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))
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))
2553 #ifdef USE_LOCALE_NUMERIC
2555 s += SvCUR(PL_numeric_radix_sv);
2559 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2560 /* no digits before the radix means we need digits after it */
2564 } while (isDIGIT(*s));
2569 else if (*s == 'I' || *s == 'i') {
2570 s++; if (*s != 'N' && *s != 'n') return 0;
2571 s++; if (*s != 'F' && *s != 'f') return 0;
2572 s++; if (*s == 'I' || *s == 'i') {
2573 s++; if (*s != 'N' && *s != 'n') return 0;
2574 s++; if (*s != 'I' && *s != 'i') return 0;
2575 s++; if (*s != 'T' && *s != 't') return 0;
2576 s++; if (*s != 'Y' && *s != 'y') return 0;
2585 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2586 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2588 /* we can have an optional exponent part */
2589 if (*s == 'e' || *s == 'E') {
2590 numtype &= IS_NUMBER_NEG;
2591 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2593 if (*s == '+' || *s == '-')
2598 } while (isDIGIT(*s));
2608 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2609 return IS_NUMBER_TO_INT_BY_ATOL;
2614 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2617 return sv_2pv(sv, &n_a);
2620 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2622 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2624 char *ptr = buf + TYPE_CHARS(UV);
2638 *--ptr = '0' + (uv % 10);
2647 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2649 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2653 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2658 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2659 char *tmpbuf = tbuf;
2665 if (SvGMAGICAL(sv)) {
2666 if (flags & SV_GMAGIC)
2674 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2676 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2681 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2686 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2687 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2694 if (SvTHINKFIRST(sv)) {
2697 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2698 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2699 return SvPV(tmpstr,*lp);
2706 switch (SvTYPE(sv)) {
2708 if ( ((SvFLAGS(sv) &
2709 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2710 == (SVs_OBJECT|SVs_RMG))
2711 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2712 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2713 regexp *re = (regexp *)mg->mg_obj;
2716 char *fptr = "msix";
2721 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2723 while((ch = *fptr++)) {
2725 reflags[left++] = ch;
2728 reflags[right--] = ch;
2733 reflags[left] = '-';
2737 mg->mg_len = re->prelen + 4 + left;
2738 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2739 Copy("(?", mg->mg_ptr, 2, char);
2740 Copy(reflags, mg->mg_ptr+2, left, char);
2741 Copy(":", mg->mg_ptr+left+2, 1, char);
2742 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2743 mg->mg_ptr[mg->mg_len - 1] = ')';
2744 mg->mg_ptr[mg->mg_len] = 0;
2746 PL_reginterp_cnt += re->program[0].next_off;
2758 case SVt_PVBM: if (SvROK(sv))
2761 s = "SCALAR"; break;
2762 case SVt_PVLV: s = "LVALUE"; break;
2763 case SVt_PVAV: s = "ARRAY"; break;
2764 case SVt_PVHV: s = "HASH"; break;
2765 case SVt_PVCV: s = "CODE"; break;
2766 case SVt_PVGV: s = "GLOB"; break;
2767 case SVt_PVFM: s = "FORMAT"; break;
2768 case SVt_PVIO: s = "IO"; break;
2769 default: s = "UNKNOWN"; break;
2773 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2776 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2782 if (SvREADONLY(sv) && !SvOK(sv)) {
2783 if (ckWARN(WARN_UNINITIALIZED))
2789 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2790 /* I'm assuming that if both IV and NV are equally valid then
2791 converting the IV is going to be more efficient */
2792 U32 isIOK = SvIOK(sv);
2793 U32 isUIOK = SvIsUV(sv);
2794 char buf[TYPE_CHARS(UV)];
2797 if (SvTYPE(sv) < SVt_PVIV)
2798 sv_upgrade(sv, SVt_PVIV);
2800 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2802 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2803 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2804 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2805 SvCUR_set(sv, ebuf - ptr);
2815 else if (SvNOKp(sv)) {
2816 if (SvTYPE(sv) < SVt_PVNV)
2817 sv_upgrade(sv, SVt_PVNV);
2818 /* The +20 is pure guesswork. Configure test needed. --jhi */
2819 SvGROW(sv, NV_DIG + 20);
2821 olderrno = errno; /* some Xenix systems wipe out errno here */
2823 if (SvNVX(sv) == 0.0)
2824 (void)strcpy(s,"0");
2828 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2831 #ifdef FIXNEGATIVEZERO
2832 if (*s == '-' && s[1] == '0' && !s[2])
2842 if (ckWARN(WARN_UNINITIALIZED)
2843 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2846 if (SvTYPE(sv) < SVt_PV)
2847 /* Typically the caller expects that sv_any is not NULL now. */
2848 sv_upgrade(sv, SVt_PV);
2851 *lp = s - SvPVX(sv);
2854 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2855 PTR2UV(sv),SvPVX(sv)));
2859 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2860 /* Sneaky stuff here */
2864 tsv = newSVpv(tmpbuf, 0);
2880 len = strlen(tmpbuf);
2882 #ifdef FIXNEGATIVEZERO
2883 if (len == 2 && t[0] == '-' && t[1] == '0') {
2888 (void)SvUPGRADE(sv, SVt_PV);
2890 s = SvGROW(sv, len + 1);
2899 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2902 return sv_2pvbyte(sv, &n_a);
2906 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2908 sv_utf8_downgrade(sv,0);
2909 return SvPV(sv,*lp);
2913 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2916 return sv_2pvutf8(sv, &n_a);
2920 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2922 sv_utf8_upgrade(sv);
2923 return SvPV(sv,*lp);
2926 /* This function is only called on magical items */
2928 Perl_sv_2bool(pTHX_ register SV *sv)
2937 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2938 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2939 return SvTRUE(tmpsv);
2940 return SvRV(sv) != 0;
2943 register XPV* Xpvtmp;
2944 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2945 (*Xpvtmp->xpv_pv > '0' ||
2946 Xpvtmp->xpv_cur > 1 ||
2947 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2954 return SvIVX(sv) != 0;
2957 return SvNVX(sv) != 0.0;
2965 =for apidoc sv_utf8_upgrade
2967 Convert the PV of an SV to its UTF8-encoded form.
2968 Forces the SV to string form it it is not already.
2969 Always sets the SvUTF8 flag to avoid future validity checks even
2970 if all the bytes have hibit clear.
2976 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2978 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
2982 =for apidoc sv_utf8_upgrade_flags
2984 Convert the PV of an SV to its UTF8-encoded form.
2985 Forces the SV to string form it it is not already.
2986 Always sets the SvUTF8 flag to avoid future validity checks even
2987 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2988 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2989 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2995 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3005 (void) sv_2pv_flags(sv,&len, flags);
3013 if (SvREADONLY(sv) && SvFAKE(sv)) {
3014 sv_force_normal(sv);
3017 /* This function could be much more efficient if we had a FLAG in SVs
3018 * to signal if there are any hibit chars in the PV.
3019 * Given that there isn't make loop fast as possible
3021 s = (U8 *) SvPVX(sv);
3022 e = (U8 *) SvEND(sv);
3026 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3032 len = SvCUR(sv) + 1; /* Plus the \0 */
3033 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3034 SvCUR(sv) = len - 1;
3036 Safefree(s); /* No longer using what was there before. */
3037 SvLEN(sv) = len; /* No longer know the real size. */
3039 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3045 =for apidoc sv_utf8_downgrade
3047 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3048 This may not be possible if the PV contains non-byte encoding characters;
3049 if this is the case, either returns false or, if C<fail_ok> is not
3056 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3058 if (SvPOK(sv) && SvUTF8(sv)) {
3063 if (SvREADONLY(sv) && SvFAKE(sv))
3064 sv_force_normal(sv);
3065 s = (U8 *) SvPV(sv, len);
3066 if (!utf8_to_bytes(s, &len)) {
3069 #ifdef USE_BYTES_DOWNGRADES
3072 U8 *e = (U8 *) SvEND(sv);
3075 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3076 if (first && ch > 255) {
3078 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3079 PL_op_desc[PL_op->op_type]);
3081 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3088 len = (d - (U8 *) SvPVX(sv));
3093 Perl_croak(aTHX_ "Wide character in %s",
3094 PL_op_desc[PL_op->op_type]);
3096 Perl_croak(aTHX_ "Wide character");
3107 =for apidoc sv_utf8_encode
3109 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3110 flag so that it looks like octets again. Used as a building block
3111 for encode_utf8 in Encode.xs
3117 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3119 (void) sv_utf8_upgrade(sv);
3124 =for apidoc sv_utf8_decode
3126 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3127 turn of SvUTF8 if needed so that we see characters. Used as a building block
3128 for decode_utf8 in Encode.xs
3136 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3142 /* The octets may have got themselves encoded - get them back as bytes */
3143 if (!sv_utf8_downgrade(sv, TRUE))
3146 /* it is actually just a matter of turning the utf8 flag on, but
3147 * we want to make sure everything inside is valid utf8 first.
3149 c = (U8 *) SvPVX(sv);
3150 if (!is_utf8_string(c, SvCUR(sv)+1))
3152 e = (U8 *) SvEND(sv);
3155 if (!UTF8_IS_INVARIANT(ch)) {
3165 /* Note: sv_setsv() should not be called with a source string that needs
3166 * to be reused, since it may destroy the source string if it is marked
3171 =for apidoc sv_setsv
3173 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3174 The source SV may be destroyed if it is mortal. Does not handle 'set'
3175 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3181 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3182 for binary compatibility only
3185 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3187 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3191 =for apidoc sv_setsv_flags
3193 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3194 The source SV may be destroyed if it is mortal. Does not handle 'set'
3195 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3196 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3197 in terms of this function.
3203 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3205 register U32 sflags;
3211 SV_CHECK_THINKFIRST(dstr);
3213 sstr = &PL_sv_undef;
3214 stype = SvTYPE(sstr);
3215 dtype = SvTYPE(dstr);
3219 /* There's a lot of redundancy below but we're going for speed here */
3224 if (dtype != SVt_PVGV) {
3225 (void)SvOK_off(dstr);
3233 sv_upgrade(dstr, SVt_IV);
3236 sv_upgrade(dstr, SVt_PVNV);
3240 sv_upgrade(dstr, SVt_PVIV);
3243 (void)SvIOK_only(dstr);
3244 SvIVX(dstr) = SvIVX(sstr);
3247 if (SvTAINTED(sstr))
3258 sv_upgrade(dstr, SVt_NV);
3263 sv_upgrade(dstr, SVt_PVNV);
3266 SvNVX(dstr) = SvNVX(sstr);
3267 (void)SvNOK_only(dstr);
3268 if (SvTAINTED(sstr))
3276 sv_upgrade(dstr, SVt_RV);
3277 else if (dtype == SVt_PVGV &&
3278 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3281 if (GvIMPORTED(dstr) != GVf_IMPORTED
3282 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3284 GvIMPORTED_on(dstr);
3295 sv_upgrade(dstr, SVt_PV);
3298 if (dtype < SVt_PVIV)
3299 sv_upgrade(dstr, SVt_PVIV);
3302 if (dtype < SVt_PVNV)
3303 sv_upgrade(dstr, SVt_PVNV);
3310 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3311 PL_op_name[PL_op->op_type]);
3313 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3317 if (dtype <= SVt_PVGV) {
3319 if (dtype != SVt_PVGV) {
3320 char *name = GvNAME(sstr);
3321 STRLEN len = GvNAMELEN(sstr);
3322 sv_upgrade(dstr, SVt_PVGV);
3323 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3324 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3325 GvNAME(dstr) = savepvn(name, len);
3326 GvNAMELEN(dstr) = len;
3327 SvFAKE_on(dstr); /* can coerce to non-glob */
3329 /* ahem, death to those who redefine active sort subs */
3330 else if (PL_curstackinfo->si_type == PERLSI_SORT
3331 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3332 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3335 #ifdef GV_SHARED_CHECK
3336 if (GvSHARED((GV*)dstr)) {
3337 Perl_croak(aTHX_ PL_no_modify);
3341 (void)SvOK_off(dstr);
3342 GvINTRO_off(dstr); /* one-shot flag */
3344 GvGP(dstr) = gp_ref(GvGP(sstr));
3345 if (SvTAINTED(sstr))
3347 if (GvIMPORTED(dstr) != GVf_IMPORTED
3348 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3350 GvIMPORTED_on(dstr);
3358 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3360 if (SvTYPE(sstr) != stype) {
3361 stype = SvTYPE(sstr);
3362 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3366 if (stype == SVt_PVLV)
3367 (void)SvUPGRADE(dstr, SVt_PVNV);
3369 (void)SvUPGRADE(dstr, stype);
3372 sflags = SvFLAGS(sstr);
3374 if (sflags & SVf_ROK) {
3375 if (dtype >= SVt_PV) {
3376 if (dtype == SVt_PVGV) {
3377 SV *sref = SvREFCNT_inc(SvRV(sstr));
3379 int intro = GvINTRO(dstr);
3381 #ifdef GV_SHARED_CHECK
3382 if (GvSHARED((GV*)dstr)) {
3383 Perl_croak(aTHX_ PL_no_modify);
3390 GvINTRO_off(dstr); /* one-shot flag */
3391 Newz(602,gp, 1, GP);
3392 GvGP(dstr) = gp_ref(gp);
3393 GvSV(dstr) = NEWSV(72,0);
3394 GvLINE(dstr) = CopLINE(PL_curcop);
3395 GvEGV(dstr) = (GV*)dstr;
3398 switch (SvTYPE(sref)) {
3401 SAVESPTR(GvAV(dstr));
3403 dref = (SV*)GvAV(dstr);
3404 GvAV(dstr) = (AV*)sref;
3405 if (!GvIMPORTED_AV(dstr)
3406 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3408 GvIMPORTED_AV_on(dstr);
3413 SAVESPTR(GvHV(dstr));
3415 dref = (SV*)GvHV(dstr);
3416 GvHV(dstr) = (HV*)sref;
3417 if (!GvIMPORTED_HV(dstr)
3418 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3420 GvIMPORTED_HV_on(dstr);
3425 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3426 SvREFCNT_dec(GvCV(dstr));
3427 GvCV(dstr) = Nullcv;
3428 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3429 PL_sub_generation++;
3431 SAVESPTR(GvCV(dstr));
3434 dref = (SV*)GvCV(dstr);
3435 if (GvCV(dstr) != (CV*)sref) {
3436 CV* cv = GvCV(dstr);
3438 if (!GvCVGEN((GV*)dstr) &&
3439 (CvROOT(cv) || CvXSUB(cv)))
3441 /* ahem, death to those who redefine
3442 * active sort subs */
3443 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3444 PL_sortcop == CvSTART(cv))
3446 "Can't redefine active sort subroutine %s",
3447 GvENAME((GV*)dstr));
3448 /* Redefining a sub - warning is mandatory if
3449 it was a const and its value changed. */
3450 if (ckWARN(WARN_REDEFINE)
3452 && (!CvCONST((CV*)sref)
3453 || sv_cmp(cv_const_sv(cv),
3454 cv_const_sv((CV*)sref)))))
3456 Perl_warner(aTHX_ WARN_REDEFINE,
3458 ? "Constant subroutine %s redefined"
3459 : "Subroutine %s redefined",
3460 GvENAME((GV*)dstr));
3463 cv_ckproto(cv, (GV*)dstr,
3464 SvPOK(sref) ? SvPVX(sref) : Nullch);
3466 GvCV(dstr) = (CV*)sref;
3467 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3468 GvASSUMECV_on(dstr);
3469 PL_sub_generation++;
3471 if (!GvIMPORTED_CV(dstr)
3472 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3474 GvIMPORTED_CV_on(dstr);
3479 SAVESPTR(GvIOp(dstr));
3481 dref = (SV*)GvIOp(dstr);
3482 GvIOp(dstr) = (IO*)sref;
3486 SAVESPTR(GvFORM(dstr));
3488 dref = (SV*)GvFORM(dstr);
3489 GvFORM(dstr) = (CV*)sref;
3493 SAVESPTR(GvSV(dstr));
3495 dref = (SV*)GvSV(dstr);
3497 if (!GvIMPORTED_SV(dstr)
3498 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3500 GvIMPORTED_SV_on(dstr);
3508 if (SvTAINTED(sstr))
3513 (void)SvOOK_off(dstr); /* backoff */
3515 Safefree(SvPVX(dstr));
3516 SvLEN(dstr)=SvCUR(dstr)=0;
3519 (void)SvOK_off(dstr);
3520 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3522 if (sflags & SVp_NOK) {
3524 /* Only set the public OK flag if the source has public OK. */
3525 if (sflags & SVf_NOK)
3526 SvFLAGS(dstr) |= SVf_NOK;
3527 SvNVX(dstr) = SvNVX(sstr);
3529 if (sflags & SVp_IOK) {
3530 (void)SvIOKp_on(dstr);
3531 if (sflags & SVf_IOK)
3532 SvFLAGS(dstr) |= SVf_IOK;
3533 if (sflags & SVf_IVisUV)
3535 SvIVX(dstr) = SvIVX(sstr);
3537 if (SvAMAGIC(sstr)) {
3541 else if (sflags & SVp_POK) {
3544 * Check to see if we can just swipe the string. If so, it's a
3545 * possible small lose on short strings, but a big win on long ones.
3546 * It might even be a win on short strings if SvPVX(dstr)
3547 * has to be allocated and SvPVX(sstr) has to be freed.
3550 if (SvTEMP(sstr) && /* slated for free anyway? */
3551 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3552 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3553 SvLEN(sstr) && /* and really is a string */
3554 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3556 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3558 SvFLAGS(dstr) &= ~SVf_OOK;
3559 Safefree(SvPVX(dstr) - SvIVX(dstr));
3561 else if (SvLEN(dstr))
3562 Safefree(SvPVX(dstr));
3564 (void)SvPOK_only(dstr);
3565 SvPV_set(dstr, SvPVX(sstr));
3566 SvLEN_set(dstr, SvLEN(sstr));
3567 SvCUR_set(dstr, SvCUR(sstr));
3570 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3571 SvPV_set(sstr, Nullch);
3576 else { /* have to copy actual string */
3577 STRLEN len = SvCUR(sstr);
3579 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3580 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3581 SvCUR_set(dstr, len);
3582 *SvEND(dstr) = '\0';
3583 (void)SvPOK_only(dstr);
3585 if (sflags & SVf_UTF8)
3588 if (sflags & SVp_NOK) {
3590 if (sflags & SVf_NOK)
3591 SvFLAGS(dstr) |= SVf_NOK;
3592 SvNVX(dstr) = SvNVX(sstr);
3594 if (sflags & SVp_IOK) {
3595 (void)SvIOKp_on(dstr);
3596 if (sflags & SVf_IOK)
3597 SvFLAGS(dstr) |= SVf_IOK;
3598 if (sflags & SVf_IVisUV)
3600 SvIVX(dstr) = SvIVX(sstr);
3603 else if (sflags & SVp_IOK) {
3604 if (sflags & SVf_IOK)
3605 (void)SvIOK_only(dstr);
3607 (void)SvOK_off(dstr);
3608 (void)SvIOKp_on(dstr);
3610 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3611 if (sflags & SVf_IVisUV)
3613 SvIVX(dstr) = SvIVX(sstr);
3614 if (sflags & SVp_NOK) {
3615 if (sflags & SVf_NOK)
3616 (void)SvNOK_on(dstr);
3618 (void)SvNOKp_on(dstr);
3619 SvNVX(dstr) = SvNVX(sstr);
3622 else if (sflags & SVp_NOK) {
3623 if (sflags & SVf_NOK)
3624 (void)SvNOK_only(dstr);
3626 (void)SvOK_off(dstr);
3629 SvNVX(dstr) = SvNVX(sstr);
3632 if (dtype == SVt_PVGV) {
3633 if (ckWARN(WARN_MISC))
3634 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3637 (void)SvOK_off(dstr);
3639 if (SvTAINTED(sstr))
3644 =for apidoc sv_setsv_mg
3646 Like C<sv_setsv>, but also handles 'set' magic.
3652 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3654 sv_setsv(dstr,sstr);
3659 =for apidoc sv_setpvn
3661 Copies a string into an SV. The C<len> parameter indicates the number of
3662 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3668 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3670 register char *dptr;
3672 SV_CHECK_THINKFIRST(sv);
3678 /* len is STRLEN which is unsigned, need to copy to signed */
3681 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3683 (void)SvUPGRADE(sv, SVt_PV);
3685 SvGROW(sv, len + 1);
3687 Move(ptr,dptr,len,char);
3690 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3695 =for apidoc sv_setpvn_mg
3697 Like C<sv_setpvn>, but also handles 'set' magic.
3703 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3705 sv_setpvn(sv,ptr,len);
3710 =for apidoc sv_setpv
3712 Copies a string into an SV. The string must be null-terminated. Does not
3713 handle 'set' magic. See C<sv_setpv_mg>.
3719 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3721 register STRLEN len;
3723 SV_CHECK_THINKFIRST(sv);
3729 (void)SvUPGRADE(sv, SVt_PV);
3731 SvGROW(sv, len + 1);
3732 Move(ptr,SvPVX(sv),len+1,char);
3734 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3739 =for apidoc sv_setpv_mg
3741 Like C<sv_setpv>, but also handles 'set' magic.
3747 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3754 =for apidoc sv_usepvn
3756 Tells an SV to use C<ptr> to find its string value. Normally the string is
3757 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3758 The C<ptr> should point to memory that was allocated by C<malloc>. The
3759 string length, C<len>, must be supplied. This function will realloc the
3760 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3761 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3762 See C<sv_usepvn_mg>.
3768 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3770 SV_CHECK_THINKFIRST(sv);
3771 (void)SvUPGRADE(sv, SVt_PV);
3776 (void)SvOOK_off(sv);
3777 if (SvPVX(sv) && SvLEN(sv))
3778 Safefree(SvPVX(sv));
3779 Renew(ptr, len+1, char);
3782 SvLEN_set(sv, len+1);
3784 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3789 =for apidoc sv_usepvn_mg
3791 Like C<sv_usepvn>, but also handles 'set' magic.
3797 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3799 sv_usepvn(sv,ptr,len);
3804 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3806 if (SvREADONLY(sv)) {
3808 char *pvx = SvPVX(sv);
3809 STRLEN len = SvCUR(sv);
3810 U32 hash = SvUVX(sv);
3811 SvGROW(sv, len + 1);
3812 Move(pvx,SvPVX(sv),len,char);
3816 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3818 else if (PL_curcop != &PL_compiling)
3819 Perl_croak(aTHX_ PL_no_modify);
3822 sv_unref_flags(sv, flags);
3823 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3828 Perl_sv_force_normal(pTHX_ register SV *sv)
3830 sv_force_normal_flags(sv, 0);
3836 Efficient removal of characters from the beginning of the string buffer.
3837 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3838 the string buffer. The C<ptr> becomes the first character of the adjusted
3845 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3849 register STRLEN delta;
3851 if (!ptr || !SvPOKp(sv))
3853 SV_CHECK_THINKFIRST(sv);
3854 if (SvTYPE(sv) < SVt_PVIV)
3855 sv_upgrade(sv,SVt_PVIV);
3858 if (!SvLEN(sv)) { /* make copy of shared string */
3859 char *pvx = SvPVX(sv);
3860 STRLEN len = SvCUR(sv);
3861 SvGROW(sv, len + 1);
3862 Move(pvx,SvPVX(sv),len,char);
3866 SvFLAGS(sv) |= SVf_OOK;
3868 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3869 delta = ptr - SvPVX(sv);
3877 =for apidoc sv_catpvn
3879 Concatenates the string onto the end of the string which is in the SV. The
3880 C<len> indicates number of bytes to copy. If the SV has the UTF8
3881 status set, then the bytes appended should be valid UTF8.
3882 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3887 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3888 for binary compatibility only
3891 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3893 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3897 =for apidoc sv_catpvn_flags
3899 Concatenates the string onto the end of the string which is in the SV. The
3900 C<len> indicates number of bytes to copy. If the SV has the UTF8
3901 status set, then the bytes appended should be valid UTF8.
3902 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3903 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3904 in terms of this function.
3910 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3915 dstr = SvPV_force_flags(dsv, dlen, flags);
3916 SvGROW(dsv, dlen + slen + 1);
3919 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3922 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3927 =for apidoc sv_catpvn_mg
3929 Like C<sv_catpvn>, but also handles 'set' magic.
3935 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3937 sv_catpvn(sv,ptr,len);
3942 =for apidoc sv_catsv
3944 Concatenates the string from SV C<ssv> onto the end of the string in
3945 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3946 not 'set' magic. See C<sv_catsv_mg>.
3950 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3951 for binary compatibility only
3954 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3956 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3960 =for apidoc sv_catsv_flags
3962 Concatenates the string from SV C<ssv> onto the end of the string in
3963 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3964 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3965 and C<sv_catsv_nomg> are implemented in terms of this function.
3970 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3976 if ((spv = SvPV(ssv, slen))) {
3977 bool sutf8 = DO_UTF8(ssv);
3980 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3982 dutf8 = DO_UTF8(dsv);
3984 if (dutf8 != sutf8) {
3986 /* Not modifying source SV, so taking a temporary copy. */
3987 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3989 sv_utf8_upgrade(csv);
3990 spv = SvPV(csv, slen);
3993 sv_utf8_upgrade_nomg(dsv);
3995 sv_catpvn_nomg(dsv, spv, slen);
4000 =for apidoc sv_catsv_mg
4002 Like C<sv_catsv>, but also handles 'set' magic.
4008 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4015 =for apidoc sv_catpv
4017 Concatenates the string onto the end of the string which is in the SV.
4018 If the SV has the UTF8 status set, then the bytes appended should be
4019 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4024 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4026 register STRLEN len;
4032 junk = SvPV_force(sv, tlen);
4034 SvGROW(sv, tlen + len + 1);
4037 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4039 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4044 =for apidoc sv_catpv_mg
4046 Like C<sv_catpv>, but also handles 'set' magic.
4052 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4059 Perl_newSV(pTHX_ STRLEN len)
4065 sv_upgrade(sv, SVt_PV);
4066 SvGROW(sv, len + 1);
4071 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4074 =for apidoc sv_magic
4076 Adds magic to an SV.
4082 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4086 if (SvREADONLY(sv)) {
4087 if (PL_curcop != &PL_compiling
4088 /* XXX this used to be !strchr("gBf", how), which seems to
4089 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4090 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4091 * to the list of things to check - DAPM 19-May-01 */
4092 && how != PERL_MAGIC_regex_global
4093 && how != PERL_MAGIC_bm
4094 && how != PERL_MAGIC_fm
4095 && how != PERL_MAGIC_sv
4098 Perl_croak(aTHX_ PL_no_modify);
4101 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4102 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4103 if (how == PERL_MAGIC_taint)
4109 (void)SvUPGRADE(sv, SVt_PVMG);
4111 Newz(702,mg, 1, MAGIC);
4112 mg->mg_moremagic = SvMAGIC(sv);
4115 /* Some magic sontains a reference loop, where the sv and object refer to
4116 each other. To prevent a avoid a reference loop that would prevent such
4117 objects being freed, we look for such loops and if we find one we avoid
4118 incrementing the object refcount. */
4119 if (!obj || obj == sv ||
4120 how == PERL_MAGIC_arylen ||
4121 how == PERL_MAGIC_qr ||
4122 (SvTYPE(obj) == SVt_PVGV &&
4123 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4124 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4125 GvFORM(obj) == (CV*)sv)))
4130 mg->mg_obj = SvREFCNT_inc(obj);
4131 mg->mg_flags |= MGf_REFCOUNTED;
4134 mg->mg_len = namlen;
4137 mg->mg_ptr = savepvn(name, namlen);
4138 else if (namlen == HEf_SVKEY)
4139 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4144 mg->mg_virtual = &PL_vtbl_sv;
4146 case PERL_MAGIC_overload:
4147 mg->mg_virtual = &PL_vtbl_amagic;
4149 case PERL_MAGIC_overload_elem:
4150 mg->mg_virtual = &PL_vtbl_amagicelem;
4152 case PERL_MAGIC_overload_table:
4153 mg->mg_virtual = &PL_vtbl_ovrld;
4156 mg->mg_virtual = &PL_vtbl_bm;
4158 case PERL_MAGIC_regdata:
4159 mg->mg_virtual = &PL_vtbl_regdata;
4161 case PERL_MAGIC_regdatum:
4162 mg->mg_virtual = &PL_vtbl_regdatum;
4164 case PERL_MAGIC_env:
4165 mg->mg_virtual = &PL_vtbl_env;
4168 mg->mg_virtual = &PL_vtbl_fm;
4170 case PERL_MAGIC_envelem:
4171 mg->mg_virtual = &PL_vtbl_envelem;
4173 case PERL_MAGIC_regex_global:
4174 mg->mg_virtual = &PL_vtbl_mglob;
4176 case PERL_MAGIC_isa:
4177 mg->mg_virtual = &PL_vtbl_isa;
4179 case PERL_MAGIC_isaelem:
4180 mg->mg_virtual = &PL_vtbl_isaelem;
4182 case PERL_MAGIC_nkeys:
4183 mg->mg_virtual = &PL_vtbl_nkeys;
4185 case PERL_MAGIC_dbfile:
4189 case PERL_MAGIC_dbline:
4190 mg->mg_virtual = &PL_vtbl_dbline;
4193 case PERL_MAGIC_mutex:
4194 mg->mg_virtual = &PL_vtbl_mutex;
4196 #endif /* USE_THREADS */
4197 #ifdef USE_LOCALE_COLLATE
4198 case PERL_MAGIC_collxfrm:
4199 mg->mg_virtual = &PL_vtbl_collxfrm;
4201 #endif /* USE_LOCALE_COLLATE */
4202 case PERL_MAGIC_tied:
4203 mg->mg_virtual = &PL_vtbl_pack;
4205 case PERL_MAGIC_tiedelem:
4206 case PERL_MAGIC_tiedscalar:
4207 mg->mg_virtual = &PL_vtbl_packelem;
4210 mg->mg_virtual = &PL_vtbl_regexp;
4212 case PERL_MAGIC_sig:
4213 mg->mg_virtual = &PL_vtbl_sig;
4215 case PERL_MAGIC_sigelem:
4216 mg->mg_virtual = &PL_vtbl_sigelem;
4218 case PERL_MAGIC_taint:
4219 mg->mg_virtual = &PL_vtbl_taint;
4222 case PERL_MAGIC_uvar:
4223 mg->mg_virtual = &PL_vtbl_uvar;
4225 case PERL_MAGIC_vec:
4226 mg->mg_virtual = &PL_vtbl_vec;
4228 case PERL_MAGIC_substr:
4229 mg->mg_virtual = &PL_vtbl_substr;
4231 case PERL_MAGIC_defelem:
4232 mg->mg_virtual = &PL_vtbl_defelem;
4234 case PERL_MAGIC_glob:
4235 mg->mg_virtual = &PL_vtbl_glob;
4237 case PERL_MAGIC_arylen:
4238 mg->mg_virtual = &PL_vtbl_arylen;
4240 case PERL_MAGIC_pos:
4241 mg->mg_virtual = &PL_vtbl_pos;
4243 case PERL_MAGIC_backref:
4244 mg->mg_virtual = &PL_vtbl_backref;
4246 case PERL_MAGIC_ext:
4247 /* Reserved for use by extensions not perl internals. */
4248 /* Useful for attaching extension internal data to perl vars. */
4249 /* Note that multiple extensions may clash if magical scalars */
4250 /* etc holding private data from one are passed to another. */
4254 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4258 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4262 =for apidoc sv_unmagic
4264 Removes magic from an SV.
4270 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4274 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4277 for (mg = *mgp; mg; mg = *mgp) {
4278 if (mg->mg_type == type) {
4279 MGVTBL* vtbl = mg->mg_virtual;
4280 *mgp = mg->mg_moremagic;
4281 if (vtbl && vtbl->svt_free)
4282 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4283 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4284 if (mg->mg_len >= 0)
4285 Safefree(mg->mg_ptr);
4286 else if (mg->mg_len == HEf_SVKEY)
4287 SvREFCNT_dec((SV*)mg->mg_ptr);
4289 if (mg->mg_flags & MGf_REFCOUNTED)
4290 SvREFCNT_dec(mg->mg_obj);
4294 mgp = &mg->mg_moremagic;
4298 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4305 =for apidoc sv_rvweaken
4313 Perl_sv_rvweaken(pTHX_ SV *sv)
4316 if (!SvOK(sv)) /* let undefs pass */
4319 Perl_croak(aTHX_ "Can't weaken a nonreference");
4320 else if (SvWEAKREF(sv)) {
4321 if (ckWARN(WARN_MISC))
4322 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4326 sv_add_backref(tsv, sv);
4333 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4337 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4338 av = (AV*)mg->mg_obj;
4341 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4342 SvREFCNT_dec(av); /* for sv_magic */
4348 S_sv_del_backref(pTHX_ SV *sv)
4355 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4356 Perl_croak(aTHX_ "panic: del_backref");
4357 av = (AV *)mg->mg_obj;
4362 svp[i] = &PL_sv_undef; /* XXX */
4369 =for apidoc sv_insert
4371 Inserts a string at the specified offset/length within the SV. Similar to
4372 the Perl substr() function.
4378 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4382 register char *midend;
4383 register char *bigend;
4389 Perl_croak(aTHX_ "Can't modify non-existent substring");
4390 SvPV_force(bigstr, curlen);
4391 (void)SvPOK_only_UTF8(bigstr);
4392 if (offset + len > curlen) {
4393 SvGROW(bigstr, offset+len+1);
4394 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4395 SvCUR_set(bigstr, offset+len);
4399 i = littlelen - len;
4400 if (i > 0) { /* string might grow */
4401 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4402 mid = big + offset + len;
4403 midend = bigend = big + SvCUR(bigstr);
4406 while (midend > mid) /* shove everything down */
4407 *--bigend = *--midend;
4408 Move(little,big+offset,littlelen,char);
4414 Move(little,SvPVX(bigstr)+offset,len,char);
4419 big = SvPVX(bigstr);
4422 bigend = big + SvCUR(bigstr);
4424 if (midend > bigend)
4425 Perl_croak(aTHX_ "panic: sv_insert");
4427 if (mid - big > bigend - midend) { /* faster to shorten from end */
4429 Move(little, mid, littlelen,char);
4432 i = bigend - midend;
4434 Move(midend, mid, i,char);
4438 SvCUR_set(bigstr, mid - big);
4441 else if ((i = mid - big)) { /* faster from front */
4442 midend -= littlelen;
4444 sv_chop(bigstr,midend-i);
4449 Move(little, mid, littlelen,char);
4451 else if (littlelen) {
4452 midend -= littlelen;
4453 sv_chop(bigstr,midend);
4454 Move(little,midend,littlelen,char);
4457 sv_chop(bigstr,midend);
4463 =for apidoc sv_replace
4465 Make the first argument a copy of the second, then delete the original.
4471 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4473 U32 refcnt = SvREFCNT(sv);
4474 SV_CHECK_THINKFIRST(sv);
4475 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4476 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4477 if (SvMAGICAL(sv)) {
4481 sv_upgrade(nsv, SVt_PVMG);
4482 SvMAGIC(nsv) = SvMAGIC(sv);
4483 SvFLAGS(nsv) |= SvMAGICAL(sv);
4489 assert(!SvREFCNT(sv));
4490 StructCopy(nsv,sv,SV);
4491 SvREFCNT(sv) = refcnt;
4492 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4497 =for apidoc sv_clear
4499 Clear an SV, making it empty. Does not free the memory used by the SV
4506 Perl_sv_clear(pTHX_ register SV *sv)
4510 assert(SvREFCNT(sv) == 0);
4513 if (PL_defstash) { /* Still have a symbol table? */
4518 Zero(&tmpref, 1, SV);
4519 sv_upgrade(&tmpref, SVt_RV);
4521 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4522 SvREFCNT(&tmpref) = 1;
4525 stash = SvSTASH(sv);
4526 destructor = StashHANDLER(stash,DESTROY);
4529 PUSHSTACKi(PERLSI_DESTROY);
4530 SvRV(&tmpref) = SvREFCNT_inc(sv);
4535 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4541 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4543 del_XRV(SvANY(&tmpref));
4546 if (PL_in_clean_objs)
4547 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4549 /* DESTROY gave object new lease on life */
4555 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4556 SvOBJECT_off(sv); /* Curse the object. */
4557 if (SvTYPE(sv) != SVt_PVIO)
4558 --PL_sv_objcount; /* XXX Might want something more general */
4561 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4564 switch (SvTYPE(sv)) {
4567 IoIFP(sv) != PerlIO_stdin() &&
4568 IoIFP(sv) != PerlIO_stdout() &&
4569 IoIFP(sv) != PerlIO_stderr())
4571 io_close((IO*)sv, FALSE);
4573 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4574 PerlDir_close(IoDIRP(sv));
4575 IoDIRP(sv) = (DIR*)NULL;
4576 Safefree(IoTOP_NAME(sv));
4577 Safefree(IoFMT_NAME(sv));
4578 Safefree(IoBOTTOM_NAME(sv));
4593 SvREFCNT_dec(LvTARG(sv));
4597 Safefree(GvNAME(sv));
4598 /* cannot decrease stash refcount yet, as we might recursively delete
4599 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4600 of stash until current sv is completely gone.
4601 -- JohnPC, 27 Mar 1998 */
4602 stash = GvSTASH(sv);
4608 (void)SvOOK_off(sv);
4616 SvREFCNT_dec(SvRV(sv));
4618 else if (SvPVX(sv) && SvLEN(sv))
4619 Safefree(SvPVX(sv));
4620 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4621 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4633 switch (SvTYPE(sv)) {
4649 del_XPVIV(SvANY(sv));
4652 del_XPVNV(SvANY(sv));
4655 del_XPVMG(SvANY(sv));
4658 del_XPVLV(SvANY(sv));
4661 del_XPVAV(SvANY(sv));
4664 del_XPVHV(SvANY(sv));
4667 del_XPVCV(SvANY(sv));
4670 del_XPVGV(SvANY(sv));
4671 /* code duplication for increased performance. */
4672 SvFLAGS(sv) &= SVf_BREAK;
4673 SvFLAGS(sv) |= SVTYPEMASK;
4674 /* decrease refcount of the stash that owns this GV, if any */
4676 SvREFCNT_dec(stash);
4677 return; /* not break, SvFLAGS reset already happened */
4679 del_XPVBM(SvANY(sv));
4682 del_XPVFM(SvANY(sv));
4685 del_XPVIO(SvANY(sv));
4688 SvFLAGS(sv) &= SVf_BREAK;
4689 SvFLAGS(sv) |= SVTYPEMASK;
4693 Perl_sv_newref(pTHX_ SV *sv)
4696 ATOMIC_INC(SvREFCNT(sv));
4703 Free the memory used by an SV.
4709 Perl_sv_free(pTHX_ SV *sv)
4711 int refcount_is_zero;
4715 if (SvREFCNT(sv) == 0) {
4716 if (SvFLAGS(sv) & SVf_BREAK)
4718 if (PL_in_clean_all) /* All is fair */
4720 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4721 /* make sure SvREFCNT(sv)==0 happens very seldom */
4722 SvREFCNT(sv) = (~(U32)0)/2;
4725 if (ckWARN_d(WARN_INTERNAL))
4726 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4729 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4730 if (!refcount_is_zero)
4734 if (ckWARN_d(WARN_DEBUGGING))
4735 Perl_warner(aTHX_ WARN_DEBUGGING,
4736 "Attempt to free temp prematurely: SV 0x%"UVxf,
4741 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4742 /* make sure SvREFCNT(sv)==0 happens very seldom */
4743 SvREFCNT(sv) = (~(U32)0)/2;
4754 Returns the length of the string in the SV. See also C<SvCUR>.
4760 Perl_sv_len(pTHX_ register SV *sv)
4769 len = mg_length(sv);
4771 junk = SvPV(sv, len);
4776 =for apidoc sv_len_utf8
4778 Returns the number of characters in the string in an SV, counting wide
4779 UTF8 bytes as a single character.
4785 Perl_sv_len_utf8(pTHX_ register SV *sv)
4791 return mg_length(sv);
4795 U8 *s = (U8*)SvPV(sv, len);
4797 return Perl_utf8_length(aTHX_ s, s + len);
4802 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4807 I32 uoffset = *offsetp;
4813 start = s = (U8*)SvPV(sv, len);
4815 while (s < send && uoffset--)
4819 *offsetp = s - start;
4823 while (s < send && ulen--)
4833 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4842 s = (U8*)SvPV(sv, len);
4844 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4845 send = s + *offsetp;
4849 /* Call utf8n_to_uvchr() to validate the sequence */
4850 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4865 Returns a boolean indicating whether the strings in the two SVs are
4872 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4886 pv1 = SvPV(sv1, cur1);
4893 pv2 = SvPV(sv2, cur2);
4895 /* do not utf8ize the comparands as a side-effect */
4896 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4897 bool is_utf8 = TRUE;
4898 /* UTF-8ness differs */
4899 if (PL_hints & HINT_UTF8_DISTINCT)
4903 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4904 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4909 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4910 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4915 /* Downgrade not possible - cannot be eq */
4921 eq = memEQ(pv1, pv2, cur1);
4932 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4933 string in C<sv1> is less than, equal to, or greater than the string in
4940 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4945 bool pv1tmp = FALSE;
4946 bool pv2tmp = FALSE;
4953 pv1 = SvPV(sv1, cur1);
4960 pv2 = SvPV(sv2, cur2);
4962 /* do not utf8ize the comparands as a side-effect */
4963 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4964 if (PL_hints & HINT_UTF8_DISTINCT)
4965 return SvUTF8(sv1) ? 1 : -1;
4968 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4972 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4978 cmp = cur2 ? -1 : 0;
4982 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4985 cmp = retval < 0 ? -1 : 1;
4986 } else if (cur1 == cur2) {
4989 cmp = cur1 < cur2 ? -1 : 1;
5002 =for apidoc sv_cmp_locale
5004 Compares the strings in two SVs in a locale-aware manner. See
5011 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5013 #ifdef USE_LOCALE_COLLATE
5019 if (PL_collation_standard)
5023 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5025 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5027 if (!pv1 || !len1) {
5038 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5041 return retval < 0 ? -1 : 1;
5044 * When the result of collation is equality, that doesn't mean
5045 * that there are no differences -- some locales exclude some
5046 * characters from consideration. So to avoid false equalities,
5047 * we use the raw string as a tiebreaker.
5053 #endif /* USE_LOCALE_COLLATE */
5055 return sv_cmp(sv1, sv2);
5058 #ifdef USE_LOCALE_COLLATE
5060 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5061 * scalar data of the variable transformed to such a format that
5062 * a normal memory comparison can be used to compare the data
5063 * according to the locale settings.
5066 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5070 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5071 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5076 Safefree(mg->mg_ptr);
5078 if ((xf = mem_collxfrm(s, len, &xlen))) {
5079 if (SvREADONLY(sv)) {
5082 return xf + sizeof(PL_collation_ix);
5085 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5086 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5099 if (mg && mg->mg_ptr) {
5101 return mg->mg_ptr + sizeof(PL_collation_ix);
5109 #endif /* USE_LOCALE_COLLATE */
5114 Get a line from the filehandle and store it into the SV, optionally
5115 appending to the currently-stored string.
5121 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5125 register STDCHAR rslast;
5126 register STDCHAR *bp;
5130 SV_CHECK_THINKFIRST(sv);
5131 (void)SvUPGRADE(sv, SVt_PV);
5135 if (RsSNARF(PL_rs)) {
5139 else if (RsRECORD(PL_rs)) {
5140 I32 recsize, bytesread;
5143 /* Grab the size of the record we're getting */
5144 recsize = SvIV(SvRV(PL_rs));
5145 (void)SvPOK_only(sv); /* Validate pointer */
5146 buffer = SvGROW(sv, recsize + 1);
5149 /* VMS wants read instead of fread, because fread doesn't respect */
5150 /* RMS record boundaries. This is not necessarily a good thing to be */
5151 /* doing, but we've got no other real choice */
5152 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5154 bytesread = PerlIO_read(fp, buffer, recsize);
5156 SvCUR_set(sv, bytesread);
5157 buffer[bytesread] = '\0';
5158 if (PerlIO_isutf8(fp))
5162 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5164 else if (RsPARA(PL_rs)) {
5169 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5170 if (PerlIO_isutf8(fp)) {
5171 rsptr = SvPVutf8(PL_rs, rslen);
5174 if (SvUTF8(PL_rs)) {
5175 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5176 Perl_croak(aTHX_ "Wide character in $/");
5179 rsptr = SvPV(PL_rs, rslen);
5183 rslast = rslen ? rsptr[rslen - 1] : '\0';
5185 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5186 do { /* to make sure file boundaries work right */
5189 i = PerlIO_getc(fp);
5193 PerlIO_ungetc(fp,i);
5199 /* See if we know enough about I/O mechanism to cheat it ! */
5201 /* This used to be #ifdef test - it is made run-time test for ease
5202 of abstracting out stdio interface. One call should be cheap
5203 enough here - and may even be a macro allowing compile
5207 if (PerlIO_fast_gets(fp)) {
5210 * We're going to steal some values from the stdio struct
5211 * and put EVERYTHING in the innermost loop into registers.
5213 register STDCHAR *ptr;
5217 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5218 /* An ungetc()d char is handled separately from the regular
5219 * buffer, so we getc() it back out and stuff it in the buffer.
5221 i = PerlIO_getc(fp);
5222 if (i == EOF) return 0;
5223 *(--((*fp)->_ptr)) = (unsigned char) i;
5227 /* Here is some breathtakingly efficient cheating */
5229 cnt = PerlIO_get_cnt(fp); /* get count into register */
5230 (void)SvPOK_only(sv); /* validate pointer */
5231 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5232 if (cnt > 80 && SvLEN(sv) > append) {
5233 shortbuffered = cnt - SvLEN(sv) + append + 1;
5234 cnt -= shortbuffered;
5238 /* remember that cnt can be negative */
5239 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5244 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5245 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5246 DEBUG_P(PerlIO_printf(Perl_debug_log,
5247 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5248 DEBUG_P(PerlIO_printf(Perl_debug_log,
5249 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5250 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5251 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5256 while (cnt > 0) { /* this | eat */
5258 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5259 goto thats_all_folks; /* screams | sed :-) */
5263 Copy(ptr, bp, cnt, char); /* this | eat */
5264 bp += cnt; /* screams | dust */
5265 ptr += cnt; /* louder | sed :-) */
5270 if (shortbuffered) { /* oh well, must extend */
5271 cnt = shortbuffered;
5273 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5275 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5276 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5280 DEBUG_P(PerlIO_printf(Perl_debug_log,
5281 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5282 PTR2UV(ptr),(long)cnt));
5283 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5284 DEBUG_P(PerlIO_printf(Perl_debug_log,
5285 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5286 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5287 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5288 /* This used to call 'filbuf' in stdio form, but as that behaves like
5289 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5290 another abstraction. */
5291 i = PerlIO_getc(fp); /* get more characters */
5292 DEBUG_P(PerlIO_printf(Perl_debug_log,
5293 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5294 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5295 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5296 cnt = PerlIO_get_cnt(fp);
5297 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5298 DEBUG_P(PerlIO_printf(Perl_debug_log,
5299 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5301 if (i == EOF) /* all done for ever? */
5302 goto thats_really_all_folks;
5304 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5306 SvGROW(sv, bpx + cnt + 2);
5307 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5309 *bp++ = i; /* store character from PerlIO_getc */
5311 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5312 goto thats_all_folks;
5316 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5317 memNE((char*)bp - rslen, rsptr, rslen))
5318 goto screamer; /* go back to the fray */
5319 thats_really_all_folks:
5321 cnt += shortbuffered;
5322 DEBUG_P(PerlIO_printf(Perl_debug_log,
5323 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5324 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5325 DEBUG_P(PerlIO_printf(Perl_debug_log,
5326 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5327 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5328 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5330 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5331 DEBUG_P(PerlIO_printf(Perl_debug_log,
5332 "Screamer: done, len=%ld, string=|%.*s|\n",
5333 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5338 /*The big, slow, and stupid way */
5341 /* Need to work around EPOC SDK features */
5342 /* On WINS: MS VC5 generates calls to _chkstk, */
5343 /* if a `large' stack frame is allocated */
5344 /* gcc on MARM does not generate calls like these */
5350 register STDCHAR *bpe = buf + sizeof(buf);
5352 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5353 ; /* keep reading */
5357 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5358 /* Accomodate broken VAXC compiler, which applies U8 cast to
5359 * both args of ?: operator, causing EOF to change into 255
5361 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5365 sv_catpvn(sv, (char *) buf, cnt);
5367 sv_setpvn(sv, (char *) buf, cnt);
5369 if (i != EOF && /* joy */
5371 SvCUR(sv) < rslen ||
5372 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5376 * If we're reading from a TTY and we get a short read,
5377 * indicating that the user hit his EOF character, we need
5378 * to notice it now, because if we try to read from the TTY
5379 * again, the EOF condition will disappear.
5381 * The comparison of cnt to sizeof(buf) is an optimization
5382 * that prevents unnecessary calls to feof().
5386 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5391 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5392 while (i != EOF) { /* to make sure file boundaries work right */
5393 i = PerlIO_getc(fp);
5395 PerlIO_ungetc(fp,i);
5401 if (PerlIO_isutf8(fp))
5406 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5413 Auto-increment of the value in the SV.
5419 Perl_sv_inc(pTHX_ register SV *sv)
5428 if (SvTHINKFIRST(sv)) {
5429 if (SvREADONLY(sv)) {
5430 if (PL_curcop != &PL_compiling)
5431 Perl_croak(aTHX_ PL_no_modify);
5435 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5437 i = PTR2IV(SvRV(sv));
5442 flags = SvFLAGS(sv);
5443 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5444 /* It's (privately or publicly) a float, but not tested as an
5445 integer, so test it to see. */
5447 flags = SvFLAGS(sv);
5449 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5450 /* It's publicly an integer, or privately an integer-not-float */
5453 if (SvUVX(sv) == UV_MAX)
5454 sv_setnv(sv, (NV)UV_MAX + 1.0);
5456 (void)SvIOK_only_UV(sv);
5459 if (SvIVX(sv) == IV_MAX)
5460 sv_setuv(sv, (UV)IV_MAX + 1);
5462 (void)SvIOK_only(sv);
5468 if (flags & SVp_NOK) {
5469 (void)SvNOK_only(sv);
5474 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5475 if ((flags & SVTYPEMASK) < SVt_PVIV)
5476 sv_upgrade(sv, SVt_IV);
5477 (void)SvIOK_only(sv);
5482 while (isALPHA(*d)) d++;
5483 while (isDIGIT(*d)) d++;
5485 #ifdef PERL_PRESERVE_IVUV
5486 /* Got to punt this an an integer if needs be, but we don't issue
5487 warnings. Probably ought to make the sv_iv_please() that does
5488 the conversion if possible, and silently. */
5489 I32 numtype = looks_like_number(sv);
5490 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5491 /* Need to try really hard to see if it's an integer.
5492 9.22337203685478e+18 is an integer.
5493 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5494 so $a="9.22337203685478e+18"; $a+0; $a++
5495 needs to be the same as $a="9.22337203685478e+18"; $a++
5502 /* sv_2iv *should* have made this an NV */
5503 if (flags & SVp_NOK) {
5504 (void)SvNOK_only(sv);
5508 /* I don't think we can get here. Maybe I should assert this
5509 And if we do get here I suspect that sv_setnv will croak. NWC
5511 #if defined(USE_LONG_DOUBLE)
5512 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",
5513 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5515 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5516 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5519 #endif /* PERL_PRESERVE_IVUV */
5520 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5524 while (d >= SvPVX(sv)) {
5532 /* MKS: The original code here died if letters weren't consecutive.
5533 * at least it didn't have to worry about non-C locales. The
5534 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5535 * arranged in order (although not consecutively) and that only
5536 * [A-Za-z] are accepted by isALPHA in the C locale.
5538 if (*d != 'z' && *d != 'Z') {
5539 do { ++*d; } while (!isALPHA(*d));
5542 *(d--) -= 'z' - 'a';
5547 *(d--) -= 'z' - 'a' + 1;
5551 /* oh,oh, the number grew */
5552 SvGROW(sv, SvCUR(sv) + 2);
5554 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5565 Auto-decrement of the value in the SV.
5571 Perl_sv_dec(pTHX_ register SV *sv)
5579 if (SvTHINKFIRST(sv)) {
5580 if (SvREADONLY(sv)) {
5581 if (PL_curcop != &PL_compiling)
5582 Perl_croak(aTHX_ PL_no_modify);
5586 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5588 i = PTR2IV(SvRV(sv));
5593 /* Unlike sv_inc we don't have to worry about string-never-numbers
5594 and keeping them magic. But we mustn't warn on punting */
5595 flags = SvFLAGS(sv);
5596 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5597 /* It's publicly an integer, or privately an integer-not-float */
5600 if (SvUVX(sv) == 0) {
5601 (void)SvIOK_only(sv);
5605 (void)SvIOK_only_UV(sv);
5609 if (SvIVX(sv) == IV_MIN)
5610 sv_setnv(sv, (NV)IV_MIN - 1.0);
5612 (void)SvIOK_only(sv);
5618 if (flags & SVp_NOK) {
5620 (void)SvNOK_only(sv);
5623 if (!(flags & SVp_POK)) {
5624 if ((flags & SVTYPEMASK) < SVt_PVNV)
5625 sv_upgrade(sv, SVt_NV);
5627 (void)SvNOK_only(sv);
5630 #ifdef PERL_PRESERVE_IVUV
5632 I32 numtype = looks_like_number(sv);
5633 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5634 /* Need to try really hard to see if it's an integer.
5635 9.22337203685478e+18 is an integer.
5636 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5637 so $a="9.22337203685478e+18"; $a+0; $a--
5638 needs to be the same as $a="9.22337203685478e+18"; $a--
5645 /* sv_2iv *should* have made this an NV */
5646 if (flags & SVp_NOK) {
5647 (void)SvNOK_only(sv);
5651 /* I don't think we can get here. Maybe I should assert this
5652 And if we do get here I suspect that sv_setnv will croak. NWC
5654 #if defined(USE_LONG_DOUBLE)
5655 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",
5656 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5658 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5659 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5663 #endif /* PERL_PRESERVE_IVUV */
5664 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5668 =for apidoc sv_mortalcopy
5670 Creates a new SV which is a copy of the original SV. The new SV is marked
5676 /* Make a string that will exist for the duration of the expression
5677 * evaluation. Actually, it may have to last longer than that, but
5678 * hopefully we won't free it until it has been assigned to a
5679 * permanent location. */
5682 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5687 sv_setsv(sv,oldstr);
5689 PL_tmps_stack[++PL_tmps_ix] = sv;
5695 =for apidoc sv_newmortal
5697 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5703 Perl_sv_newmortal(pTHX)
5708 SvFLAGS(sv) = SVs_TEMP;
5710 PL_tmps_stack[++PL_tmps_ix] = sv;
5715 =for apidoc sv_2mortal
5717 Marks an SV as mortal. The SV will be destroyed when the current context
5723 /* same thing without the copying */
5726 Perl_sv_2mortal(pTHX_ register SV *sv)
5730 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5733 PL_tmps_stack[++PL_tmps_ix] = sv;
5741 Creates a new SV and copies a string into it. The reference count for the
5742 SV is set to 1. If C<len> is zero, Perl will compute the length using
5743 strlen(). For efficiency, consider using C<newSVpvn> instead.
5749 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5756 sv_setpvn(sv,s,len);
5761 =for apidoc newSVpvn
5763 Creates a new SV and copies a string into it. The reference count for the
5764 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5765 string. You are responsible for ensuring that the source string is at least
5772 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5777 sv_setpvn(sv,s,len);
5782 =for apidoc newSVpvn_share
5784 Creates a new SV and populates it with a string from
5785 the string table. Turns on READONLY and FAKE.
5786 The idea here is that as string table is used for shared hash
5787 keys these strings will have SvPVX == HeKEY and hash lookup
5788 will avoid string compare.
5794 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5797 bool is_utf8 = FALSE;
5802 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5803 STRLEN tmplen = len;
5804 /* See the note in hv.c:hv_fetch() --jhi */
5805 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5809 PERL_HASH(hash, src, len);
5811 sv_upgrade(sv, SVt_PVIV);
5812 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5824 #if defined(PERL_IMPLICIT_CONTEXT)
5826 Perl_newSVpvf_nocontext(const char* pat, ...)
5831 va_start(args, pat);
5832 sv = vnewSVpvf(pat, &args);
5839 =for apidoc newSVpvf
5841 Creates a new SV an initialize it with the string formatted like
5848 Perl_newSVpvf(pTHX_ const char* pat, ...)
5852 va_start(args, pat);
5853 sv = vnewSVpvf(pat, &args);
5859 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5863 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5870 Creates a new SV and copies a floating point value into it.
5871 The reference count for the SV is set to 1.
5877 Perl_newSVnv(pTHX_ NV n)
5889 Creates a new SV and copies an integer into it. The reference count for the
5896 Perl_newSViv(pTHX_ IV i)
5908 Creates a new SV and copies an unsigned integer into it.
5909 The reference count for the SV is set to 1.
5915 Perl_newSVuv(pTHX_ UV u)
5925 =for apidoc newRV_noinc
5927 Creates an RV wrapper for an SV. The reference count for the original
5928 SV is B<not> incremented.
5934 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5939 sv_upgrade(sv, SVt_RV);
5946 /* newRV_inc is #defined to newRV in sv.h */
5948 Perl_newRV(pTHX_ SV *tmpRef)
5950 return newRV_noinc(SvREFCNT_inc(tmpRef));
5956 Creates a new SV which is an exact duplicate of the original SV.
5961 /* make an exact duplicate of old */
5964 Perl_newSVsv(pTHX_ register SV *old)
5970 if (SvTYPE(old) == SVTYPEMASK) {
5971 if (ckWARN_d(WARN_INTERNAL))
5972 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5987 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5995 char todo[PERL_UCHAR_MAX+1];
6000 if (!*s) { /* reset ?? searches */
6001 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6002 pm->op_pmdynflags &= ~PMdf_USED;
6007 /* reset variables */
6009 if (!HvARRAY(stash))
6012 Zero(todo, 256, char);
6014 i = (unsigned char)*s;
6018 max = (unsigned char)*s++;
6019 for ( ; i <= max; i++) {
6022 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6023 for (entry = HvARRAY(stash)[i];
6025 entry = HeNEXT(entry))
6027 if (!todo[(U8)*HeKEY(entry)])
6029 gv = (GV*)HeVAL(entry);
6031 if (SvTHINKFIRST(sv)) {
6032 if (!SvREADONLY(sv) && SvROK(sv))
6037 if (SvTYPE(sv) >= SVt_PV) {
6039 if (SvPVX(sv) != Nullch)
6046 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6048 #ifdef USE_ENVIRON_ARRAY
6050 environ[0] = Nullch;
6059 Perl_sv_2io(pTHX_ SV *sv)
6065 switch (SvTYPE(sv)) {
6073 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6077 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6079 return sv_2io(SvRV(sv));
6080 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6086 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6093 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6100 return *gvp = Nullgv, Nullcv;
6101 switch (SvTYPE(sv)) {
6120 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6121 tryAMAGICunDEREF(to_cv);
6124 if (SvTYPE(sv) == SVt_PVCV) {
6133 Perl_croak(aTHX_ "Not a subroutine reference");
6138 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6144 if (lref && !GvCVu(gv)) {
6147 tmpsv = NEWSV(704,0);
6148 gv_efullname3(tmpsv, gv, Nullch);
6149 /* XXX this is probably not what they think they're getting.
6150 * It has the same effect as "sub name;", i.e. just a forward
6152 newSUB(start_subparse(FALSE, 0),
6153 newSVOP(OP_CONST, 0, tmpsv),
6158 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6167 Returns true if the SV has a true value by Perl's rules.
6173 Perl_sv_true(pTHX_ register SV *sv)
6179 if ((tXpv = (XPV*)SvANY(sv)) &&
6180 (tXpv->xpv_cur > 1 ||
6181 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6188 return SvIVX(sv) != 0;
6191 return SvNVX(sv) != 0.0;
6193 return sv_2bool(sv);
6199 Perl_sv_iv(pTHX_ register SV *sv)
6203 return (IV)SvUVX(sv);
6210 Perl_sv_uv(pTHX_ register SV *sv)
6215 return (UV)SvIVX(sv);
6221 Perl_sv_nv(pTHX_ register SV *sv)
6229 Perl_sv_pv(pTHX_ SV *sv)
6236 return sv_2pv(sv, &n_a);
6240 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6246 return sv_2pv(sv, lp);
6250 =for apidoc sv_pvn_force
6252 Get a sensible string out of the SV somehow.
6258 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6260 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6264 =for apidoc sv_pvn_force_flags
6266 Get a sensible string out of the SV somehow.
6267 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6268 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6269 implemented in terms of this function.
6275 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6279 if (SvTHINKFIRST(sv) && !SvROK(sv))
6280 sv_force_normal(sv);
6286 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6287 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6288 PL_op_name[PL_op->op_type]);
6291 s = sv_2pv_flags(sv, lp, flags);
6292 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6297 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6298 SvGROW(sv, len + 1);
6299 Move(s,SvPVX(sv),len,char);
6304 SvPOK_on(sv); /* validate pointer */
6306 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6307 PTR2UV(sv),SvPVX(sv)));
6314 Perl_sv_pvbyte(pTHX_ SV *sv)
6316 sv_utf8_downgrade(sv,0);
6321 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6323 sv_utf8_downgrade(sv,0);
6324 return sv_pvn(sv,lp);
6328 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6330 sv_utf8_downgrade(sv,0);
6331 return sv_pvn_force(sv,lp);
6335 Perl_sv_pvutf8(pTHX_ SV *sv)
6337 sv_utf8_upgrade(sv);
6342 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6344 sv_utf8_upgrade(sv);
6345 return sv_pvn(sv,lp);
6349 =for apidoc sv_pvutf8n_force
6351 Get a sensible UTF8-encoded string out of the SV somehow. See
6358 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6360 sv_utf8_upgrade(sv);
6361 return sv_pvn_force(sv,lp);
6365 =for apidoc sv_reftype
6367 Returns a string describing what the SV is a reference to.
6373 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6375 if (ob && SvOBJECT(sv))
6376 return HvNAME(SvSTASH(sv));
6378 switch (SvTYPE(sv)) {
6392 case SVt_PVLV: return "LVALUE";
6393 case SVt_PVAV: return "ARRAY";
6394 case SVt_PVHV: return "HASH";
6395 case SVt_PVCV: return "CODE";
6396 case SVt_PVGV: return "GLOB";
6397 case SVt_PVFM: return "FORMAT";
6398 case SVt_PVIO: return "IO";
6399 default: return "UNKNOWN";
6405 =for apidoc sv_isobject
6407 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6408 object. If the SV is not an RV, or if the object is not blessed, then this
6415 Perl_sv_isobject(pTHX_ SV *sv)
6432 Returns a boolean indicating whether the SV is blessed into the specified
6433 class. This does not check for subtypes; use C<sv_derived_from> to verify
6434 an inheritance relationship.
6440 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6452 return strEQ(HvNAME(SvSTASH(sv)), name);
6458 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6459 it will be upgraded to one. If C<classname> is non-null then the new SV will
6460 be blessed in the specified package. The new SV is returned and its
6461 reference count is 1.
6467 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6473 SV_CHECK_THINKFIRST(rv);
6476 if (SvTYPE(rv) >= SVt_PVMG) {
6477 U32 refcnt = SvREFCNT(rv);
6481 SvREFCNT(rv) = refcnt;
6484 if (SvTYPE(rv) < SVt_RV)
6485 sv_upgrade(rv, SVt_RV);
6486 else if (SvTYPE(rv) > SVt_RV) {
6487 (void)SvOOK_off(rv);
6488 if (SvPVX(rv) && SvLEN(rv))
6489 Safefree(SvPVX(rv));
6499 HV* stash = gv_stashpv(classname, TRUE);
6500 (void)sv_bless(rv, stash);
6506 =for apidoc sv_setref_pv
6508 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6509 argument will be upgraded to an RV. That RV will be modified to point to
6510 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6511 into the SV. The C<classname> argument indicates the package for the
6512 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6513 will be returned and will have a reference count of 1.
6515 Do not use with other Perl types such as HV, AV, SV, CV, because those
6516 objects will become corrupted by the pointer copy process.
6518 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6524 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6527 sv_setsv(rv, &PL_sv_undef);
6531 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6536 =for apidoc sv_setref_iv
6538 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6539 argument will be upgraded to an RV. That RV will be modified to point to
6540 the new SV. The C<classname> argument indicates the package for the
6541 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6542 will be returned and will have a reference count of 1.
6548 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6550 sv_setiv(newSVrv(rv,classname), iv);
6555 =for apidoc sv_setref_uv
6557 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6558 argument will be upgraded to an RV. That RV will be modified to point to
6559 the new SV. The C<classname> argument indicates the package for the
6560 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6561 will be returned and will have a reference count of 1.
6567 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6569 sv_setuv(newSVrv(rv,classname), uv);
6574 =for apidoc sv_setref_nv
6576 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6577 argument will be upgraded to an RV. That RV will be modified to point to
6578 the new SV. The C<classname> argument indicates the package for the
6579 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6580 will be returned and will have a reference count of 1.
6586 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6588 sv_setnv(newSVrv(rv,classname), nv);
6593 =for apidoc sv_setref_pvn
6595 Copies a string into a new SV, optionally blessing the SV. The length of the
6596 string must be specified with C<n>. The C<rv> argument will be upgraded to
6597 an RV. That RV will be modified to point to the new SV. The C<classname>
6598 argument indicates the package for the blessing. Set C<classname> to
6599 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6600 a reference count of 1.
6602 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6608 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6610 sv_setpvn(newSVrv(rv,classname), pv, n);
6615 =for apidoc sv_bless
6617 Blesses an SV into a specified package. The SV must be an RV. The package
6618 must be designated by its stash (see C<gv_stashpv()>). The reference count
6619 of the SV is unaffected.
6625 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6629 Perl_croak(aTHX_ "Can't bless non-reference value");
6631 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6632 if (SvREADONLY(tmpRef))
6633 Perl_croak(aTHX_ PL_no_modify);
6634 if (SvOBJECT(tmpRef)) {
6635 if (SvTYPE(tmpRef) != SVt_PVIO)
6637 SvREFCNT_dec(SvSTASH(tmpRef));
6640 SvOBJECT_on(tmpRef);
6641 if (SvTYPE(tmpRef) != SVt_PVIO)
6643 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6644 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6655 S_sv_unglob(pTHX_ SV *sv)
6659 assert(SvTYPE(sv) == SVt_PVGV);
6664 SvREFCNT_dec(GvSTASH(sv));
6665 GvSTASH(sv) = Nullhv;
6667 sv_unmagic(sv, PERL_MAGIC_glob);
6668 Safefree(GvNAME(sv));
6671 /* need to keep SvANY(sv) in the right arena */
6672 xpvmg = new_XPVMG();
6673 StructCopy(SvANY(sv), xpvmg, XPVMG);
6674 del_XPVGV(SvANY(sv));
6677 SvFLAGS(sv) &= ~SVTYPEMASK;
6678 SvFLAGS(sv) |= SVt_PVMG;
6682 =for apidoc sv_unref_flags
6684 Unsets the RV status of the SV, and decrements the reference count of
6685 whatever was being referenced by the RV. This can almost be thought of
6686 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6687 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6688 (otherwise the decrementing is conditional on the reference count being
6689 different from one or the reference being a readonly SV).
6696 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6700 if (SvWEAKREF(sv)) {
6708 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6710 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6711 sv_2mortal(rv); /* Schedule for freeing later */
6715 =for apidoc sv_unref
6717 Unsets the RV status of the SV, and decrements the reference count of
6718 whatever was being referenced by the RV. This can almost be thought of
6719 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6720 being zero. See C<SvROK_off>.
6726 Perl_sv_unref(pTHX_ SV *sv)
6728 sv_unref_flags(sv, 0);
6732 Perl_sv_taint(pTHX_ SV *sv)
6734 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6738 Perl_sv_untaint(pTHX_ SV *sv)
6740 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6741 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6748 Perl_sv_tainted(pTHX_ SV *sv)
6750 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6751 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6752 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6759 =for apidoc sv_setpviv
6761 Copies an integer into the given SV, also updating its string value.
6762 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6768 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6770 char buf[TYPE_CHARS(UV)];
6772 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6774 sv_setpvn(sv, ptr, ebuf - ptr);
6779 =for apidoc sv_setpviv_mg
6781 Like C<sv_setpviv>, but also handles 'set' magic.
6787 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6789 char buf[TYPE_CHARS(UV)];
6791 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6793 sv_setpvn(sv, ptr, ebuf - ptr);
6797 #if defined(PERL_IMPLICIT_CONTEXT)
6799 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6803 va_start(args, pat);
6804 sv_vsetpvf(sv, pat, &args);
6810 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6814 va_start(args, pat);
6815 sv_vsetpvf_mg(sv, pat, &args);
6821 =for apidoc sv_setpvf
6823 Processes its arguments like C<sprintf> and sets an SV to the formatted
6824 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6830 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6833 va_start(args, pat);
6834 sv_vsetpvf(sv, pat, &args);
6839 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6841 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6845 =for apidoc sv_setpvf_mg
6847 Like C<sv_setpvf>, but also handles 'set' magic.
6853 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6856 va_start(args, pat);
6857 sv_vsetpvf_mg(sv, pat, &args);
6862 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6864 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6868 #if defined(PERL_IMPLICIT_CONTEXT)
6870 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6874 va_start(args, pat);
6875 sv_vcatpvf(sv, pat, &args);
6880 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6884 va_start(args, pat);
6885 sv_vcatpvf_mg(sv, pat, &args);
6891 =for apidoc sv_catpvf
6893 Processes its arguments like C<sprintf> and appends the formatted
6894 output to an SV. If the appended data contains "wide" characters
6895 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6896 and characters >255 formatted with %c), the original SV might get
6897 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6898 C<SvSETMAGIC()> must typically be called after calling this function
6899 to handle 'set' magic.
6904 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6907 va_start(args, pat);
6908 sv_vcatpvf(sv, pat, &args);
6913 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6915 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6919 =for apidoc sv_catpvf_mg
6921 Like C<sv_catpvf>, but also handles 'set' magic.
6927 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6930 va_start(args, pat);
6931 sv_vcatpvf_mg(sv, pat, &args);
6936 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6938 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6943 =for apidoc sv_vsetpvfn
6945 Works like C<vcatpvfn> but copies the text into the SV instead of
6952 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6954 sv_setpvn(sv, "", 0);
6955 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6959 S_expect_number(pTHX_ char** pattern)
6962 switch (**pattern) {
6963 case '1': case '2': case '3':
6964 case '4': case '5': case '6':
6965 case '7': case '8': case '9':
6966 while (isDIGIT(**pattern))
6967 var = var * 10 + (*(*pattern)++ - '0');
6971 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6974 =for apidoc sv_vcatpvfn
6976 Processes its arguments like C<vsprintf> and appends the formatted output
6977 to an SV. Uses an array of SVs if the C style variable argument list is
6978 missing (NULL). When running with taint checks enabled, indicates via
6979 C<maybe_tainted> if results are untrustworthy (often due to the use of
6986 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6993 static char nullstr[] = "(null)";
6996 /* no matter what, this is a string now */
6997 (void)SvPV_force(sv, origlen);
6999 /* special-case "", "%s", and "%_" */
7002 if (patlen == 2 && pat[0] == '%') {
7006 char *s = va_arg(*args, char*);
7007 sv_catpv(sv, s ? s : nullstr);
7009 else if (svix < svmax) {
7010 sv_catsv(sv, *svargs);
7011 if (DO_UTF8(*svargs))
7017 argsv = va_arg(*args, SV*);
7018 sv_catsv(sv, argsv);
7023 /* See comment on '_' below */
7028 patend = (char*)pat + patlen;
7029 for (p = (char*)pat; p < patend; p = q) {
7032 bool vectorize = FALSE;
7033 bool vectorarg = FALSE;
7034 bool vec_utf = FALSE;
7040 bool has_precis = FALSE;
7042 bool is_utf = FALSE;
7045 U8 utf8buf[UTF8_MAXLEN+1];
7046 STRLEN esignlen = 0;
7048 char *eptr = Nullch;
7050 /* Times 4: a decimal digit takes more than 3 binary digits.
7051 * NV_DIG: mantissa takes than many decimal digits.
7052 * Plus 32: Playing safe. */
7053 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7054 /* large enough for "%#.#f" --chip */
7055 /* what about long double NVs? --jhi */
7058 U8 *vecstr = Null(U8*);
7070 STRLEN dotstrlen = 1;
7071 I32 efix = 0; /* explicit format parameter index */
7072 I32 ewix = 0; /* explicit width index */
7073 I32 epix = 0; /* explicit precision index */
7074 I32 evix = 0; /* explicit vector index */
7075 bool asterisk = FALSE;
7077 /* echo everything up to the next format specification */
7078 for (q = p; q < patend && *q != '%'; ++q) ;
7080 sv_catpvn(sv, p, q - p);
7087 We allow format specification elements in this order:
7088 \d+\$ explicit format parameter index
7090 \*?(\d+\$)?v vector with optional (optionally specified) arg
7091 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7092 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7094 [%bcdefginopsux_DFOUX] format (mandatory)
7096 if (EXPECT_NUMBER(q, width)) {
7137 if (EXPECT_NUMBER(q, ewix))
7146 if ((vectorarg = asterisk)) {
7156 EXPECT_NUMBER(q, width);
7161 vecsv = va_arg(*args, SV*);
7163 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7164 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7165 dotstr = SvPVx(vecsv, dotstrlen);
7170 vecsv = va_arg(*args, SV*);
7171 vecstr = (U8*)SvPVx(vecsv,veclen);
7172 vec_utf = DO_UTF8(vecsv);
7174 else if (efix ? efix <= svmax : svix < svmax) {
7175 vecsv = svargs[efix ? efix-1 : svix++];
7176 vecstr = (U8*)SvPVx(vecsv,veclen);
7177 vec_utf = DO_UTF8(vecsv);
7187 i = va_arg(*args, int);
7189 i = (ewix ? ewix <= svmax : svix < svmax) ?
7190 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7192 width = (i < 0) ? -i : i;
7202 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7205 i = va_arg(*args, int);
7207 i = (ewix ? ewix <= svmax : svix < svmax)
7208 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7209 precis = (i < 0) ? 0 : i;
7214 precis = precis * 10 + (*q++ - '0');
7222 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7233 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7234 if (*(q + 1) == 'l') { /* lld, llf */
7257 argsv = (efix ? efix <= svmax : svix < svmax) ?
7258 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7265 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7267 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7269 eptr = (char*)utf8buf;
7270 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7282 eptr = va_arg(*args, char*);
7284 #ifdef MACOS_TRADITIONAL
7285 /* On MacOS, %#s format is used for Pascal strings */
7290 elen = strlen(eptr);
7293 elen = sizeof nullstr - 1;
7297 eptr = SvPVx(argsv, elen);
7298 if (DO_UTF8(argsv)) {
7299 if (has_precis && precis < elen) {
7301 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7304 if (width) { /* fudge width (can't fudge elen) */
7305 width += elen - sv_len_utf8(argsv);
7314 * The "%_" hack might have to be changed someday,
7315 * if ISO or ANSI decide to use '_' for something.
7316 * So we keep it hidden from users' code.
7320 argsv = va_arg(*args, SV*);
7321 eptr = SvPVx(argsv, elen);
7327 if (has_precis && elen > precis)
7336 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7354 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7364 case 'h': iv = (short)va_arg(*args, int); break;
7365 default: iv = va_arg(*args, int); break;
7366 case 'l': iv = va_arg(*args, long); break;
7367 case 'V': iv = va_arg(*args, IV); break;
7369 case 'q': iv = va_arg(*args, Quad_t); break;
7376 case 'h': iv = (short)iv; break;
7378 case 'l': iv = (long)iv; break;
7381 case 'q': iv = (Quad_t)iv; break;
7388 esignbuf[esignlen++] = plus;
7392 esignbuf[esignlen++] = '-';
7434 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7444 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7445 default: uv = va_arg(*args, unsigned); break;
7446 case 'l': uv = va_arg(*args, unsigned long); break;
7447 case 'V': uv = va_arg(*args, UV); break;
7449 case 'q': uv = va_arg(*args, Quad_t); break;
7456 case 'h': uv = (unsigned short)uv; break;
7458 case 'l': uv = (unsigned long)uv; break;
7461 case 'q': uv = (Quad_t)uv; break;
7467 eptr = ebuf + sizeof ebuf;
7473 p = (char*)((c == 'X')
7474 ? "0123456789ABCDEF" : "0123456789abcdef");
7480 esignbuf[esignlen++] = '0';
7481 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7487 *--eptr = '0' + dig;
7489 if (alt && *eptr != '0')
7495 *--eptr = '0' + dig;
7498 esignbuf[esignlen++] = '0';
7499 esignbuf[esignlen++] = 'b';
7502 default: /* it had better be ten or less */
7503 #if defined(PERL_Y2KWARN)
7504 if (ckWARN(WARN_Y2K)) {
7506 char *s = SvPV(sv,n);
7507 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7508 && (n == 2 || !isDIGIT(s[n-3])))
7510 Perl_warner(aTHX_ WARN_Y2K,
7511 "Possible Y2K bug: %%%c %s",
7512 c, "format string following '19'");
7518 *--eptr = '0' + dig;
7519 } while (uv /= base);
7522 elen = (ebuf + sizeof ebuf) - eptr;
7525 zeros = precis - elen;
7526 else if (precis == 0 && elen == 1 && *eptr == '0')
7531 /* FLOATING POINT */
7534 c = 'f'; /* maybe %F isn't supported here */
7540 /* This is evil, but floating point is even more evil */
7543 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7546 if (c != 'e' && c != 'E') {
7548 (void)Perl_frexp(nv, &i);
7549 if (i == PERL_INT_MIN)
7550 Perl_die(aTHX_ "panic: frexp");
7552 need = BIT_DIGITS(i);
7554 need += has_precis ? precis : 6; /* known default */
7558 need += 20; /* fudge factor */
7559 if (PL_efloatsize < need) {
7560 Safefree(PL_efloatbuf);
7561 PL_efloatsize = need + 20; /* more fudge */
7562 New(906, PL_efloatbuf, PL_efloatsize, char);
7563 PL_efloatbuf[0] = '\0';
7566 eptr = ebuf + sizeof ebuf;
7569 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7571 /* Copy the one or more characters in a long double
7572 * format before the 'base' ([efgEFG]) character to
7573 * the format string. */
7574 static char const prifldbl[] = PERL_PRIfldbl;
7575 char const *p = prifldbl + sizeof(prifldbl) - 3;
7576 while (p >= prifldbl) { *--eptr = *p--; }
7581 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7586 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7598 /* No taint. Otherwise we are in the strange situation
7599 * where printf() taints but print($float) doesn't.
7601 (void)sprintf(PL_efloatbuf, eptr, nv);
7603 eptr = PL_efloatbuf;
7604 elen = strlen(PL_efloatbuf);
7611 i = SvCUR(sv) - origlen;
7614 case 'h': *(va_arg(*args, short*)) = i; break;
7615 default: *(va_arg(*args, int*)) = i; break;
7616 case 'l': *(va_arg(*args, long*)) = i; break;
7617 case 'V': *(va_arg(*args, IV*)) = i; break;
7619 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7624 sv_setuv_mg(argsv, (UV)i);
7625 continue; /* not "break" */
7632 if (!args && ckWARN(WARN_PRINTF) &&
7633 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7634 SV *msg = sv_newmortal();
7635 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7636 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7639 Perl_sv_catpvf(aTHX_ msg,
7640 "\"%%%c\"", c & 0xFF);
7642 Perl_sv_catpvf(aTHX_ msg,
7643 "\"%%\\%03"UVof"\"",
7646 sv_catpv(msg, "end of string");
7647 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7650 /* output mangled stuff ... */
7656 /* ... right here, because formatting flags should not apply */
7657 SvGROW(sv, SvCUR(sv) + elen + 1);
7659 Copy(eptr, p, elen, char);
7662 SvCUR(sv) = p - SvPVX(sv);
7663 continue; /* not "break" */
7666 have = esignlen + zeros + elen;
7667 need = (have > width ? have : width);
7670 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7672 if (esignlen && fill == '0') {
7673 for (i = 0; i < esignlen; i++)
7677 memset(p, fill, gap);
7680 if (esignlen && fill != '0') {
7681 for (i = 0; i < esignlen; i++)
7685 for (i = zeros; i; i--)
7689 Copy(eptr, p, elen, char);
7693 memset(p, ' ', gap);
7698 Copy(dotstr, p, dotstrlen, char);
7702 vectorize = FALSE; /* done iterating over vecstr */
7707 SvCUR(sv) = p - SvPVX(sv);
7715 #if defined(USE_ITHREADS)
7717 #if defined(USE_THREADS)
7718 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7721 #ifndef GpREFCNT_inc
7722 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7726 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7727 #define av_dup(s) (AV*)sv_dup((SV*)s)
7728 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7729 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7730 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7731 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7732 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7733 #define io_dup(s) (IO*)sv_dup((SV*)s)
7734 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7735 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7736 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7737 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7738 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7741 Perl_re_dup(pTHX_ REGEXP *r)
7743 /* XXX fix when pmop->op_pmregexp becomes shared */
7744 return ReREFCNT_inc(r);
7748 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7752 return (PerlIO*)NULL;
7754 /* look for it in the table first */
7755 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7759 /* create anew and remember what it is */
7760 ret = PerlIO_fdupopen(aTHX_ fp);
7761 ptr_table_store(PL_ptr_table, fp, ret);
7766 Perl_dirp_dup(pTHX_ DIR *dp)
7775 Perl_gp_dup(pTHX_ GP *gp)
7780 /* look for it in the table first */
7781 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7785 /* create anew and remember what it is */
7786 Newz(0, ret, 1, GP);
7787 ptr_table_store(PL_ptr_table, gp, ret);
7790 ret->gp_refcnt = 0; /* must be before any other dups! */
7791 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7792 ret->gp_io = io_dup_inc(gp->gp_io);
7793 ret->gp_form = cv_dup_inc(gp->gp_form);
7794 ret->gp_av = av_dup_inc(gp->gp_av);
7795 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7796 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7797 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7798 ret->gp_cvgen = gp->gp_cvgen;
7799 ret->gp_flags = gp->gp_flags;
7800 ret->gp_line = gp->gp_line;
7801 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7806 Perl_mg_dup(pTHX_ MAGIC *mg)
7808 MAGIC *mgprev = (MAGIC*)NULL;
7811 return (MAGIC*)NULL;
7812 /* look for it in the table first */
7813 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7817 for (; mg; mg = mg->mg_moremagic) {
7819 Newz(0, nmg, 1, MAGIC);
7821 mgprev->mg_moremagic = nmg;
7824 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7825 nmg->mg_private = mg->mg_private;
7826 nmg->mg_type = mg->mg_type;
7827 nmg->mg_flags = mg->mg_flags;
7828 if (mg->mg_type == PERL_MAGIC_qr) {
7829 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7832 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7833 ? sv_dup_inc(mg->mg_obj)
7834 : sv_dup(mg->mg_obj);
7836 nmg->mg_len = mg->mg_len;
7837 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7838 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7839 if (mg->mg_len >= 0) {
7840 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7841 if (mg->mg_type == PERL_MAGIC_overload_table &&
7842 AMT_AMAGIC((AMT*)mg->mg_ptr))
7844 AMT *amtp = (AMT*)mg->mg_ptr;
7845 AMT *namtp = (AMT*)nmg->mg_ptr;
7847 for (i = 1; i < NofAMmeth; i++) {
7848 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7852 else if (mg->mg_len == HEf_SVKEY)
7853 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7861 Perl_ptr_table_new(pTHX)
7864 Newz(0, tbl, 1, PTR_TBL_t);
7867 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7872 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7874 PTR_TBL_ENT_t *tblent;
7875 UV hash = PTR2UV(sv);
7877 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7878 for (; tblent; tblent = tblent->next) {
7879 if (tblent->oldval == sv)
7880 return tblent->newval;
7886 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7888 PTR_TBL_ENT_t *tblent, **otblent;
7889 /* XXX this may be pessimal on platforms where pointers aren't good
7890 * hash values e.g. if they grow faster in the most significant
7892 UV hash = PTR2UV(oldv);
7896 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7897 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7898 if (tblent->oldval == oldv) {
7899 tblent->newval = newv;
7904 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7905 tblent->oldval = oldv;
7906 tblent->newval = newv;
7907 tblent->next = *otblent;
7910 if (i && tbl->tbl_items > tbl->tbl_max)
7911 ptr_table_split(tbl);
7915 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7917 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7918 UV oldsize = tbl->tbl_max + 1;
7919 UV newsize = oldsize * 2;
7922 Renew(ary, newsize, PTR_TBL_ENT_t*);
7923 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7924 tbl->tbl_max = --newsize;
7926 for (i=0; i < oldsize; i++, ary++) {
7927 PTR_TBL_ENT_t **curentp, **entp, *ent;
7930 curentp = ary + oldsize;
7931 for (entp = ary, ent = *ary; ent; ent = *entp) {
7932 if ((newsize & PTR2UV(ent->oldval)) != i) {
7934 ent->next = *curentp;
7945 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7947 register PTR_TBL_ENT_t **array;
7948 register PTR_TBL_ENT_t *entry;
7949 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7953 if (!tbl || !tbl->tbl_items) {
7957 array = tbl->tbl_ary;
7964 entry = entry->next;
7968 if (++riter > max) {
7971 entry = array[riter];
7979 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7984 ptr_table_clear(tbl);
7985 Safefree(tbl->tbl_ary);
7994 S_gv_share(pTHX_ SV *sstr)
7997 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7999 if (GvIO(gv) || GvFORM(gv)) {
8000 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8002 else if (!GvCV(gv)) {
8006 /* CvPADLISTs cannot be shared */
8007 if (!CvXSUB(GvCV(gv))) {
8012 if (!GvSHARED(gv)) {
8014 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8015 HvNAME(GvSTASH(gv)), GvNAME(gv));
8021 * write attempts will die with
8022 * "Modification of a read-only value attempted"
8028 SvREADONLY_on(GvSV(gv));
8035 SvREADONLY_on(GvAV(gv));
8042 SvREADONLY_on(GvAV(gv));
8045 return sstr; /* he_dup() will SvREFCNT_inc() */
8049 Perl_sv_dup(pTHX_ SV *sstr)
8053 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8055 /* look for it in the table first */
8056 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8060 /* create anew and remember what it is */
8062 ptr_table_store(PL_ptr_table, sstr, dstr);
8065 SvFLAGS(dstr) = SvFLAGS(sstr);
8066 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8067 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8070 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8071 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8072 PL_watch_pvx, SvPVX(sstr));
8075 switch (SvTYPE(sstr)) {
8080 SvANY(dstr) = new_XIV();
8081 SvIVX(dstr) = SvIVX(sstr);
8084 SvANY(dstr) = new_XNV();
8085 SvNVX(dstr) = SvNVX(sstr);
8088 SvANY(dstr) = new_XRV();
8089 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8090 ? sv_dup(SvRV(sstr))
8091 : sv_dup_inc(SvRV(sstr));
8094 SvANY(dstr) = new_XPV();
8095 SvCUR(dstr) = SvCUR(sstr);
8096 SvLEN(dstr) = SvLEN(sstr);
8098 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8099 ? sv_dup(SvRV(sstr))
8100 : sv_dup_inc(SvRV(sstr));
8101 else if (SvPVX(sstr) && SvLEN(sstr))
8102 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8104 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8107 SvANY(dstr) = new_XPVIV();
8108 SvCUR(dstr) = SvCUR(sstr);
8109 SvLEN(dstr) = SvLEN(sstr);
8110 SvIVX(dstr) = SvIVX(sstr);
8112 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8113 ? sv_dup(SvRV(sstr))
8114 : sv_dup_inc(SvRV(sstr));
8115 else if (SvPVX(sstr) && SvLEN(sstr))
8116 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8118 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8121 SvANY(dstr) = new_XPVNV();
8122 SvCUR(dstr) = SvCUR(sstr);
8123 SvLEN(dstr) = SvLEN(sstr);
8124 SvIVX(dstr) = SvIVX(sstr);
8125 SvNVX(dstr) = SvNVX(sstr);
8127 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8128 ? sv_dup(SvRV(sstr))
8129 : sv_dup_inc(SvRV(sstr));
8130 else if (SvPVX(sstr) && SvLEN(sstr))
8131 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8133 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8136 SvANY(dstr) = new_XPVMG();
8137 SvCUR(dstr) = SvCUR(sstr);
8138 SvLEN(dstr) = SvLEN(sstr);
8139 SvIVX(dstr) = SvIVX(sstr);
8140 SvNVX(dstr) = SvNVX(sstr);
8141 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8142 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8144 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8145 ? sv_dup(SvRV(sstr))
8146 : sv_dup_inc(SvRV(sstr));
8147 else if (SvPVX(sstr) && SvLEN(sstr))
8148 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8150 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8153 SvANY(dstr) = new_XPVBM();
8154 SvCUR(dstr) = SvCUR(sstr);
8155 SvLEN(dstr) = SvLEN(sstr);
8156 SvIVX(dstr) = SvIVX(sstr);
8157 SvNVX(dstr) = SvNVX(sstr);
8158 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8159 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8161 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8162 ? sv_dup(SvRV(sstr))
8163 : sv_dup_inc(SvRV(sstr));
8164 else if (SvPVX(sstr) && SvLEN(sstr))
8165 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8167 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8168 BmRARE(dstr) = BmRARE(sstr);
8169 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8170 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8173 SvANY(dstr) = new_XPVLV();
8174 SvCUR(dstr) = SvCUR(sstr);
8175 SvLEN(dstr) = SvLEN(sstr);
8176 SvIVX(dstr) = SvIVX(sstr);
8177 SvNVX(dstr) = SvNVX(sstr);
8178 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8179 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8181 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8182 ? sv_dup(SvRV(sstr))
8183 : sv_dup_inc(SvRV(sstr));
8184 else if (SvPVX(sstr) && SvLEN(sstr))
8185 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8187 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8188 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8189 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8190 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8191 LvTYPE(dstr) = LvTYPE(sstr);
8194 if (GvSHARED((GV*)sstr)) {
8196 if ((share = gv_share(sstr))) {
8200 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8201 HvNAME(GvSTASH(share)), GvNAME(share));
8206 SvANY(dstr) = new_XPVGV();
8207 SvCUR(dstr) = SvCUR(sstr);
8208 SvLEN(dstr) = SvLEN(sstr);
8209 SvIVX(dstr) = SvIVX(sstr);
8210 SvNVX(dstr) = SvNVX(sstr);
8211 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8212 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8214 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8215 ? sv_dup(SvRV(sstr))
8216 : sv_dup_inc(SvRV(sstr));
8217 else if (SvPVX(sstr) && SvLEN(sstr))
8218 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8220 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8221 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8222 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8223 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8224 GvFLAGS(dstr) = GvFLAGS(sstr);
8225 GvGP(dstr) = gp_dup(GvGP(sstr));
8226 (void)GpREFCNT_inc(GvGP(dstr));
8229 SvANY(dstr) = new_XPVIO();
8230 SvCUR(dstr) = SvCUR(sstr);
8231 SvLEN(dstr) = SvLEN(sstr);
8232 SvIVX(dstr) = SvIVX(sstr);
8233 SvNVX(dstr) = SvNVX(sstr);
8234 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8235 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8237 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8238 ? sv_dup(SvRV(sstr))
8239 : sv_dup_inc(SvRV(sstr));
8240 else if (SvPVX(sstr) && SvLEN(sstr))
8241 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8243 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8244 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8245 if (IoOFP(sstr) == IoIFP(sstr))
8246 IoOFP(dstr) = IoIFP(dstr);
8248 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8249 /* PL_rsfp_filters entries have fake IoDIRP() */
8250 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8251 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8253 IoDIRP(dstr) = IoDIRP(sstr);
8254 IoLINES(dstr) = IoLINES(sstr);
8255 IoPAGE(dstr) = IoPAGE(sstr);
8256 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8257 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8258 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8259 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8260 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8261 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8262 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8263 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8264 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8265 IoTYPE(dstr) = IoTYPE(sstr);
8266 IoFLAGS(dstr) = IoFLAGS(sstr);
8269 SvANY(dstr) = new_XPVAV();
8270 SvCUR(dstr) = SvCUR(sstr);
8271 SvLEN(dstr) = SvLEN(sstr);
8272 SvIVX(dstr) = SvIVX(sstr);
8273 SvNVX(dstr) = SvNVX(sstr);
8274 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8275 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8276 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8277 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8278 if (AvARRAY((AV*)sstr)) {
8279 SV **dst_ary, **src_ary;
8280 SSize_t items = AvFILLp((AV*)sstr) + 1;
8282 src_ary = AvARRAY((AV*)sstr);
8283 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8284 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8285 SvPVX(dstr) = (char*)dst_ary;
8286 AvALLOC((AV*)dstr) = dst_ary;
8287 if (AvREAL((AV*)sstr)) {
8289 *dst_ary++ = sv_dup_inc(*src_ary++);
8293 *dst_ary++ = sv_dup(*src_ary++);
8295 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8296 while (items-- > 0) {
8297 *dst_ary++ = &PL_sv_undef;
8301 SvPVX(dstr) = Nullch;
8302 AvALLOC((AV*)dstr) = (SV**)NULL;
8306 SvANY(dstr) = new_XPVHV();
8307 SvCUR(dstr) = SvCUR(sstr);
8308 SvLEN(dstr) = SvLEN(sstr);
8309 SvIVX(dstr) = SvIVX(sstr);
8310 SvNVX(dstr) = SvNVX(sstr);
8311 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8312 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8313 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8314 if (HvARRAY((HV*)sstr)) {
8316 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8317 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8318 Newz(0, dxhv->xhv_array,
8319 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8320 while (i <= sxhv->xhv_max) {
8321 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8322 !!HvSHAREKEYS(sstr));
8325 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8328 SvPVX(dstr) = Nullch;
8329 HvEITER((HV*)dstr) = (HE*)NULL;
8331 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8332 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8335 SvANY(dstr) = new_XPVFM();
8336 FmLINES(dstr) = FmLINES(sstr);
8340 SvANY(dstr) = new_XPVCV();
8342 SvCUR(dstr) = SvCUR(sstr);
8343 SvLEN(dstr) = SvLEN(sstr);
8344 SvIVX(dstr) = SvIVX(sstr);
8345 SvNVX(dstr) = SvNVX(sstr);
8346 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8347 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8348 if (SvPVX(sstr) && SvLEN(sstr))
8349 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8351 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8352 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8353 CvSTART(dstr) = CvSTART(sstr);
8354 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8355 CvXSUB(dstr) = CvXSUB(sstr);
8356 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8357 CvGV(dstr) = gv_dup(CvGV(sstr));
8358 CvDEPTH(dstr) = CvDEPTH(sstr);
8359 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8360 /* XXX padlists are real, but pretend to be not */
8361 AvREAL_on(CvPADLIST(sstr));
8362 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8363 AvREAL_off(CvPADLIST(sstr));
8364 AvREAL_off(CvPADLIST(dstr));
8367 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8368 if (!CvANON(sstr) || CvCLONED(sstr))
8369 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8371 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8372 CvFLAGS(dstr) = CvFLAGS(sstr);
8375 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8379 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8386 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8391 return (PERL_CONTEXT*)NULL;
8393 /* look for it in the table first */
8394 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8398 /* create anew and remember what it is */
8399 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8400 ptr_table_store(PL_ptr_table, cxs, ncxs);
8403 PERL_CONTEXT *cx = &cxs[ix];
8404 PERL_CONTEXT *ncx = &ncxs[ix];
8405 ncx->cx_type = cx->cx_type;
8406 if (CxTYPE(cx) == CXt_SUBST) {
8407 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8410 ncx->blk_oldsp = cx->blk_oldsp;
8411 ncx->blk_oldcop = cx->blk_oldcop;
8412 ncx->blk_oldretsp = cx->blk_oldretsp;
8413 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8414 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8415 ncx->blk_oldpm = cx->blk_oldpm;
8416 ncx->blk_gimme = cx->blk_gimme;
8417 switch (CxTYPE(cx)) {
8419 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8420 ? cv_dup_inc(cx->blk_sub.cv)
8421 : cv_dup(cx->blk_sub.cv));
8422 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8423 ? av_dup_inc(cx->blk_sub.argarray)
8425 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8426 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8427 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8428 ncx->blk_sub.lval = cx->blk_sub.lval;
8431 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8432 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8433 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8434 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8435 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8438 ncx->blk_loop.label = cx->blk_loop.label;
8439 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8440 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8441 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8442 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8443 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8444 ? cx->blk_loop.iterdata
8445 : gv_dup((GV*)cx->blk_loop.iterdata));
8446 ncx->blk_loop.oldcurpad
8447 = (SV**)ptr_table_fetch(PL_ptr_table,
8448 cx->blk_loop.oldcurpad);
8449 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8450 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8451 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8452 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8453 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8456 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8457 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8458 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8459 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8472 Perl_si_dup(pTHX_ PERL_SI *si)
8477 return (PERL_SI*)NULL;
8479 /* look for it in the table first */
8480 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8484 /* create anew and remember what it is */
8485 Newz(56, nsi, 1, PERL_SI);
8486 ptr_table_store(PL_ptr_table, si, nsi);
8488 nsi->si_stack = av_dup_inc(si->si_stack);
8489 nsi->si_cxix = si->si_cxix;
8490 nsi->si_cxmax = si->si_cxmax;
8491 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8492 nsi->si_type = si->si_type;
8493 nsi->si_prev = si_dup(si->si_prev);
8494 nsi->si_next = si_dup(si->si_next);
8495 nsi->si_markoff = si->si_markoff;
8500 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8501 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8502 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8503 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8504 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8505 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8506 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8507 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8508 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8509 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8510 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8511 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8514 #define pv_dup_inc(p) SAVEPV(p)
8515 #define pv_dup(p) SAVEPV(p)
8516 #define svp_dup_inc(p,pp) any_dup(p,pp)
8519 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8526 /* look for it in the table first */
8527 ret = ptr_table_fetch(PL_ptr_table, v);
8531 /* see if it is part of the interpreter structure */
8532 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8533 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8541 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8543 ANY *ss = proto_perl->Tsavestack;
8544 I32 ix = proto_perl->Tsavestack_ix;
8545 I32 max = proto_perl->Tsavestack_max;
8558 void (*dptr) (void*);
8559 void (*dxptr) (pTHXo_ void*);
8562 Newz(54, nss, max, ANY);
8568 case SAVEt_ITEM: /* normal string */
8569 sv = (SV*)POPPTR(ss,ix);
8570 TOPPTR(nss,ix) = sv_dup_inc(sv);
8571 sv = (SV*)POPPTR(ss,ix);
8572 TOPPTR(nss,ix) = sv_dup_inc(sv);
8574 case SAVEt_SV: /* scalar reference */
8575 sv = (SV*)POPPTR(ss,ix);
8576 TOPPTR(nss,ix) = sv_dup_inc(sv);
8577 gv = (GV*)POPPTR(ss,ix);
8578 TOPPTR(nss,ix) = gv_dup_inc(gv);
8580 case SAVEt_GENERIC_PVREF: /* generic char* */
8581 c = (char*)POPPTR(ss,ix);
8582 TOPPTR(nss,ix) = pv_dup(c);
8583 ptr = POPPTR(ss,ix);
8584 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8586 case SAVEt_GENERIC_SVREF: /* generic sv */
8587 case SAVEt_SVREF: /* scalar reference */
8588 sv = (SV*)POPPTR(ss,ix);
8589 TOPPTR(nss,ix) = sv_dup_inc(sv);
8590 ptr = POPPTR(ss,ix);
8591 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8593 case SAVEt_AV: /* array reference */
8594 av = (AV*)POPPTR(ss,ix);
8595 TOPPTR(nss,ix) = av_dup_inc(av);
8596 gv = (GV*)POPPTR(ss,ix);
8597 TOPPTR(nss,ix) = gv_dup(gv);
8599 case SAVEt_HV: /* hash reference */
8600 hv = (HV*)POPPTR(ss,ix);
8601 TOPPTR(nss,ix) = hv_dup_inc(hv);
8602 gv = (GV*)POPPTR(ss,ix);
8603 TOPPTR(nss,ix) = gv_dup(gv);
8605 case SAVEt_INT: /* int reference */
8606 ptr = POPPTR(ss,ix);
8607 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8608 intval = (int)POPINT(ss,ix);
8609 TOPINT(nss,ix) = intval;
8611 case SAVEt_LONG: /* long reference */
8612 ptr = POPPTR(ss,ix);
8613 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8614 longval = (long)POPLONG(ss,ix);
8615 TOPLONG(nss,ix) = longval;
8617 case SAVEt_I32: /* I32 reference */
8618 case SAVEt_I16: /* I16 reference */
8619 case SAVEt_I8: /* I8 reference */
8620 ptr = POPPTR(ss,ix);
8621 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8625 case SAVEt_IV: /* IV reference */
8626 ptr = POPPTR(ss,ix);
8627 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8631 case SAVEt_SPTR: /* SV* reference */
8632 ptr = POPPTR(ss,ix);
8633 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8634 sv = (SV*)POPPTR(ss,ix);
8635 TOPPTR(nss,ix) = sv_dup(sv);
8637 case SAVEt_VPTR: /* random* reference */
8638 ptr = POPPTR(ss,ix);
8639 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8640 ptr = POPPTR(ss,ix);
8641 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8643 case SAVEt_PPTR: /* char* reference */
8644 ptr = POPPTR(ss,ix);
8645 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8646 c = (char*)POPPTR(ss,ix);
8647 TOPPTR(nss,ix) = pv_dup(c);
8649 case SAVEt_HPTR: /* HV* reference */
8650 ptr = POPPTR(ss,ix);
8651 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8652 hv = (HV*)POPPTR(ss,ix);
8653 TOPPTR(nss,ix) = hv_dup(hv);
8655 case SAVEt_APTR: /* AV* reference */
8656 ptr = POPPTR(ss,ix);
8657 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8658 av = (AV*)POPPTR(ss,ix);
8659 TOPPTR(nss,ix) = av_dup(av);
8662 gv = (GV*)POPPTR(ss,ix);
8663 TOPPTR(nss,ix) = gv_dup(gv);
8665 case SAVEt_GP: /* scalar reference */
8666 gp = (GP*)POPPTR(ss,ix);
8667 TOPPTR(nss,ix) = gp = gp_dup(gp);
8668 (void)GpREFCNT_inc(gp);
8669 gv = (GV*)POPPTR(ss,ix);
8670 TOPPTR(nss,ix) = gv_dup_inc(c);
8671 c = (char*)POPPTR(ss,ix);
8672 TOPPTR(nss,ix) = pv_dup(c);
8679 case SAVEt_MORTALIZESV:
8680 sv = (SV*)POPPTR(ss,ix);
8681 TOPPTR(nss,ix) = sv_dup_inc(sv);
8684 ptr = POPPTR(ss,ix);
8685 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8686 /* these are assumed to be refcounted properly */
8687 switch (((OP*)ptr)->op_type) {
8694 TOPPTR(nss,ix) = ptr;
8699 TOPPTR(nss,ix) = Nullop;
8704 TOPPTR(nss,ix) = Nullop;
8707 c = (char*)POPPTR(ss,ix);
8708 TOPPTR(nss,ix) = pv_dup_inc(c);
8711 longval = POPLONG(ss,ix);
8712 TOPLONG(nss,ix) = longval;
8715 hv = (HV*)POPPTR(ss,ix);
8716 TOPPTR(nss,ix) = hv_dup_inc(hv);
8717 c = (char*)POPPTR(ss,ix);
8718 TOPPTR(nss,ix) = pv_dup_inc(c);
8722 case SAVEt_DESTRUCTOR:
8723 ptr = POPPTR(ss,ix);
8724 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8725 dptr = POPDPTR(ss,ix);
8726 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8728 case SAVEt_DESTRUCTOR_X:
8729 ptr = POPPTR(ss,ix);
8730 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8731 dxptr = POPDXPTR(ss,ix);
8732 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8734 case SAVEt_REGCONTEXT:
8740 case SAVEt_STACK_POS: /* Position on Perl stack */
8744 case SAVEt_AELEM: /* array element */
8745 sv = (SV*)POPPTR(ss,ix);
8746 TOPPTR(nss,ix) = sv_dup_inc(sv);
8749 av = (AV*)POPPTR(ss,ix);
8750 TOPPTR(nss,ix) = av_dup_inc(av);
8752 case SAVEt_HELEM: /* hash element */
8753 sv = (SV*)POPPTR(ss,ix);
8754 TOPPTR(nss,ix) = sv_dup_inc(sv);
8755 sv = (SV*)POPPTR(ss,ix);
8756 TOPPTR(nss,ix) = sv_dup_inc(sv);
8757 hv = (HV*)POPPTR(ss,ix);
8758 TOPPTR(nss,ix) = hv_dup_inc(hv);
8761 ptr = POPPTR(ss,ix);
8762 TOPPTR(nss,ix) = ptr;
8769 av = (AV*)POPPTR(ss,ix);
8770 TOPPTR(nss,ix) = av_dup(av);
8773 longval = (long)POPLONG(ss,ix);
8774 TOPLONG(nss,ix) = longval;
8775 ptr = POPPTR(ss,ix);
8776 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8777 sv = (SV*)POPPTR(ss,ix);
8778 TOPPTR(nss,ix) = sv_dup(sv);
8781 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8793 perl_clone(PerlInterpreter *proto_perl, UV flags)
8796 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8799 #ifdef PERL_IMPLICIT_SYS
8800 return perl_clone_using(proto_perl, flags,
8802 proto_perl->IMemShared,
8803 proto_perl->IMemParse,
8813 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8814 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8815 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8816 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8817 struct IPerlDir* ipD, struct IPerlSock* ipS,
8818 struct IPerlProc* ipP)
8820 /* XXX many of the string copies here can be optimized if they're
8821 * constants; they need to be allocated as common memory and just
8822 * their pointers copied. */
8826 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8828 PERL_SET_THX(pPerl);
8829 # else /* !PERL_OBJECT */
8830 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8831 PERL_SET_THX(my_perl);
8834 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8840 # else /* !DEBUGGING */
8841 Zero(my_perl, 1, PerlInterpreter);
8842 # endif /* DEBUGGING */
8846 PL_MemShared = ipMS;
8854 # endif /* PERL_OBJECT */
8855 #else /* !PERL_IMPLICIT_SYS */
8857 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8858 PERL_SET_THX(my_perl);
8861 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8867 # else /* !DEBUGGING */
8868 Zero(my_perl, 1, PerlInterpreter);
8869 # endif /* DEBUGGING */
8870 #endif /* PERL_IMPLICIT_SYS */
8873 PL_xiv_arenaroot = NULL;
8875 PL_xnv_arenaroot = NULL;
8877 PL_xrv_arenaroot = NULL;
8879 PL_xpv_arenaroot = NULL;
8881 PL_xpviv_arenaroot = NULL;
8882 PL_xpviv_root = NULL;
8883 PL_xpvnv_arenaroot = NULL;
8884 PL_xpvnv_root = NULL;
8885 PL_xpvcv_arenaroot = NULL;
8886 PL_xpvcv_root = NULL;
8887 PL_xpvav_arenaroot = NULL;
8888 PL_xpvav_root = NULL;
8889 PL_xpvhv_arenaroot = NULL;
8890 PL_xpvhv_root = NULL;
8891 PL_xpvmg_arenaroot = NULL;
8892 PL_xpvmg_root = NULL;
8893 PL_xpvlv_arenaroot = NULL;
8894 PL_xpvlv_root = NULL;
8895 PL_xpvbm_arenaroot = NULL;
8896 PL_xpvbm_root = NULL;
8897 PL_he_arenaroot = NULL;
8899 PL_nice_chunk = NULL;
8900 PL_nice_chunk_size = 0;
8903 PL_sv_root = Nullsv;
8904 PL_sv_arenaroot = Nullsv;
8906 PL_debug = proto_perl->Idebug;
8908 /* create SV map for pointer relocation */
8909 PL_ptr_table = ptr_table_new();
8911 /* initialize these special pointers as early as possible */
8912 SvANY(&PL_sv_undef) = NULL;
8913 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8914 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8915 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8918 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8920 SvANY(&PL_sv_no) = new_XPVNV();
8922 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8923 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8924 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8925 SvCUR(&PL_sv_no) = 0;
8926 SvLEN(&PL_sv_no) = 1;
8927 SvNVX(&PL_sv_no) = 0;
8928 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8931 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8933 SvANY(&PL_sv_yes) = new_XPVNV();
8935 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8936 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8937 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8938 SvCUR(&PL_sv_yes) = 1;
8939 SvLEN(&PL_sv_yes) = 2;
8940 SvNVX(&PL_sv_yes) = 1;
8941 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8943 /* create shared string table */
8944 PL_strtab = newHV();
8945 HvSHAREKEYS_off(PL_strtab);
8946 hv_ksplit(PL_strtab, 512);
8947 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8949 PL_compiling = proto_perl->Icompiling;
8950 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8951 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8952 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8953 if (!specialWARN(PL_compiling.cop_warnings))
8954 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8955 if (!specialCopIO(PL_compiling.cop_io))
8956 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8957 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8959 /* pseudo environmental stuff */
8960 PL_origargc = proto_perl->Iorigargc;
8962 New(0, PL_origargv, i+1, char*);
8963 PL_origargv[i] = '\0';
8965 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8967 PL_envgv = gv_dup(proto_perl->Ienvgv);
8968 PL_incgv = gv_dup(proto_perl->Iincgv);
8969 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8970 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8971 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8972 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8975 PL_minus_c = proto_perl->Iminus_c;
8976 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8977 PL_localpatches = proto_perl->Ilocalpatches;
8978 PL_splitstr = proto_perl->Isplitstr;
8979 PL_preprocess = proto_perl->Ipreprocess;
8980 PL_minus_n = proto_perl->Iminus_n;
8981 PL_minus_p = proto_perl->Iminus_p;
8982 PL_minus_l = proto_perl->Iminus_l;
8983 PL_minus_a = proto_perl->Iminus_a;
8984 PL_minus_F = proto_perl->Iminus_F;
8985 PL_doswitches = proto_perl->Idoswitches;
8986 PL_dowarn = proto_perl->Idowarn;
8987 PL_doextract = proto_perl->Idoextract;
8988 PL_sawampersand = proto_perl->Isawampersand;
8989 PL_unsafe = proto_perl->Iunsafe;
8990 PL_inplace = SAVEPV(proto_perl->Iinplace);
8991 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8992 PL_perldb = proto_perl->Iperldb;
8993 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8995 /* magical thingies */
8996 /* XXX time(&PL_basetime) when asked for? */
8997 PL_basetime = proto_perl->Ibasetime;
8998 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9000 PL_maxsysfd = proto_perl->Imaxsysfd;
9001 PL_multiline = proto_perl->Imultiline;
9002 PL_statusvalue = proto_perl->Istatusvalue;
9004 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9007 /* shortcuts to various I/O objects */
9008 PL_stdingv = gv_dup(proto_perl->Istdingv);
9009 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9010 PL_defgv = gv_dup(proto_perl->Idefgv);
9011 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9012 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
9013 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
9015 /* shortcuts to regexp stuff */
9016 PL_replgv = gv_dup(proto_perl->Ireplgv);
9018 /* shortcuts to misc objects */
9019 PL_errgv = gv_dup(proto_perl->Ierrgv);
9021 /* shortcuts to debugging objects */
9022 PL_DBgv = gv_dup(proto_perl->IDBgv);
9023 PL_DBline = gv_dup(proto_perl->IDBline);
9024 PL_DBsub = gv_dup(proto_perl->IDBsub);
9025 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9026 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9027 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9028 PL_lineary = av_dup(proto_perl->Ilineary);
9029 PL_dbargs = av_dup(proto_perl->Idbargs);
9032 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9033 PL_curstash = hv_dup(proto_perl->Tcurstash);
9034 PL_debstash = hv_dup(proto_perl->Idebstash);
9035 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9036 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9038 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9039 PL_endav = av_dup_inc(proto_perl->Iendav);
9040 PL_checkav = av_dup_inc(proto_perl->Icheckav);
9041 PL_initav = av_dup_inc(proto_perl->Iinitav);
9043 PL_sub_generation = proto_perl->Isub_generation;
9045 /* funky return mechanisms */
9046 PL_forkprocess = proto_perl->Iforkprocess;
9048 /* subprocess state */
9049 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9051 /* internal state */
9052 PL_tainting = proto_perl->Itainting;
9053 PL_maxo = proto_perl->Imaxo;
9054 if (proto_perl->Iop_mask)
9055 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9057 PL_op_mask = Nullch;
9059 /* current interpreter roots */
9060 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9061 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9062 PL_main_start = proto_perl->Imain_start;
9063 PL_eval_root = proto_perl->Ieval_root;
9064 PL_eval_start = proto_perl->Ieval_start;
9066 /* runtime control stuff */
9067 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9068 PL_copline = proto_perl->Icopline;
9070 PL_filemode = proto_perl->Ifilemode;
9071 PL_lastfd = proto_perl->Ilastfd;
9072 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9075 PL_gensym = proto_perl->Igensym;
9076 PL_preambled = proto_perl->Ipreambled;
9077 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9078 PL_laststatval = proto_perl->Ilaststatval;
9079 PL_laststype = proto_perl->Ilaststype;
9080 PL_mess_sv = Nullsv;
9082 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
9083 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9085 /* interpreter atexit processing */
9086 PL_exitlistlen = proto_perl->Iexitlistlen;
9087 if (PL_exitlistlen) {
9088 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9089 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9092 PL_exitlist = (PerlExitListEntry*)NULL;
9093 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9095 PL_profiledata = NULL;
9096 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9097 /* PL_rsfp_filters entries have fake IoDIRP() */
9098 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9100 PL_compcv = cv_dup(proto_perl->Icompcv);
9101 PL_comppad = av_dup(proto_perl->Icomppad);
9102 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9103 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9104 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9105 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9106 proto_perl->Tcurpad);
9108 #ifdef HAVE_INTERP_INTERN
9109 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9112 /* more statics moved here */
9113 PL_generation = proto_perl->Igeneration;
9114 PL_DBcv = cv_dup(proto_perl->IDBcv);
9116 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9117 PL_in_clean_all = proto_perl->Iin_clean_all;
9119 PL_uid = proto_perl->Iuid;
9120 PL_euid = proto_perl->Ieuid;
9121 PL_gid = proto_perl->Igid;
9122 PL_egid = proto_perl->Iegid;
9123 PL_nomemok = proto_perl->Inomemok;
9124 PL_an = proto_perl->Ian;
9125 PL_cop_seqmax = proto_perl->Icop_seqmax;
9126 PL_op_seqmax = proto_perl->Iop_seqmax;
9127 PL_evalseq = proto_perl->Ievalseq;
9128 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9129 PL_origalen = proto_perl->Iorigalen;
9130 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9131 PL_osname = SAVEPV(proto_perl->Iosname);
9132 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9133 PL_sighandlerp = proto_perl->Isighandlerp;
9136 PL_runops = proto_perl->Irunops;
9138 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9141 PL_cshlen = proto_perl->Icshlen;
9142 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9145 PL_lex_state = proto_perl->Ilex_state;
9146 PL_lex_defer = proto_perl->Ilex_defer;
9147 PL_lex_expect = proto_perl->Ilex_expect;
9148 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9149 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9150 PL_lex_starts = proto_perl->Ilex_starts;
9151 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9152 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9153 PL_lex_op = proto_perl->Ilex_op;
9154 PL_lex_inpat = proto_perl->Ilex_inpat;
9155 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9156 PL_lex_brackets = proto_perl->Ilex_brackets;
9157 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9158 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9159 PL_lex_casemods = proto_perl->Ilex_casemods;
9160 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9161 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9163 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9164 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9165 PL_nexttoke = proto_perl->Inexttoke;
9167 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9168 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9169 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9170 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9171 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9172 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9173 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9174 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9175 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9176 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9177 PL_pending_ident = proto_perl->Ipending_ident;
9178 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9180 PL_expect = proto_perl->Iexpect;
9182 PL_multi_start = proto_perl->Imulti_start;
9183 PL_multi_end = proto_perl->Imulti_end;
9184 PL_multi_open = proto_perl->Imulti_open;
9185 PL_multi_close = proto_perl->Imulti_close;
9187 PL_error_count = proto_perl->Ierror_count;
9188 PL_subline = proto_perl->Isubline;
9189 PL_subname = sv_dup_inc(proto_perl->Isubname);
9191 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9192 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9193 PL_padix = proto_perl->Ipadix;
9194 PL_padix_floor = proto_perl->Ipadix_floor;
9195 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9197 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9198 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9199 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9200 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9201 PL_last_lop_op = proto_perl->Ilast_lop_op;
9202 PL_in_my = proto_perl->Iin_my;
9203 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9205 PL_cryptseen = proto_perl->Icryptseen;
9208 PL_hints = proto_perl->Ihints;
9210 PL_amagic_generation = proto_perl->Iamagic_generation;
9212 #ifdef USE_LOCALE_COLLATE
9213 PL_collation_ix = proto_perl->Icollation_ix;
9214 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9215 PL_collation_standard = proto_perl->Icollation_standard;
9216 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9217 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9218 #endif /* USE_LOCALE_COLLATE */
9220 #ifdef USE_LOCALE_NUMERIC
9221 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9222 PL_numeric_standard = proto_perl->Inumeric_standard;
9223 PL_numeric_local = proto_perl->Inumeric_local;
9224 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9225 #endif /* !USE_LOCALE_NUMERIC */
9227 /* utf8 character classes */
9228 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9229 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9230 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9231 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9232 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9233 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9234 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9235 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9236 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9237 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9238 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9239 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9240 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9241 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9242 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9243 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9244 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9247 PL_last_swash_hv = Nullhv; /* reinits on demand */
9248 PL_last_swash_klen = 0;
9249 PL_last_swash_key[0]= '\0';
9250 PL_last_swash_tmps = (U8*)NULL;
9251 PL_last_swash_slen = 0;
9253 /* perly.c globals */
9254 PL_yydebug = proto_perl->Iyydebug;
9255 PL_yynerrs = proto_perl->Iyynerrs;
9256 PL_yyerrflag = proto_perl->Iyyerrflag;
9257 PL_yychar = proto_perl->Iyychar;
9258 PL_yyval = proto_perl->Iyyval;
9259 PL_yylval = proto_perl->Iyylval;
9261 PL_glob_index = proto_perl->Iglob_index;
9262 PL_srand_called = proto_perl->Isrand_called;
9263 PL_uudmap['M'] = 0; /* reinits on demand */
9264 PL_bitcount = Nullch; /* reinits on demand */
9266 if (proto_perl->Ipsig_pend) {
9267 Newz(0, PL_psig_pend, SIG_SIZE, int);
9270 PL_psig_pend = (int*)NULL;
9273 if (proto_perl->Ipsig_ptr) {
9274 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9275 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9276 for (i = 1; i < SIG_SIZE; i++) {
9277 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9278 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9282 PL_psig_ptr = (SV**)NULL;
9283 PL_psig_name = (SV**)NULL;
9286 /* thrdvar.h stuff */
9288 if (flags & CLONEf_COPY_STACKS) {
9289 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9290 PL_tmps_ix = proto_perl->Ttmps_ix;
9291 PL_tmps_max = proto_perl->Ttmps_max;
9292 PL_tmps_floor = proto_perl->Ttmps_floor;
9293 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9295 while (i <= PL_tmps_ix) {
9296 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9300 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9301 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9302 Newz(54, PL_markstack, i, I32);
9303 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9304 - proto_perl->Tmarkstack);
9305 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9306 - proto_perl->Tmarkstack);
9307 Copy(proto_perl->Tmarkstack, PL_markstack,
9308 PL_markstack_ptr - PL_markstack + 1, I32);
9310 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9311 * NOTE: unlike the others! */
9312 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9313 PL_scopestack_max = proto_perl->Tscopestack_max;
9314 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9315 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9317 /* next push_return() sets PL_retstack[PL_retstack_ix]
9318 * NOTE: unlike the others! */
9319 PL_retstack_ix = proto_perl->Tretstack_ix;
9320 PL_retstack_max = proto_perl->Tretstack_max;
9321 Newz(54, PL_retstack, PL_retstack_max, OP*);
9322 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9324 /* NOTE: si_dup() looks at PL_markstack */
9325 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9327 /* PL_curstack = PL_curstackinfo->si_stack; */
9328 PL_curstack = av_dup(proto_perl->Tcurstack);
9329 PL_mainstack = av_dup(proto_perl->Tmainstack);
9331 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9332 PL_stack_base = AvARRAY(PL_curstack);
9333 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9334 - proto_perl->Tstack_base);
9335 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9337 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9338 * NOTE: unlike the others! */
9339 PL_savestack_ix = proto_perl->Tsavestack_ix;
9340 PL_savestack_max = proto_perl->Tsavestack_max;
9341 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9342 PL_savestack = ss_dup(proto_perl);
9346 ENTER; /* perl_destruct() wants to LEAVE; */
9349 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9350 PL_top_env = &PL_start_env;
9352 PL_op = proto_perl->Top;
9355 PL_Xpv = (XPV*)NULL;
9356 PL_na = proto_perl->Tna;
9358 PL_statbuf = proto_perl->Tstatbuf;
9359 PL_statcache = proto_perl->Tstatcache;
9360 PL_statgv = gv_dup(proto_perl->Tstatgv);
9361 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9363 PL_timesbuf = proto_perl->Ttimesbuf;
9366 PL_tainted = proto_perl->Ttainted;
9367 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9368 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9369 PL_rs = sv_dup_inc(proto_perl->Trs);
9370 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9371 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9372 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9373 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9374 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9375 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9376 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9378 PL_restartop = proto_perl->Trestartop;
9379 PL_in_eval = proto_perl->Tin_eval;
9380 PL_delaymagic = proto_perl->Tdelaymagic;
9381 PL_dirty = proto_perl->Tdirty;
9382 PL_localizing = proto_perl->Tlocalizing;
9384 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9385 PL_protect = proto_perl->Tprotect;
9387 PL_errors = sv_dup_inc(proto_perl->Terrors);
9388 PL_av_fetch_sv = Nullsv;
9389 PL_hv_fetch_sv = Nullsv;
9390 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9391 PL_modcount = proto_perl->Tmodcount;
9392 PL_lastgotoprobe = Nullop;
9393 PL_dumpindent = proto_perl->Tdumpindent;
9395 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9396 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9397 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9398 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9399 PL_sortcxix = proto_perl->Tsortcxix;
9400 PL_efloatbuf = Nullch; /* reinits on demand */
9401 PL_efloatsize = 0; /* reinits on demand */
9405 PL_screamfirst = NULL;
9406 PL_screamnext = NULL;
9407 PL_maxscream = -1; /* reinits on demand */
9408 PL_lastscream = Nullsv;
9410 PL_watchaddr = NULL;
9411 PL_watchok = Nullch;
9413 PL_regdummy = proto_perl->Tregdummy;
9414 PL_regcomp_parse = Nullch;
9415 PL_regxend = Nullch;
9416 PL_regcode = (regnode*)NULL;
9419 PL_regprecomp = Nullch;
9424 PL_seen_zerolen = 0;
9426 PL_regcomp_rx = (regexp*)NULL;
9428 PL_colorset = 0; /* reinits PL_colors[] */
9429 /*PL_colors[6] = {0,0,0,0,0,0};*/
9430 PL_reg_whilem_seen = 0;
9431 PL_reginput = Nullch;
9434 PL_regstartp = (I32*)NULL;
9435 PL_regendp = (I32*)NULL;
9436 PL_reglastparen = (U32*)NULL;
9437 PL_regtill = Nullch;
9438 PL_reg_start_tmp = (char**)NULL;
9439 PL_reg_start_tmpl = 0;
9440 PL_regdata = (struct reg_data*)NULL;
9443 PL_reg_eval_set = 0;
9445 PL_regprogram = (regnode*)NULL;
9447 PL_regcc = (CURCUR*)NULL;
9448 PL_reg_call_cc = (struct re_cc_state*)NULL;
9449 PL_reg_re = (regexp*)NULL;
9450 PL_reg_ganch = Nullch;
9452 PL_reg_magic = (MAGIC*)NULL;
9454 PL_reg_oldcurpm = (PMOP*)NULL;
9455 PL_reg_curpm = (PMOP*)NULL;
9456 PL_reg_oldsaved = Nullch;
9457 PL_reg_oldsavedlen = 0;
9459 PL_reg_leftiter = 0;
9460 PL_reg_poscache = Nullch;
9461 PL_reg_poscache_size= 0;
9463 /* RE engine - function pointers */
9464 PL_regcompp = proto_perl->Tregcompp;
9465 PL_regexecp = proto_perl->Tregexecp;
9466 PL_regint_start = proto_perl->Tregint_start;
9467 PL_regint_string = proto_perl->Tregint_string;
9468 PL_regfree = proto_perl->Tregfree;
9470 PL_reginterp_cnt = 0;
9471 PL_reg_starttry = 0;
9473 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9474 ptr_table_free(PL_ptr_table);
9475 PL_ptr_table = NULL;
9479 return (PerlInterpreter*)pPerl;
9485 #else /* !USE_ITHREADS */
9491 #endif /* USE_ITHREADS */
9494 do_report_used(pTHXo_ SV *sv)
9496 if (SvTYPE(sv) != SVTYPEMASK) {
9497 PerlIO_printf(Perl_debug_log, "****\n");
9503 do_clean_objs(pTHXo_ SV *sv)
9507 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9508 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9509 if (SvWEAKREF(sv)) {
9520 /* XXX Might want to check arrays, etc. */
9523 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9525 do_clean_named_objs(pTHXo_ SV *sv)
9527 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9528 if ( SvOBJECT(GvSV(sv)) ||
9529 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9530 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9531 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9532 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9534 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9542 do_clean_all(pTHXo_ SV *sv)
9544 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9545 SvFLAGS(sv) |= SVf_BREAK;