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);
2310 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2312 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2313 #ifdef NV_PRESERVES_UV
2316 /* Only set the public NV OK flag if this NV preserves the IV */
2317 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2318 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2319 : (SvIVX(sv) == I_V(SvNVX(sv))))
2325 else if (SvPOKp(sv) && SvLEN(sv)) {
2326 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2328 SvNVX(sv) = Atof(SvPVX(sv));
2329 #ifdef NV_PRESERVES_UV
2332 /* Only set the public NV OK flag if this NV preserves the value in
2333 the PV at least as well as an IV/UV would.
2334 Not sure how to do this 100% reliably. */
2335 /* if that shift count is out of range then Configure's test is
2336 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2338 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2339 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2340 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2341 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2342 /* Definitely too large/small to fit in an integer, so no loss
2343 of precision going to integer in the future via NV */
2346 /* Is it something we can run through strtol etc (ie no
2347 trailing exponent part)? */
2348 int numtype = looks_like_number(sv);
2349 /* XXX probably should cache this if called above */
2352 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2353 /* Can't use strtol etc to convert this string, so don't try */
2356 sv_2inuv_non_preserve (sv, numtype);
2358 #endif /* NV_PRESERVES_UV */
2361 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2363 if (SvTYPE(sv) < SVt_NV)
2364 /* Typically the caller expects that sv_any is not NULL now. */
2365 /* XXX Ilya implies that this is a bug in callers that assume this
2366 and ideally should be fixed. */
2367 sv_upgrade(sv, SVt_NV);
2370 #if defined(USE_LONG_DOUBLE)
2372 STORE_NUMERIC_LOCAL_SET_STANDARD();
2373 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2374 PTR2UV(sv), SvNVX(sv));
2375 RESTORE_NUMERIC_LOCAL();
2379 STORE_NUMERIC_LOCAL_SET_STANDARD();
2380 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2381 PTR2UV(sv), SvNVX(sv));
2382 RESTORE_NUMERIC_LOCAL();
2389 S_asIV(pTHX_ SV *sv)
2391 I32 numtype = looks_like_number(sv);
2394 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2395 return Atol(SvPVX(sv));
2397 if (ckWARN(WARN_NUMERIC))
2400 d = Atof(SvPVX(sv));
2405 S_asUV(pTHX_ SV *sv)
2407 I32 numtype = looks_like_number(sv);
2410 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2411 return Strtoul(SvPVX(sv), Null(char**), 10);
2414 if (ckWARN(WARN_NUMERIC))
2417 return U_V(Atof(SvPVX(sv)));
2421 * Returns a combination of (advisory only - can get false negatives)
2422 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2423 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2424 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2425 * 0 if does not look like number.
2427 * (atol and strtol stop when they hit a decimal point. strtol will return
2428 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2429 * do this, and vendors have had 11 years to get it right.
2430 * However, will try to make it still work with only atol
2432 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2433 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2434 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2435 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2436 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2437 * IS_NUMBER_NOT_INT saw "." or "e"
2439 * IS_NUMBER_INFINITY
2443 =for apidoc looks_like_number
2445 Test if an the content of an SV looks like a number (or is a
2446 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2447 issue a non-numeric warning), even if your atof() doesn't grok them.
2453 Perl_looks_like_number(pTHX_ SV *sv)
2456 register char *send;
2457 register char *sbegin;
2458 register char *nbegin;
2462 #ifdef USE_LOCALE_NUMERIC
2463 bool specialradix = FALSE;
2470 else if (SvPOKp(sv))
2471 sbegin = SvPV(sv, len);
2474 send = sbegin + len;
2481 numtype = IS_NUMBER_NEG;
2488 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2489 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2490 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2491 * will need (int)atof().
2494 /* next must be digit or the radix separator or beginning of infinity */
2498 } while (isDIGIT(*s));
2500 /* Aaargh. long long really is irritating.
2501 In the gospel according to ANSI 1989, it is an axiom that "long"
2502 is the longest integer type, and that if you don't know how long
2503 something is you can cast it to long, and nothing will be lost
2504 (except possibly speed of execution if long is slower than the
2506 Now, one can't be sure if the old rules apply, or long long
2507 (or some other newfangled thing) is actually longer than the
2508 (formerly) longest thing.
2510 /* This lot will work for 64 bit *as long as* either
2511 either long is 64 bit
2512 or we can find both strtol/strtoq and strtoul/strtouq
2513 If not, we really should refuse to let the user use 64 bit IVs
2514 By "64 bit" I really mean IVs that don't get preserved by NVs
2515 It also should work for 128 bit IVs. Can any lend me a machine to
2518 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2519 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2520 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2521 ? sizeof(long) : sizeof (IV))*8-1))
2522 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2524 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2525 digit less (IV_MAX= 9223372036854775807,
2526 UV_MAX= 18446744073709551615) so be cautious */
2527 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2530 #ifdef USE_LOCALE_NUMERIC
2531 || (specialradix = IS_NUMERIC_RADIX(s))
2534 #ifdef USE_LOCALE_NUMERIC
2536 s += SvCUR(PL_numeric_radix_sv);
2540 numtype |= IS_NUMBER_NOT_INT;
2541 while (isDIGIT(*s)) /* optional digits after the radix */
2546 #ifdef USE_LOCALE_NUMERIC
2547 || (specialradix = IS_NUMERIC_RADIX(s))
2550 #ifdef USE_LOCALE_NUMERIC
2552 s += SvCUR(PL_numeric_radix_sv);
2556 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2557 /* no digits before the radix means we need digits after it */
2561 } while (isDIGIT(*s));
2566 else if (*s == 'I' || *s == 'i') {
2567 s++; if (*s != 'N' && *s != 'n') return 0;
2568 s++; if (*s != 'F' && *s != 'f') return 0;
2569 s++; if (*s == 'I' || *s == 'i') {
2570 s++; if (*s != 'N' && *s != 'n') return 0;
2571 s++; if (*s != 'I' && *s != 'i') return 0;
2572 s++; if (*s != 'T' && *s != 't') return 0;
2573 s++; if (*s != 'Y' && *s != 'y') return 0;
2582 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2583 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2585 /* we can have an optional exponent part */
2586 if (*s == 'e' || *s == 'E') {
2587 numtype &= IS_NUMBER_NEG;
2588 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2590 if (*s == '+' || *s == '-')
2595 } while (isDIGIT(*s));
2605 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2606 return IS_NUMBER_TO_INT_BY_ATOL;
2611 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2614 return sv_2pv(sv, &n_a);
2617 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2619 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2621 char *ptr = buf + TYPE_CHARS(UV);
2635 *--ptr = '0' + (uv % 10);
2644 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2649 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2650 char *tmpbuf = tbuf;
2656 if (SvGMAGICAL(sv)) {
2664 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2666 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2671 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2676 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2677 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2684 if (SvTHINKFIRST(sv)) {
2687 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2688 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2689 return SvPV(tmpstr,*lp);
2696 switch (SvTYPE(sv)) {
2698 if ( ((SvFLAGS(sv) &
2699 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2700 == (SVs_OBJECT|SVs_RMG))
2701 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2702 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2703 regexp *re = (regexp *)mg->mg_obj;
2706 char *fptr = "msix";
2711 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2713 while((ch = *fptr++)) {
2715 reflags[left++] = ch;
2718 reflags[right--] = ch;
2723 reflags[left] = '-';
2727 mg->mg_len = re->prelen + 4 + left;
2728 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2729 Copy("(?", mg->mg_ptr, 2, char);
2730 Copy(reflags, mg->mg_ptr+2, left, char);
2731 Copy(":", mg->mg_ptr+left+2, 1, char);
2732 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2733 mg->mg_ptr[mg->mg_len - 1] = ')';
2734 mg->mg_ptr[mg->mg_len] = 0;
2736 PL_reginterp_cnt += re->program[0].next_off;
2748 case SVt_PVBM: if (SvROK(sv))
2751 s = "SCALAR"; break;
2752 case SVt_PVLV: s = "LVALUE"; break;
2753 case SVt_PVAV: s = "ARRAY"; break;
2754 case SVt_PVHV: s = "HASH"; break;
2755 case SVt_PVCV: s = "CODE"; break;
2756 case SVt_PVGV: s = "GLOB"; break;
2757 case SVt_PVFM: s = "FORMAT"; break;
2758 case SVt_PVIO: s = "IO"; break;
2759 default: s = "UNKNOWN"; break;
2763 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2766 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2772 if (SvREADONLY(sv) && !SvOK(sv)) {
2773 if (ckWARN(WARN_UNINITIALIZED))
2779 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2780 /* I'm assuming that if both IV and NV are equally valid then
2781 converting the IV is going to be more efficient */
2782 U32 isIOK = SvIOK(sv);
2783 U32 isUIOK = SvIsUV(sv);
2784 char buf[TYPE_CHARS(UV)];
2787 if (SvTYPE(sv) < SVt_PVIV)
2788 sv_upgrade(sv, SVt_PVIV);
2790 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2792 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2793 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2794 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2795 SvCUR_set(sv, ebuf - ptr);
2805 else if (SvNOKp(sv)) {
2806 if (SvTYPE(sv) < SVt_PVNV)
2807 sv_upgrade(sv, SVt_PVNV);
2808 /* The +20 is pure guesswork. Configure test needed. --jhi */
2809 SvGROW(sv, NV_DIG + 20);
2811 olderrno = errno; /* some Xenix systems wipe out errno here */
2813 if (SvNVX(sv) == 0.0)
2814 (void)strcpy(s,"0");
2818 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2821 #ifdef FIXNEGATIVEZERO
2822 if (*s == '-' && s[1] == '0' && !s[2])
2832 if (ckWARN(WARN_UNINITIALIZED)
2833 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2836 if (SvTYPE(sv) < SVt_PV)
2837 /* Typically the caller expects that sv_any is not NULL now. */
2838 sv_upgrade(sv, SVt_PV);
2841 *lp = s - SvPVX(sv);
2844 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2845 PTR2UV(sv),SvPVX(sv)));
2849 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2850 /* Sneaky stuff here */
2854 tsv = newSVpv(tmpbuf, 0);
2870 len = strlen(tmpbuf);
2872 #ifdef FIXNEGATIVEZERO
2873 if (len == 2 && t[0] == '-' && t[1] == '0') {
2878 (void)SvUPGRADE(sv, SVt_PV);
2880 s = SvGROW(sv, len + 1);
2889 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2892 return sv_2pvbyte(sv, &n_a);
2896 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2898 sv_utf8_downgrade(sv,0);
2899 return SvPV(sv,*lp);
2903 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2906 return sv_2pvutf8(sv, &n_a);
2910 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2912 sv_utf8_upgrade(sv);
2913 return SvPV(sv,*lp);
2916 /* This function is only called on magical items */
2918 Perl_sv_2bool(pTHX_ register SV *sv)
2927 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2928 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2929 return SvTRUE(tmpsv);
2930 return SvRV(sv) != 0;
2933 register XPV* Xpvtmp;
2934 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2935 (*Xpvtmp->xpv_pv > '0' ||
2936 Xpvtmp->xpv_cur > 1 ||
2937 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2944 return SvIVX(sv) != 0;
2947 return SvNVX(sv) != 0.0;
2955 =for apidoc sv_utf8_upgrade
2957 Convert the PV of an SV to its UTF8-encoded form.
2958 Forces the SV to string form it it is not already.
2959 Always sets the SvUTF8 flag to avoid future validity checks even
2960 if all the bytes have hibit clear.
2966 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2976 (void) sv_2pv(sv,&len);
2984 if (SvREADONLY(sv) && SvFAKE(sv)) {
2985 sv_force_normal(sv);
2988 /* This function could be much more efficient if we had a FLAG in SVs
2989 * to signal if there are any hibit chars in the PV.
2990 * Given that there isn't make loop fast as possible
2992 s = (U8 *) SvPVX(sv);
2993 e = (U8 *) SvEND(sv);
2997 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3003 len = SvCUR(sv) + 1; /* Plus the \0 */
3004 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3005 SvCUR(sv) = len - 1;
3007 Safefree(s); /* No longer using what was there before. */
3008 SvLEN(sv) = len; /* No longer know the real size. */
3010 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3016 =for apidoc sv_utf8_downgrade
3018 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3019 This may not be possible if the PV contains non-byte encoding characters;
3020 if this is the case, either returns false or, if C<fail_ok> is not
3027 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3029 if (SvPOK(sv) && SvUTF8(sv)) {
3034 if (SvREADONLY(sv) && SvFAKE(sv))
3035 sv_force_normal(sv);
3036 s = (U8 *) SvPV(sv, len);
3037 if (!utf8_to_bytes(s, &len)) {
3040 #ifdef USE_BYTES_DOWNGRADES
3043 U8 *e = (U8 *) SvEND(sv);
3046 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3047 if (first && ch > 255) {
3049 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3050 PL_op_desc[PL_op->op_type]);
3052 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3059 len = (d - (U8 *) SvPVX(sv));
3064 Perl_croak(aTHX_ "Wide character in %s",
3065 PL_op_desc[PL_op->op_type]);
3067 Perl_croak(aTHX_ "Wide character");
3078 =for apidoc sv_utf8_encode
3080 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3081 flag so that it looks like octets again. Used as a building block
3082 for encode_utf8 in Encode.xs
3088 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3090 (void) sv_utf8_upgrade(sv);
3095 =for apidoc sv_utf8_decode
3097 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3098 turn of SvUTF8 if needed so that we see characters. Used as a building block
3099 for decode_utf8 in Encode.xs
3107 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3113 /* The octets may have got themselves encoded - get them back as bytes */
3114 if (!sv_utf8_downgrade(sv, TRUE))
3117 /* it is actually just a matter of turning the utf8 flag on, but
3118 * we want to make sure everything inside is valid utf8 first.
3120 c = (U8 *) SvPVX(sv);
3121 if (!is_utf8_string(c, SvCUR(sv)+1))
3123 e = (U8 *) SvEND(sv);
3126 if (!UTF8_IS_INVARIANT(ch)) {
3136 /* Note: sv_setsv() should not be called with a source string that needs
3137 * to be reused, since it may destroy the source string if it is marked
3142 =for apidoc sv_setsv
3144 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3145 The source SV may be destroyed if it is mortal. Does not handle 'set'
3146 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3153 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3155 register U32 sflags;
3161 SV_CHECK_THINKFIRST(dstr);
3163 sstr = &PL_sv_undef;
3164 stype = SvTYPE(sstr);
3165 dtype = SvTYPE(dstr);
3169 /* There's a lot of redundancy below but we're going for speed here */
3174 if (dtype != SVt_PVGV) {
3175 (void)SvOK_off(dstr);
3183 sv_upgrade(dstr, SVt_IV);
3186 sv_upgrade(dstr, SVt_PVNV);
3190 sv_upgrade(dstr, SVt_PVIV);
3193 (void)SvIOK_only(dstr);
3194 SvIVX(dstr) = SvIVX(sstr);
3197 if (SvTAINTED(sstr))
3208 sv_upgrade(dstr, SVt_NV);
3213 sv_upgrade(dstr, SVt_PVNV);
3216 SvNVX(dstr) = SvNVX(sstr);
3217 (void)SvNOK_only(dstr);
3218 if (SvTAINTED(sstr))
3226 sv_upgrade(dstr, SVt_RV);
3227 else if (dtype == SVt_PVGV &&
3228 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3231 if (GvIMPORTED(dstr) != GVf_IMPORTED
3232 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3234 GvIMPORTED_on(dstr);
3245 sv_upgrade(dstr, SVt_PV);
3248 if (dtype < SVt_PVIV)
3249 sv_upgrade(dstr, SVt_PVIV);
3252 if (dtype < SVt_PVNV)
3253 sv_upgrade(dstr, SVt_PVNV);
3260 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3261 PL_op_name[PL_op->op_type]);
3263 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3267 if (dtype <= SVt_PVGV) {
3269 if (dtype != SVt_PVGV) {
3270 char *name = GvNAME(sstr);
3271 STRLEN len = GvNAMELEN(sstr);
3272 sv_upgrade(dstr, SVt_PVGV);
3273 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3274 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3275 GvNAME(dstr) = savepvn(name, len);
3276 GvNAMELEN(dstr) = len;
3277 SvFAKE_on(dstr); /* can coerce to non-glob */
3279 /* ahem, death to those who redefine active sort subs */
3280 else if (PL_curstackinfo->si_type == PERLSI_SORT
3281 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3282 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3285 #ifdef GV_SHARED_CHECK
3286 if (GvSHARED((GV*)dstr)) {
3287 Perl_croak(aTHX_ PL_no_modify);
3291 (void)SvOK_off(dstr);
3292 GvINTRO_off(dstr); /* one-shot flag */
3294 GvGP(dstr) = gp_ref(GvGP(sstr));
3295 if (SvTAINTED(sstr))
3297 if (GvIMPORTED(dstr) != GVf_IMPORTED
3298 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3300 GvIMPORTED_on(dstr);
3308 if (SvGMAGICAL(sstr)) {
3310 if (SvTYPE(sstr) != stype) {
3311 stype = SvTYPE(sstr);
3312 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3316 if (stype == SVt_PVLV)
3317 (void)SvUPGRADE(dstr, SVt_PVNV);
3319 (void)SvUPGRADE(dstr, stype);
3322 sflags = SvFLAGS(sstr);
3324 if (sflags & SVf_ROK) {
3325 if (dtype >= SVt_PV) {
3326 if (dtype == SVt_PVGV) {
3327 SV *sref = SvREFCNT_inc(SvRV(sstr));
3329 int intro = GvINTRO(dstr);
3331 #ifdef GV_SHARED_CHECK
3332 if (GvSHARED((GV*)dstr)) {
3333 Perl_croak(aTHX_ PL_no_modify);
3340 GvINTRO_off(dstr); /* one-shot flag */
3341 Newz(602,gp, 1, GP);
3342 GvGP(dstr) = gp_ref(gp);
3343 GvSV(dstr) = NEWSV(72,0);
3344 GvLINE(dstr) = CopLINE(PL_curcop);
3345 GvEGV(dstr) = (GV*)dstr;
3348 switch (SvTYPE(sref)) {
3351 SAVESPTR(GvAV(dstr));
3353 dref = (SV*)GvAV(dstr);
3354 GvAV(dstr) = (AV*)sref;
3355 if (!GvIMPORTED_AV(dstr)
3356 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3358 GvIMPORTED_AV_on(dstr);
3363 SAVESPTR(GvHV(dstr));
3365 dref = (SV*)GvHV(dstr);
3366 GvHV(dstr) = (HV*)sref;
3367 if (!GvIMPORTED_HV(dstr)
3368 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3370 GvIMPORTED_HV_on(dstr);
3375 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3376 SvREFCNT_dec(GvCV(dstr));
3377 GvCV(dstr) = Nullcv;
3378 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3379 PL_sub_generation++;
3381 SAVESPTR(GvCV(dstr));
3384 dref = (SV*)GvCV(dstr);
3385 if (GvCV(dstr) != (CV*)sref) {
3386 CV* cv = GvCV(dstr);
3388 if (!GvCVGEN((GV*)dstr) &&
3389 (CvROOT(cv) || CvXSUB(cv)))
3391 /* ahem, death to those who redefine
3392 * active sort subs */
3393 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3394 PL_sortcop == CvSTART(cv))
3396 "Can't redefine active sort subroutine %s",
3397 GvENAME((GV*)dstr));
3398 /* Redefining a sub - warning is mandatory if
3399 it was a const and its value changed. */
3400 if (ckWARN(WARN_REDEFINE)
3402 && (!CvCONST((CV*)sref)
3403 || sv_cmp(cv_const_sv(cv),
3404 cv_const_sv((CV*)sref)))))
3406 Perl_warner(aTHX_ WARN_REDEFINE,
3408 ? "Constant subroutine %s redefined"
3409 : "Subroutine %s redefined",
3410 GvENAME((GV*)dstr));
3413 cv_ckproto(cv, (GV*)dstr,
3414 SvPOK(sref) ? SvPVX(sref) : Nullch);
3416 GvCV(dstr) = (CV*)sref;
3417 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3418 GvASSUMECV_on(dstr);
3419 PL_sub_generation++;
3421 if (!GvIMPORTED_CV(dstr)
3422 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3424 GvIMPORTED_CV_on(dstr);
3429 SAVESPTR(GvIOp(dstr));
3431 dref = (SV*)GvIOp(dstr);
3432 GvIOp(dstr) = (IO*)sref;
3436 SAVESPTR(GvFORM(dstr));
3438 dref = (SV*)GvFORM(dstr);
3439 GvFORM(dstr) = (CV*)sref;
3443 SAVESPTR(GvSV(dstr));
3445 dref = (SV*)GvSV(dstr);
3447 if (!GvIMPORTED_SV(dstr)
3448 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3450 GvIMPORTED_SV_on(dstr);
3458 if (SvTAINTED(sstr))
3463 (void)SvOOK_off(dstr); /* backoff */
3465 Safefree(SvPVX(dstr));
3466 SvLEN(dstr)=SvCUR(dstr)=0;
3469 (void)SvOK_off(dstr);
3470 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3472 if (sflags & SVp_NOK) {
3474 /* Only set the public OK flag if the source has public OK. */
3475 if (sflags & SVf_NOK)
3476 SvFLAGS(dstr) |= SVf_NOK;
3477 SvNVX(dstr) = SvNVX(sstr);
3479 if (sflags & SVp_IOK) {
3480 (void)SvIOKp_on(dstr);
3481 if (sflags & SVf_IOK)
3482 SvFLAGS(dstr) |= SVf_IOK;
3483 if (sflags & SVf_IVisUV)
3485 SvIVX(dstr) = SvIVX(sstr);
3487 if (SvAMAGIC(sstr)) {
3491 else if (sflags & SVp_POK) {
3494 * Check to see if we can just swipe the string. If so, it's a
3495 * possible small lose on short strings, but a big win on long ones.
3496 * It might even be a win on short strings if SvPVX(dstr)
3497 * has to be allocated and SvPVX(sstr) has to be freed.
3500 if (SvTEMP(sstr) && /* slated for free anyway? */
3501 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3502 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3503 SvLEN(sstr) && /* and really is a string */
3504 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3506 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3508 SvFLAGS(dstr) &= ~SVf_OOK;
3509 Safefree(SvPVX(dstr) - SvIVX(dstr));
3511 else if (SvLEN(dstr))
3512 Safefree(SvPVX(dstr));
3514 (void)SvPOK_only(dstr);
3515 SvPV_set(dstr, SvPVX(sstr));
3516 SvLEN_set(dstr, SvLEN(sstr));
3517 SvCUR_set(dstr, SvCUR(sstr));
3520 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3521 SvPV_set(sstr, Nullch);
3526 else { /* have to copy actual string */
3527 STRLEN len = SvCUR(sstr);
3529 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3530 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3531 SvCUR_set(dstr, len);
3532 *SvEND(dstr) = '\0';
3533 (void)SvPOK_only(dstr);
3535 if (sflags & SVf_UTF8)
3538 if (sflags & SVp_NOK) {
3540 if (sflags & SVf_NOK)
3541 SvFLAGS(dstr) |= SVf_NOK;
3542 SvNVX(dstr) = SvNVX(sstr);
3544 if (sflags & SVp_IOK) {
3545 (void)SvIOKp_on(dstr);
3546 if (sflags & SVf_IOK)
3547 SvFLAGS(dstr) |= SVf_IOK;
3548 if (sflags & SVf_IVisUV)
3550 SvIVX(dstr) = SvIVX(sstr);
3553 else if (sflags & SVp_IOK) {
3554 if (sflags & SVf_IOK)
3555 (void)SvIOK_only(dstr);
3557 (void)SvOK_off(dstr);
3558 (void)SvIOKp_on(dstr);
3560 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3561 if (sflags & SVf_IVisUV)
3563 SvIVX(dstr) = SvIVX(sstr);
3564 if (sflags & SVp_NOK) {
3565 if (sflags & SVf_NOK)
3566 (void)SvNOK_on(dstr);
3568 (void)SvNOKp_on(dstr);
3569 SvNVX(dstr) = SvNVX(sstr);
3572 else if (sflags & SVp_NOK) {
3573 if (sflags & SVf_NOK)
3574 (void)SvNOK_only(dstr);
3576 (void)SvOK_off(dstr);
3579 SvNVX(dstr) = SvNVX(sstr);
3582 if (dtype == SVt_PVGV) {
3583 if (ckWARN(WARN_MISC))
3584 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3587 (void)SvOK_off(dstr);
3589 if (SvTAINTED(sstr))
3594 =for apidoc sv_setsv_mg
3596 Like C<sv_setsv>, but also handles 'set' magic.
3602 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3604 sv_setsv(dstr,sstr);
3609 =for apidoc sv_setpvn
3611 Copies a string into an SV. The C<len> parameter indicates the number of
3612 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3618 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3620 register char *dptr;
3622 SV_CHECK_THINKFIRST(sv);
3628 /* len is STRLEN which is unsigned, need to copy to signed */
3632 (void)SvUPGRADE(sv, SVt_PV);
3634 SvGROW(sv, len + 1);
3636 Move(ptr,dptr,len,char);
3639 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3644 =for apidoc sv_setpvn_mg
3646 Like C<sv_setpvn>, but also handles 'set' magic.
3652 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3654 sv_setpvn(sv,ptr,len);
3659 =for apidoc sv_setpv
3661 Copies a string into an SV. The string must be null-terminated. Does not
3662 handle 'set' magic. See C<sv_setpv_mg>.
3668 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3670 register STRLEN len;
3672 SV_CHECK_THINKFIRST(sv);
3678 (void)SvUPGRADE(sv, SVt_PV);
3680 SvGROW(sv, len + 1);
3681 Move(ptr,SvPVX(sv),len+1,char);
3683 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3688 =for apidoc sv_setpv_mg
3690 Like C<sv_setpv>, but also handles 'set' magic.
3696 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3703 =for apidoc sv_usepvn
3705 Tells an SV to use C<ptr> to find its string value. Normally the string is
3706 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3707 The C<ptr> should point to memory that was allocated by C<malloc>. The
3708 string length, C<len>, must be supplied. This function will realloc the
3709 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3710 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3711 See C<sv_usepvn_mg>.
3717 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3719 SV_CHECK_THINKFIRST(sv);
3720 (void)SvUPGRADE(sv, SVt_PV);
3725 (void)SvOOK_off(sv);
3726 if (SvPVX(sv) && SvLEN(sv))
3727 Safefree(SvPVX(sv));
3728 Renew(ptr, len+1, char);
3731 SvLEN_set(sv, len+1);
3733 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3738 =for apidoc sv_usepvn_mg
3740 Like C<sv_usepvn>, but also handles 'set' magic.
3746 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3748 sv_usepvn(sv,ptr,len);
3753 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3755 if (SvREADONLY(sv)) {
3757 char *pvx = SvPVX(sv);
3758 STRLEN len = SvCUR(sv);
3759 U32 hash = SvUVX(sv);
3760 SvGROW(sv, len + 1);
3761 Move(pvx,SvPVX(sv),len,char);
3765 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3767 else if (PL_curcop != &PL_compiling)
3768 Perl_croak(aTHX_ PL_no_modify);
3771 sv_unref_flags(sv, flags);
3772 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3777 Perl_sv_force_normal(pTHX_ register SV *sv)
3779 sv_force_normal_flags(sv, 0);
3785 Efficient removal of characters from the beginning of the string buffer.
3786 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3787 the string buffer. The C<ptr> becomes the first character of the adjusted
3794 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3798 register STRLEN delta;
3800 if (!ptr || !SvPOKp(sv))
3802 SV_CHECK_THINKFIRST(sv);
3803 if (SvTYPE(sv) < SVt_PVIV)
3804 sv_upgrade(sv,SVt_PVIV);
3807 if (!SvLEN(sv)) { /* make copy of shared string */
3808 char *pvx = SvPVX(sv);
3809 STRLEN len = SvCUR(sv);
3810 SvGROW(sv, len + 1);
3811 Move(pvx,SvPVX(sv),len,char);
3815 SvFLAGS(sv) |= SVf_OOK;
3817 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3818 delta = ptr - SvPVX(sv);
3826 =for apidoc sv_catpvn
3828 Concatenates the string onto the end of the string which is in the SV. The
3829 C<len> indicates number of bytes to copy. If the SV has the UTF8
3830 status set, then the bytes appended should be valid UTF8.
3831 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3837 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3842 junk = SvPV_force(sv, tlen);
3843 SvGROW(sv, tlen + len + 1);
3846 Move(ptr,SvPVX(sv)+tlen,len,char);
3849 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3854 =for apidoc sv_catpvn_mg
3856 Like C<sv_catpvn>, but also handles 'set' magic.
3862 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3864 sv_catpvn(sv,ptr,len);
3869 =for apidoc sv_catsv
3871 Concatenates the string from SV C<ssv> onto the end of the string in
3872 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3873 not 'set' magic. See C<sv_catsv_mg>.
3878 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3884 if ((spv = SvPV(ssv, slen))) {
3885 bool dutf8 = DO_UTF8(dsv);
3886 bool sutf8 = DO_UTF8(ssv);
3889 sv_catpvn(dsv,spv,slen);
3892 /* Not modifying source SV, so taking a temporary copy. */
3893 SV* csv = sv_2mortal(newSVsv(ssv));
3897 sv_utf8_upgrade(csv);
3898 cpv = SvPV(csv,clen);
3899 sv_catpvn(dsv,cpv,clen);
3902 sv_utf8_upgrade(dsv);
3903 sv_catpvn(dsv,spv,slen);
3904 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3911 =for apidoc sv_catsv_mg
3913 Like C<sv_catsv>, but also handles 'set' magic.
3919 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3926 =for apidoc sv_catpv
3928 Concatenates the string onto the end of the string which is in the SV.
3929 If the SV has the UTF8 status set, then the bytes appended should be
3930 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3935 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3937 register STRLEN len;
3943 junk = SvPV_force(sv, tlen);
3945 SvGROW(sv, tlen + len + 1);
3948 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3950 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3955 =for apidoc sv_catpv_mg
3957 Like C<sv_catpv>, but also handles 'set' magic.
3963 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3970 Perl_newSV(pTHX_ STRLEN len)
3976 sv_upgrade(sv, SVt_PV);
3977 SvGROW(sv, len + 1);
3982 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3985 =for apidoc sv_magic
3987 Adds magic to an SV.
3993 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3997 if (SvREADONLY(sv)) {
3998 if (PL_curcop != &PL_compiling
3999 /* XXX this used to be !strchr("gBf", how), which seems to
4000 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4001 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4002 * to the list of things to check - DAPM 19-May-01 */
4003 && how != PERL_MAGIC_regex_global
4004 && how != PERL_MAGIC_bm
4005 && how != PERL_MAGIC_fm
4006 && how != PERL_MAGIC_sv
4009 Perl_croak(aTHX_ PL_no_modify);
4012 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4013 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4014 if (how == PERL_MAGIC_taint)
4020 (void)SvUPGRADE(sv, SVt_PVMG);
4022 Newz(702,mg, 1, MAGIC);
4023 mg->mg_moremagic = SvMAGIC(sv);
4026 /* Some magic sontains a reference loop, where the sv and object refer to
4027 each other. To prevent a avoid a reference loop that would prevent such
4028 objects being freed, we look for such loops and if we find one we avoid
4029 incrementing the object refcount. */
4030 if (!obj || obj == sv ||
4031 how == PERL_MAGIC_arylen ||
4032 how == PERL_MAGIC_qr ||
4033 (SvTYPE(obj) == SVt_PVGV &&
4034 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4035 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4036 GvFORM(obj) == (CV*)sv)))
4041 mg->mg_obj = SvREFCNT_inc(obj);
4042 mg->mg_flags |= MGf_REFCOUNTED;
4045 mg->mg_len = namlen;
4048 mg->mg_ptr = savepvn(name, namlen);
4049 else if (namlen == HEf_SVKEY)
4050 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4055 mg->mg_virtual = &PL_vtbl_sv;
4057 case PERL_MAGIC_overload:
4058 mg->mg_virtual = &PL_vtbl_amagic;
4060 case PERL_MAGIC_overload_elem:
4061 mg->mg_virtual = &PL_vtbl_amagicelem;
4063 case PERL_MAGIC_overload_table:
4064 mg->mg_virtual = &PL_vtbl_ovrld;
4067 mg->mg_virtual = &PL_vtbl_bm;
4069 case PERL_MAGIC_regdata:
4070 mg->mg_virtual = &PL_vtbl_regdata;
4072 case PERL_MAGIC_regdatum:
4073 mg->mg_virtual = &PL_vtbl_regdatum;
4075 case PERL_MAGIC_env:
4076 mg->mg_virtual = &PL_vtbl_env;
4079 mg->mg_virtual = &PL_vtbl_fm;
4081 case PERL_MAGIC_envelem:
4082 mg->mg_virtual = &PL_vtbl_envelem;
4084 case PERL_MAGIC_regex_global:
4085 mg->mg_virtual = &PL_vtbl_mglob;
4087 case PERL_MAGIC_isa:
4088 mg->mg_virtual = &PL_vtbl_isa;
4090 case PERL_MAGIC_isaelem:
4091 mg->mg_virtual = &PL_vtbl_isaelem;
4093 case PERL_MAGIC_nkeys:
4094 mg->mg_virtual = &PL_vtbl_nkeys;
4096 case PERL_MAGIC_dbfile:
4100 case PERL_MAGIC_dbline:
4101 mg->mg_virtual = &PL_vtbl_dbline;
4104 case PERL_MAGIC_mutex:
4105 mg->mg_virtual = &PL_vtbl_mutex;
4107 #endif /* USE_THREADS */
4108 #ifdef USE_LOCALE_COLLATE
4109 case PERL_MAGIC_collxfrm:
4110 mg->mg_virtual = &PL_vtbl_collxfrm;
4112 #endif /* USE_LOCALE_COLLATE */
4113 case PERL_MAGIC_tied:
4114 mg->mg_virtual = &PL_vtbl_pack;
4116 case PERL_MAGIC_tiedelem:
4117 case PERL_MAGIC_tiedscalar:
4118 mg->mg_virtual = &PL_vtbl_packelem;
4121 mg->mg_virtual = &PL_vtbl_regexp;
4123 case PERL_MAGIC_sig:
4124 mg->mg_virtual = &PL_vtbl_sig;
4126 case PERL_MAGIC_sigelem:
4127 mg->mg_virtual = &PL_vtbl_sigelem;
4129 case PERL_MAGIC_taint:
4130 mg->mg_virtual = &PL_vtbl_taint;
4133 case PERL_MAGIC_uvar:
4134 mg->mg_virtual = &PL_vtbl_uvar;
4136 case PERL_MAGIC_vec:
4137 mg->mg_virtual = &PL_vtbl_vec;
4139 case PERL_MAGIC_substr:
4140 mg->mg_virtual = &PL_vtbl_substr;
4142 case PERL_MAGIC_defelem:
4143 mg->mg_virtual = &PL_vtbl_defelem;
4145 case PERL_MAGIC_glob:
4146 mg->mg_virtual = &PL_vtbl_glob;
4148 case PERL_MAGIC_arylen:
4149 mg->mg_virtual = &PL_vtbl_arylen;
4151 case PERL_MAGIC_pos:
4152 mg->mg_virtual = &PL_vtbl_pos;
4154 case PERL_MAGIC_backref:
4155 mg->mg_virtual = &PL_vtbl_backref;
4157 case PERL_MAGIC_ext:
4158 /* Reserved for use by extensions not perl internals. */
4159 /* Useful for attaching extension internal data to perl vars. */
4160 /* Note that multiple extensions may clash if magical scalars */
4161 /* etc holding private data from one are passed to another. */
4165 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4169 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4173 =for apidoc sv_unmagic
4175 Removes magic from an SV.
4181 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4185 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4188 for (mg = *mgp; mg; mg = *mgp) {
4189 if (mg->mg_type == type) {
4190 MGVTBL* vtbl = mg->mg_virtual;
4191 *mgp = mg->mg_moremagic;
4192 if (vtbl && vtbl->svt_free)
4193 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4194 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4195 if (mg->mg_len >= 0)
4196 Safefree(mg->mg_ptr);
4197 else if (mg->mg_len == HEf_SVKEY)
4198 SvREFCNT_dec((SV*)mg->mg_ptr);
4200 if (mg->mg_flags & MGf_REFCOUNTED)
4201 SvREFCNT_dec(mg->mg_obj);
4205 mgp = &mg->mg_moremagic;
4209 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4216 =for apidoc sv_rvweaken
4224 Perl_sv_rvweaken(pTHX_ SV *sv)
4227 if (!SvOK(sv)) /* let undefs pass */
4230 Perl_croak(aTHX_ "Can't weaken a nonreference");
4231 else if (SvWEAKREF(sv)) {
4232 if (ckWARN(WARN_MISC))
4233 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4237 sv_add_backref(tsv, sv);
4244 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4248 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4249 av = (AV*)mg->mg_obj;
4252 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4253 SvREFCNT_dec(av); /* for sv_magic */
4259 S_sv_del_backref(pTHX_ SV *sv)
4266 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4267 Perl_croak(aTHX_ "panic: del_backref");
4268 av = (AV *)mg->mg_obj;
4273 svp[i] = &PL_sv_undef; /* XXX */
4280 =for apidoc sv_insert
4282 Inserts a string at the specified offset/length within the SV. Similar to
4283 the Perl substr() function.
4289 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4293 register char *midend;
4294 register char *bigend;
4300 Perl_croak(aTHX_ "Can't modify non-existent substring");
4301 SvPV_force(bigstr, curlen);
4302 (void)SvPOK_only_UTF8(bigstr);
4303 if (offset + len > curlen) {
4304 SvGROW(bigstr, offset+len+1);
4305 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4306 SvCUR_set(bigstr, offset+len);
4310 i = littlelen - len;
4311 if (i > 0) { /* string might grow */
4312 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4313 mid = big + offset + len;
4314 midend = bigend = big + SvCUR(bigstr);
4317 while (midend > mid) /* shove everything down */
4318 *--bigend = *--midend;
4319 Move(little,big+offset,littlelen,char);
4325 Move(little,SvPVX(bigstr)+offset,len,char);
4330 big = SvPVX(bigstr);
4333 bigend = big + SvCUR(bigstr);
4335 if (midend > bigend)
4336 Perl_croak(aTHX_ "panic: sv_insert");
4338 if (mid - big > bigend - midend) { /* faster to shorten from end */
4340 Move(little, mid, littlelen,char);
4343 i = bigend - midend;
4345 Move(midend, mid, i,char);
4349 SvCUR_set(bigstr, mid - big);
4352 else if ((i = mid - big)) { /* faster from front */
4353 midend -= littlelen;
4355 sv_chop(bigstr,midend-i);
4360 Move(little, mid, littlelen,char);
4362 else if (littlelen) {
4363 midend -= littlelen;
4364 sv_chop(bigstr,midend);
4365 Move(little,midend,littlelen,char);
4368 sv_chop(bigstr,midend);
4374 =for apidoc sv_replace
4376 Make the first argument a copy of the second, then delete the original.
4382 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4384 U32 refcnt = SvREFCNT(sv);
4385 SV_CHECK_THINKFIRST(sv);
4386 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4387 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4388 if (SvMAGICAL(sv)) {
4392 sv_upgrade(nsv, SVt_PVMG);
4393 SvMAGIC(nsv) = SvMAGIC(sv);
4394 SvFLAGS(nsv) |= SvMAGICAL(sv);
4400 assert(!SvREFCNT(sv));
4401 StructCopy(nsv,sv,SV);
4402 SvREFCNT(sv) = refcnt;
4403 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4408 =for apidoc sv_clear
4410 Clear an SV, making it empty. Does not free the memory used by the SV
4417 Perl_sv_clear(pTHX_ register SV *sv)
4421 assert(SvREFCNT(sv) == 0);
4424 if (PL_defstash) { /* Still have a symbol table? */
4429 Zero(&tmpref, 1, SV);
4430 sv_upgrade(&tmpref, SVt_RV);
4432 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4433 SvREFCNT(&tmpref) = 1;
4436 stash = SvSTASH(sv);
4437 destructor = StashHANDLER(stash,DESTROY);
4440 PUSHSTACKi(PERLSI_DESTROY);
4441 SvRV(&tmpref) = SvREFCNT_inc(sv);
4446 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4452 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4454 del_XRV(SvANY(&tmpref));
4457 if (PL_in_clean_objs)
4458 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4460 /* DESTROY gave object new lease on life */
4466 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4467 SvOBJECT_off(sv); /* Curse the object. */
4468 if (SvTYPE(sv) != SVt_PVIO)
4469 --PL_sv_objcount; /* XXX Might want something more general */
4472 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4475 switch (SvTYPE(sv)) {
4478 IoIFP(sv) != PerlIO_stdin() &&
4479 IoIFP(sv) != PerlIO_stdout() &&
4480 IoIFP(sv) != PerlIO_stderr())
4482 io_close((IO*)sv, FALSE);
4484 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4485 PerlDir_close(IoDIRP(sv));
4486 IoDIRP(sv) = (DIR*)NULL;
4487 Safefree(IoTOP_NAME(sv));
4488 Safefree(IoFMT_NAME(sv));
4489 Safefree(IoBOTTOM_NAME(sv));
4504 SvREFCNT_dec(LvTARG(sv));
4508 Safefree(GvNAME(sv));
4509 /* cannot decrease stash refcount yet, as we might recursively delete
4510 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4511 of stash until current sv is completely gone.
4512 -- JohnPC, 27 Mar 1998 */
4513 stash = GvSTASH(sv);
4519 (void)SvOOK_off(sv);
4527 SvREFCNT_dec(SvRV(sv));
4529 else if (SvPVX(sv) && SvLEN(sv))
4530 Safefree(SvPVX(sv));
4531 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4532 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4544 switch (SvTYPE(sv)) {
4560 del_XPVIV(SvANY(sv));
4563 del_XPVNV(SvANY(sv));
4566 del_XPVMG(SvANY(sv));
4569 del_XPVLV(SvANY(sv));
4572 del_XPVAV(SvANY(sv));
4575 del_XPVHV(SvANY(sv));
4578 del_XPVCV(SvANY(sv));
4581 del_XPVGV(SvANY(sv));
4582 /* code duplication for increased performance. */
4583 SvFLAGS(sv) &= SVf_BREAK;
4584 SvFLAGS(sv) |= SVTYPEMASK;
4585 /* decrease refcount of the stash that owns this GV, if any */
4587 SvREFCNT_dec(stash);
4588 return; /* not break, SvFLAGS reset already happened */
4590 del_XPVBM(SvANY(sv));
4593 del_XPVFM(SvANY(sv));
4596 del_XPVIO(SvANY(sv));
4599 SvFLAGS(sv) &= SVf_BREAK;
4600 SvFLAGS(sv) |= SVTYPEMASK;
4604 Perl_sv_newref(pTHX_ SV *sv)
4607 ATOMIC_INC(SvREFCNT(sv));
4614 Free the memory used by an SV.
4620 Perl_sv_free(pTHX_ SV *sv)
4622 int refcount_is_zero;
4626 if (SvREFCNT(sv) == 0) {
4627 if (SvFLAGS(sv) & SVf_BREAK)
4629 if (PL_in_clean_all) /* All is fair */
4631 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4632 /* make sure SvREFCNT(sv)==0 happens very seldom */
4633 SvREFCNT(sv) = (~(U32)0)/2;
4636 if (ckWARN_d(WARN_INTERNAL))
4637 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4640 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4641 if (!refcount_is_zero)
4645 if (ckWARN_d(WARN_DEBUGGING))
4646 Perl_warner(aTHX_ WARN_DEBUGGING,
4647 "Attempt to free temp prematurely: SV 0x%"UVxf,
4652 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4653 /* make sure SvREFCNT(sv)==0 happens very seldom */
4654 SvREFCNT(sv) = (~(U32)0)/2;
4665 Returns the length of the string in the SV. See also C<SvCUR>.
4671 Perl_sv_len(pTHX_ register SV *sv)
4680 len = mg_length(sv);
4682 junk = SvPV(sv, len);
4687 =for apidoc sv_len_utf8
4689 Returns the number of characters in the string in an SV, counting wide
4690 UTF8 bytes as a single character.
4696 Perl_sv_len_utf8(pTHX_ register SV *sv)
4702 return mg_length(sv);
4706 U8 *s = (U8*)SvPV(sv, len);
4708 return Perl_utf8_length(aTHX_ s, s + len);
4713 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4718 I32 uoffset = *offsetp;
4724 start = s = (U8*)SvPV(sv, len);
4726 while (s < send && uoffset--)
4730 *offsetp = s - start;
4734 while (s < send && ulen--)
4744 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4753 s = (U8*)SvPV(sv, len);
4755 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4756 send = s + *offsetp;
4760 /* Call utf8n_to_uvchr() to validate the sequence */
4761 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4776 Returns a boolean indicating whether the strings in the two SVs are
4783 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4797 pv1 = SvPV(sv1, cur1);
4804 pv2 = SvPV(sv2, cur2);
4806 /* do not utf8ize the comparands as a side-effect */
4807 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4808 bool is_utf8 = TRUE;
4809 /* UTF-8ness differs */
4810 if (PL_hints & HINT_UTF8_DISTINCT)
4814 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4815 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4820 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4821 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4826 /* Downgrade not possible - cannot be eq */
4832 eq = memEQ(pv1, pv2, cur1);
4843 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4844 string in C<sv1> is less than, equal to, or greater than the string in
4851 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4856 bool pv1tmp = FALSE;
4857 bool pv2tmp = FALSE;
4864 pv1 = SvPV(sv1, cur1);
4871 pv2 = SvPV(sv2, cur2);
4873 /* do not utf8ize the comparands as a side-effect */
4874 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4875 if (PL_hints & HINT_UTF8_DISTINCT)
4876 return SvUTF8(sv1) ? 1 : -1;
4879 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4883 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4889 cmp = cur2 ? -1 : 0;
4893 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4896 cmp = retval < 0 ? -1 : 1;
4897 } else if (cur1 == cur2) {
4900 cmp = cur1 < cur2 ? -1 : 1;
4913 =for apidoc sv_cmp_locale
4915 Compares the strings in two SVs in a locale-aware manner. See
4922 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4924 #ifdef USE_LOCALE_COLLATE
4930 if (PL_collation_standard)
4934 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4936 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4938 if (!pv1 || !len1) {
4949 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4952 return retval < 0 ? -1 : 1;
4955 * When the result of collation is equality, that doesn't mean
4956 * that there are no differences -- some locales exclude some
4957 * characters from consideration. So to avoid false equalities,
4958 * we use the raw string as a tiebreaker.
4964 #endif /* USE_LOCALE_COLLATE */
4966 return sv_cmp(sv1, sv2);
4969 #ifdef USE_LOCALE_COLLATE
4971 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
4972 * scalar data of the variable transformed to such a format that
4973 * a normal memory comparison can be used to compare the data
4974 * according to the locale settings.
4977 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4981 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
4982 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4987 Safefree(mg->mg_ptr);
4989 if ((xf = mem_collxfrm(s, len, &xlen))) {
4990 if (SvREADONLY(sv)) {
4993 return xf + sizeof(PL_collation_ix);
4996 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
4997 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5010 if (mg && mg->mg_ptr) {
5012 return mg->mg_ptr + sizeof(PL_collation_ix);
5020 #endif /* USE_LOCALE_COLLATE */
5025 Get a line from the filehandle and store it into the SV, optionally
5026 appending to the currently-stored string.
5032 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5036 register STDCHAR rslast;
5037 register STDCHAR *bp;
5041 SV_CHECK_THINKFIRST(sv);
5042 (void)SvUPGRADE(sv, SVt_PV);
5046 if (RsSNARF(PL_rs)) {
5050 else if (RsRECORD(PL_rs)) {
5051 I32 recsize, bytesread;
5054 /* Grab the size of the record we're getting */
5055 recsize = SvIV(SvRV(PL_rs));
5056 (void)SvPOK_only(sv); /* Validate pointer */
5057 buffer = SvGROW(sv, recsize + 1);
5060 /* VMS wants read instead of fread, because fread doesn't respect */
5061 /* RMS record boundaries. This is not necessarily a good thing to be */
5062 /* doing, but we've got no other real choice */
5063 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5065 bytesread = PerlIO_read(fp, buffer, recsize);
5067 SvCUR_set(sv, bytesread);
5068 buffer[bytesread] = '\0';
5069 if (PerlIO_isutf8(fp))
5073 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5075 else if (RsPARA(PL_rs)) {
5080 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5081 if (PerlIO_isutf8(fp)) {
5082 rsptr = SvPVutf8(PL_rs, rslen);
5085 if (SvUTF8(PL_rs)) {
5086 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5087 Perl_croak(aTHX_ "Wide character in $/");
5090 rsptr = SvPV(PL_rs, rslen);
5094 rslast = rslen ? rsptr[rslen - 1] : '\0';
5096 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5097 do { /* to make sure file boundaries work right */
5100 i = PerlIO_getc(fp);
5104 PerlIO_ungetc(fp,i);
5110 /* See if we know enough about I/O mechanism to cheat it ! */
5112 /* This used to be #ifdef test - it is made run-time test for ease
5113 of abstracting out stdio interface. One call should be cheap
5114 enough here - and may even be a macro allowing compile
5118 if (PerlIO_fast_gets(fp)) {
5121 * We're going to steal some values from the stdio struct
5122 * and put EVERYTHING in the innermost loop into registers.
5124 register STDCHAR *ptr;
5128 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5129 /* An ungetc()d char is handled separately from the regular
5130 * buffer, so we getc() it back out and stuff it in the buffer.
5132 i = PerlIO_getc(fp);
5133 if (i == EOF) return 0;
5134 *(--((*fp)->_ptr)) = (unsigned char) i;
5138 /* Here is some breathtakingly efficient cheating */
5140 cnt = PerlIO_get_cnt(fp); /* get count into register */
5141 (void)SvPOK_only(sv); /* validate pointer */
5142 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5143 if (cnt > 80 && SvLEN(sv) > append) {
5144 shortbuffered = cnt - SvLEN(sv) + append + 1;
5145 cnt -= shortbuffered;
5149 /* remember that cnt can be negative */
5150 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5155 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5156 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5157 DEBUG_P(PerlIO_printf(Perl_debug_log,
5158 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5159 DEBUG_P(PerlIO_printf(Perl_debug_log,
5160 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5161 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5162 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5167 while (cnt > 0) { /* this | eat */
5169 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5170 goto thats_all_folks; /* screams | sed :-) */
5174 Copy(ptr, bp, cnt, char); /* this | eat */
5175 bp += cnt; /* screams | dust */
5176 ptr += cnt; /* louder | sed :-) */
5181 if (shortbuffered) { /* oh well, must extend */
5182 cnt = shortbuffered;
5184 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5186 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5187 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5191 DEBUG_P(PerlIO_printf(Perl_debug_log,
5192 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5193 PTR2UV(ptr),(long)cnt));
5194 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5195 DEBUG_P(PerlIO_printf(Perl_debug_log,
5196 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5197 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5198 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5199 /* This used to call 'filbuf' in stdio form, but as that behaves like
5200 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5201 another abstraction. */
5202 i = PerlIO_getc(fp); /* get more characters */
5203 DEBUG_P(PerlIO_printf(Perl_debug_log,
5204 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5205 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5206 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5207 cnt = PerlIO_get_cnt(fp);
5208 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5209 DEBUG_P(PerlIO_printf(Perl_debug_log,
5210 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5212 if (i == EOF) /* all done for ever? */
5213 goto thats_really_all_folks;
5215 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5217 SvGROW(sv, bpx + cnt + 2);
5218 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5220 *bp++ = i; /* store character from PerlIO_getc */
5222 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5223 goto thats_all_folks;
5227 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5228 memNE((char*)bp - rslen, rsptr, rslen))
5229 goto screamer; /* go back to the fray */
5230 thats_really_all_folks:
5232 cnt += shortbuffered;
5233 DEBUG_P(PerlIO_printf(Perl_debug_log,
5234 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5235 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5236 DEBUG_P(PerlIO_printf(Perl_debug_log,
5237 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5238 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5239 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5241 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5242 DEBUG_P(PerlIO_printf(Perl_debug_log,
5243 "Screamer: done, len=%ld, string=|%.*s|\n",
5244 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5249 /*The big, slow, and stupid way */
5252 /* Need to work around EPOC SDK features */
5253 /* On WINS: MS VC5 generates calls to _chkstk, */
5254 /* if a `large' stack frame is allocated */
5255 /* gcc on MARM does not generate calls like these */
5261 register STDCHAR *bpe = buf + sizeof(buf);
5263 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5264 ; /* keep reading */
5268 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5269 /* Accomodate broken VAXC compiler, which applies U8 cast to
5270 * both args of ?: operator, causing EOF to change into 255
5272 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5276 sv_catpvn(sv, (char *) buf, cnt);
5278 sv_setpvn(sv, (char *) buf, cnt);
5280 if (i != EOF && /* joy */
5282 SvCUR(sv) < rslen ||
5283 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5287 * If we're reading from a TTY and we get a short read,
5288 * indicating that the user hit his EOF character, we need
5289 * to notice it now, because if we try to read from the TTY
5290 * again, the EOF condition will disappear.
5292 * The comparison of cnt to sizeof(buf) is an optimization
5293 * that prevents unnecessary calls to feof().
5297 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5302 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5303 while (i != EOF) { /* to make sure file boundaries work right */
5304 i = PerlIO_getc(fp);
5306 PerlIO_ungetc(fp,i);
5312 if (PerlIO_isutf8(fp))
5317 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5324 Auto-increment of the value in the SV.
5330 Perl_sv_inc(pTHX_ register SV *sv)
5339 if (SvTHINKFIRST(sv)) {
5340 if (SvREADONLY(sv)) {
5341 if (PL_curcop != &PL_compiling)
5342 Perl_croak(aTHX_ PL_no_modify);
5346 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5348 i = PTR2IV(SvRV(sv));
5353 flags = SvFLAGS(sv);
5354 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5355 /* It's (privately or publicly) a float, but not tested as an
5356 integer, so test it to see. */
5358 flags = SvFLAGS(sv);
5360 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5361 /* It's publicly an integer, or privately an integer-not-float */
5364 if (SvUVX(sv) == UV_MAX)
5365 sv_setnv(sv, (NV)UV_MAX + 1.0);
5367 (void)SvIOK_only_UV(sv);
5370 if (SvIVX(sv) == IV_MAX)
5371 sv_setuv(sv, (UV)IV_MAX + 1);
5373 (void)SvIOK_only(sv);
5379 if (flags & SVp_NOK) {
5380 (void)SvNOK_only(sv);
5385 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5386 if ((flags & SVTYPEMASK) < SVt_PVIV)
5387 sv_upgrade(sv, SVt_IV);
5388 (void)SvIOK_only(sv);
5393 while (isALPHA(*d)) d++;
5394 while (isDIGIT(*d)) d++;
5396 #ifdef PERL_PRESERVE_IVUV
5397 /* Got to punt this an an integer if needs be, but we don't issue
5398 warnings. Probably ought to make the sv_iv_please() that does
5399 the conversion if possible, and silently. */
5400 I32 numtype = looks_like_number(sv);
5401 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5402 /* Need to try really hard to see if it's an integer.
5403 9.22337203685478e+18 is an integer.
5404 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5405 so $a="9.22337203685478e+18"; $a+0; $a++
5406 needs to be the same as $a="9.22337203685478e+18"; $a++
5413 /* sv_2iv *should* have made this an NV */
5414 if (flags & SVp_NOK) {
5415 (void)SvNOK_only(sv);
5419 /* I don't think we can get here. Maybe I should assert this
5420 And if we do get here I suspect that sv_setnv will croak. NWC
5422 #if defined(USE_LONG_DOUBLE)
5423 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",
5424 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5426 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5427 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5430 #endif /* PERL_PRESERVE_IVUV */
5431 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5435 while (d >= SvPVX(sv)) {
5443 /* MKS: The original code here died if letters weren't consecutive.
5444 * at least it didn't have to worry about non-C locales. The
5445 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5446 * arranged in order (although not consecutively) and that only
5447 * [A-Za-z] are accepted by isALPHA in the C locale.
5449 if (*d != 'z' && *d != 'Z') {
5450 do { ++*d; } while (!isALPHA(*d));
5453 *(d--) -= 'z' - 'a';
5458 *(d--) -= 'z' - 'a' + 1;
5462 /* oh,oh, the number grew */
5463 SvGROW(sv, SvCUR(sv) + 2);
5465 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5476 Auto-decrement of the value in the SV.
5482 Perl_sv_dec(pTHX_ register SV *sv)
5490 if (SvTHINKFIRST(sv)) {
5491 if (SvREADONLY(sv)) {
5492 if (PL_curcop != &PL_compiling)
5493 Perl_croak(aTHX_ PL_no_modify);
5497 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5499 i = PTR2IV(SvRV(sv));
5504 /* Unlike sv_inc we don't have to worry about string-never-numbers
5505 and keeping them magic. But we mustn't warn on punting */
5506 flags = SvFLAGS(sv);
5507 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5508 /* It's publicly an integer, or privately an integer-not-float */
5511 if (SvUVX(sv) == 0) {
5512 (void)SvIOK_only(sv);
5516 (void)SvIOK_only_UV(sv);
5520 if (SvIVX(sv) == IV_MIN)
5521 sv_setnv(sv, (NV)IV_MIN - 1.0);
5523 (void)SvIOK_only(sv);
5529 if (flags & SVp_NOK) {
5531 (void)SvNOK_only(sv);
5534 if (!(flags & SVp_POK)) {
5535 if ((flags & SVTYPEMASK) < SVt_PVNV)
5536 sv_upgrade(sv, SVt_NV);
5538 (void)SvNOK_only(sv);
5541 #ifdef PERL_PRESERVE_IVUV
5543 I32 numtype = looks_like_number(sv);
5544 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5545 /* Need to try really hard to see if it's an integer.
5546 9.22337203685478e+18 is an integer.
5547 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5548 so $a="9.22337203685478e+18"; $a+0; $a--
5549 needs to be the same as $a="9.22337203685478e+18"; $a--
5556 /* sv_2iv *should* have made this an NV */
5557 if (flags & SVp_NOK) {
5558 (void)SvNOK_only(sv);
5562 /* I don't think we can get here. Maybe I should assert this
5563 And if we do get here I suspect that sv_setnv will croak. NWC
5565 #if defined(USE_LONG_DOUBLE)
5566 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",
5567 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5569 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5570 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5574 #endif /* PERL_PRESERVE_IVUV */
5575 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5579 =for apidoc sv_mortalcopy
5581 Creates a new SV which is a copy of the original SV. The new SV is marked
5587 /* Make a string that will exist for the duration of the expression
5588 * evaluation. Actually, it may have to last longer than that, but
5589 * hopefully we won't free it until it has been assigned to a
5590 * permanent location. */
5593 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5598 sv_setsv(sv,oldstr);
5600 PL_tmps_stack[++PL_tmps_ix] = sv;
5606 =for apidoc sv_newmortal
5608 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5614 Perl_sv_newmortal(pTHX)
5619 SvFLAGS(sv) = SVs_TEMP;
5621 PL_tmps_stack[++PL_tmps_ix] = sv;
5626 =for apidoc sv_2mortal
5628 Marks an SV as mortal. The SV will be destroyed when the current context
5634 /* same thing without the copying */
5637 Perl_sv_2mortal(pTHX_ register SV *sv)
5641 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5644 PL_tmps_stack[++PL_tmps_ix] = sv;
5652 Creates a new SV and copies a string into it. The reference count for the
5653 SV is set to 1. If C<len> is zero, Perl will compute the length using
5654 strlen(). For efficiency, consider using C<newSVpvn> instead.
5660 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5667 sv_setpvn(sv,s,len);
5672 =for apidoc newSVpvn
5674 Creates a new SV and copies a string into it. The reference count for the
5675 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5676 string. You are responsible for ensuring that the source string is at least
5683 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5688 sv_setpvn(sv,s,len);
5693 =for apidoc newSVpvn_share
5695 Creates a new SV and populates it with a string from
5696 the string table. Turns on READONLY and FAKE.
5697 The idea here is that as string table is used for shared hash
5698 keys these strings will have SvPVX == HeKEY and hash lookup
5699 will avoid string compare.
5705 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5708 bool is_utf8 = FALSE;
5713 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5714 STRLEN tmplen = len;
5715 /* See the note in hv.c:hv_fetch() --jhi */
5716 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5720 PERL_HASH(hash, src, len);
5722 sv_upgrade(sv, SVt_PVIV);
5723 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5735 #if defined(PERL_IMPLICIT_CONTEXT)
5737 Perl_newSVpvf_nocontext(const char* pat, ...)
5742 va_start(args, pat);
5743 sv = vnewSVpvf(pat, &args);
5750 =for apidoc newSVpvf
5752 Creates a new SV an initialize it with the string formatted like
5759 Perl_newSVpvf(pTHX_ const char* pat, ...)
5763 va_start(args, pat);
5764 sv = vnewSVpvf(pat, &args);
5770 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5774 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5781 Creates a new SV and copies a floating point value into it.
5782 The reference count for the SV is set to 1.
5788 Perl_newSVnv(pTHX_ NV n)
5800 Creates a new SV and copies an integer into it. The reference count for the
5807 Perl_newSViv(pTHX_ IV i)
5819 Creates a new SV and copies an unsigned integer into it.
5820 The reference count for the SV is set to 1.
5826 Perl_newSVuv(pTHX_ UV u)
5836 =for apidoc newRV_noinc
5838 Creates an RV wrapper for an SV. The reference count for the original
5839 SV is B<not> incremented.
5845 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5850 sv_upgrade(sv, SVt_RV);
5857 /* newRV_inc is #defined to newRV in sv.h */
5859 Perl_newRV(pTHX_ SV *tmpRef)
5861 return newRV_noinc(SvREFCNT_inc(tmpRef));
5867 Creates a new SV which is an exact duplicate of the original SV.
5872 /* make an exact duplicate of old */
5875 Perl_newSVsv(pTHX_ register SV *old)
5881 if (SvTYPE(old) == SVTYPEMASK) {
5882 if (ckWARN_d(WARN_INTERNAL))
5883 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5898 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5906 char todo[PERL_UCHAR_MAX+1];
5911 if (!*s) { /* reset ?? searches */
5912 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5913 pm->op_pmdynflags &= ~PMdf_USED;
5918 /* reset variables */
5920 if (!HvARRAY(stash))
5923 Zero(todo, 256, char);
5925 i = (unsigned char)*s;
5929 max = (unsigned char)*s++;
5930 for ( ; i <= max; i++) {
5933 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5934 for (entry = HvARRAY(stash)[i];
5936 entry = HeNEXT(entry))
5938 if (!todo[(U8)*HeKEY(entry)])
5940 gv = (GV*)HeVAL(entry);
5942 if (SvTHINKFIRST(sv)) {
5943 if (!SvREADONLY(sv) && SvROK(sv))
5948 if (SvTYPE(sv) >= SVt_PV) {
5950 if (SvPVX(sv) != Nullch)
5957 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5959 #ifdef USE_ENVIRON_ARRAY
5961 environ[0] = Nullch;
5970 Perl_sv_2io(pTHX_ SV *sv)
5976 switch (SvTYPE(sv)) {
5984 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5988 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5990 return sv_2io(SvRV(sv));
5991 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5997 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6004 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6011 return *gvp = Nullgv, Nullcv;
6012 switch (SvTYPE(sv)) {
6031 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6032 tryAMAGICunDEREF(to_cv);
6035 if (SvTYPE(sv) == SVt_PVCV) {
6044 Perl_croak(aTHX_ "Not a subroutine reference");
6049 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6055 if (lref && !GvCVu(gv)) {
6058 tmpsv = NEWSV(704,0);
6059 gv_efullname3(tmpsv, gv, Nullch);
6060 /* XXX this is probably not what they think they're getting.
6061 * It has the same effect as "sub name;", i.e. just a forward
6063 newSUB(start_subparse(FALSE, 0),
6064 newSVOP(OP_CONST, 0, tmpsv),
6069 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6078 Returns true if the SV has a true value by Perl's rules.
6084 Perl_sv_true(pTHX_ register SV *sv)
6090 if ((tXpv = (XPV*)SvANY(sv)) &&
6091 (tXpv->xpv_cur > 1 ||
6092 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6099 return SvIVX(sv) != 0;
6102 return SvNVX(sv) != 0.0;
6104 return sv_2bool(sv);
6110 Perl_sv_iv(pTHX_ register SV *sv)
6114 return (IV)SvUVX(sv);
6121 Perl_sv_uv(pTHX_ register SV *sv)
6126 return (UV)SvIVX(sv);
6132 Perl_sv_nv(pTHX_ register SV *sv)
6140 Perl_sv_pv(pTHX_ SV *sv)
6147 return sv_2pv(sv, &n_a);
6151 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6157 return sv_2pv(sv, lp);
6161 =for apidoc sv_pvn_force
6163 Get a sensible string out of the SV somehow.
6169 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6173 if (SvTHINKFIRST(sv) && !SvROK(sv))
6174 sv_force_normal(sv);
6180 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6181 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6182 PL_op_name[PL_op->op_type]);
6186 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6191 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6192 SvGROW(sv, len + 1);
6193 Move(s,SvPVX(sv),len,char);
6198 SvPOK_on(sv); /* validate pointer */
6200 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6201 PTR2UV(sv),SvPVX(sv)));
6208 Perl_sv_pvbyte(pTHX_ SV *sv)
6210 sv_utf8_downgrade(sv,0);
6215 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6217 sv_utf8_downgrade(sv,0);
6218 return sv_pvn(sv,lp);
6222 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6224 sv_utf8_downgrade(sv,0);
6225 return sv_pvn_force(sv,lp);
6229 Perl_sv_pvutf8(pTHX_ SV *sv)
6231 sv_utf8_upgrade(sv);
6236 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6238 sv_utf8_upgrade(sv);
6239 return sv_pvn(sv,lp);
6243 =for apidoc sv_pvutf8n_force
6245 Get a sensible UTF8-encoded string out of the SV somehow. See
6252 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6254 sv_utf8_upgrade(sv);
6255 return sv_pvn_force(sv,lp);
6259 =for apidoc sv_reftype
6261 Returns a string describing what the SV is a reference to.
6267 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6269 if (ob && SvOBJECT(sv))
6270 return HvNAME(SvSTASH(sv));
6272 switch (SvTYPE(sv)) {
6286 case SVt_PVLV: return "LVALUE";
6287 case SVt_PVAV: return "ARRAY";
6288 case SVt_PVHV: return "HASH";
6289 case SVt_PVCV: return "CODE";
6290 case SVt_PVGV: return "GLOB";
6291 case SVt_PVFM: return "FORMAT";
6292 case SVt_PVIO: return "IO";
6293 default: return "UNKNOWN";
6299 =for apidoc sv_isobject
6301 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6302 object. If the SV is not an RV, or if the object is not blessed, then this
6309 Perl_sv_isobject(pTHX_ SV *sv)
6326 Returns a boolean indicating whether the SV is blessed into the specified
6327 class. This does not check for subtypes; use C<sv_derived_from> to verify
6328 an inheritance relationship.
6334 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6346 return strEQ(HvNAME(SvSTASH(sv)), name);
6352 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6353 it will be upgraded to one. If C<classname> is non-null then the new SV will
6354 be blessed in the specified package. The new SV is returned and its
6355 reference count is 1.
6361 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6367 SV_CHECK_THINKFIRST(rv);
6370 if (SvTYPE(rv) >= SVt_PVMG) {
6371 U32 refcnt = SvREFCNT(rv);
6375 SvREFCNT(rv) = refcnt;
6378 if (SvTYPE(rv) < SVt_RV)
6379 sv_upgrade(rv, SVt_RV);
6380 else if (SvTYPE(rv) > SVt_RV) {
6381 (void)SvOOK_off(rv);
6382 if (SvPVX(rv) && SvLEN(rv))
6383 Safefree(SvPVX(rv));
6393 HV* stash = gv_stashpv(classname, TRUE);
6394 (void)sv_bless(rv, stash);
6400 =for apidoc sv_setref_pv
6402 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6403 argument will be upgraded to an RV. That RV will be modified to point to
6404 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6405 into the SV. The C<classname> argument indicates the package for the
6406 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6407 will be returned and will have a reference count of 1.
6409 Do not use with other Perl types such as HV, AV, SV, CV, because those
6410 objects will become corrupted by the pointer copy process.
6412 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6418 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6421 sv_setsv(rv, &PL_sv_undef);
6425 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6430 =for apidoc sv_setref_iv
6432 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6433 argument will be upgraded to an RV. That RV will be modified to point to
6434 the new SV. The C<classname> argument indicates the package for the
6435 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6436 will be returned and will have a reference count of 1.
6442 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6444 sv_setiv(newSVrv(rv,classname), iv);
6449 =for apidoc sv_setref_uv
6451 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6452 argument will be upgraded to an RV. That RV will be modified to point to
6453 the new SV. The C<classname> argument indicates the package for the
6454 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6455 will be returned and will have a reference count of 1.
6461 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6463 sv_setuv(newSVrv(rv,classname), uv);
6468 =for apidoc sv_setref_nv
6470 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6471 argument will be upgraded to an RV. That RV will be modified to point to
6472 the new SV. The C<classname> argument indicates the package for the
6473 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6474 will be returned and will have a reference count of 1.
6480 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6482 sv_setnv(newSVrv(rv,classname), nv);
6487 =for apidoc sv_setref_pvn
6489 Copies a string into a new SV, optionally blessing the SV. The length of the
6490 string must be specified with C<n>. The C<rv> argument will be upgraded to
6491 an RV. That RV will be modified to point to the new SV. The C<classname>
6492 argument indicates the package for the blessing. Set C<classname> to
6493 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6494 a reference count of 1.
6496 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6502 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6504 sv_setpvn(newSVrv(rv,classname), pv, n);
6509 =for apidoc sv_bless
6511 Blesses an SV into a specified package. The SV must be an RV. The package
6512 must be designated by its stash (see C<gv_stashpv()>). The reference count
6513 of the SV is unaffected.
6519 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6523 Perl_croak(aTHX_ "Can't bless non-reference value");
6525 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6526 if (SvREADONLY(tmpRef))
6527 Perl_croak(aTHX_ PL_no_modify);
6528 if (SvOBJECT(tmpRef)) {
6529 if (SvTYPE(tmpRef) != SVt_PVIO)
6531 SvREFCNT_dec(SvSTASH(tmpRef));
6534 SvOBJECT_on(tmpRef);
6535 if (SvTYPE(tmpRef) != SVt_PVIO)
6537 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6538 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6549 S_sv_unglob(pTHX_ SV *sv)
6553 assert(SvTYPE(sv) == SVt_PVGV);
6558 SvREFCNT_dec(GvSTASH(sv));
6559 GvSTASH(sv) = Nullhv;
6561 sv_unmagic(sv, PERL_MAGIC_glob);
6562 Safefree(GvNAME(sv));
6565 /* need to keep SvANY(sv) in the right arena */
6566 xpvmg = new_XPVMG();
6567 StructCopy(SvANY(sv), xpvmg, XPVMG);
6568 del_XPVGV(SvANY(sv));
6571 SvFLAGS(sv) &= ~SVTYPEMASK;
6572 SvFLAGS(sv) |= SVt_PVMG;
6576 =for apidoc sv_unref_flags
6578 Unsets the RV status of the SV, and decrements the reference count of
6579 whatever was being referenced by the RV. This can almost be thought of
6580 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6581 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6582 (otherwise the decrementing is conditional on the reference count being
6583 different from one or the reference being a readonly SV).
6590 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6594 if (SvWEAKREF(sv)) {
6602 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6604 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6605 sv_2mortal(rv); /* Schedule for freeing later */
6609 =for apidoc sv_unref
6611 Unsets the RV status of the SV, and decrements the reference count of
6612 whatever was being referenced by the RV. This can almost be thought of
6613 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6614 being zero. See C<SvROK_off>.
6620 Perl_sv_unref(pTHX_ SV *sv)
6622 sv_unref_flags(sv, 0);
6626 Perl_sv_taint(pTHX_ SV *sv)
6628 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6632 Perl_sv_untaint(pTHX_ SV *sv)
6634 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6635 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6642 Perl_sv_tainted(pTHX_ SV *sv)
6644 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6645 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6646 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6653 =for apidoc sv_setpviv
6655 Copies an integer into the given SV, also updating its string value.
6656 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6662 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6664 char buf[TYPE_CHARS(UV)];
6666 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6668 sv_setpvn(sv, ptr, ebuf - ptr);
6673 =for apidoc sv_setpviv_mg
6675 Like C<sv_setpviv>, but also handles 'set' magic.
6681 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6683 char buf[TYPE_CHARS(UV)];
6685 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6687 sv_setpvn(sv, ptr, ebuf - ptr);
6691 #if defined(PERL_IMPLICIT_CONTEXT)
6693 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6697 va_start(args, pat);
6698 sv_vsetpvf(sv, pat, &args);
6704 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6708 va_start(args, pat);
6709 sv_vsetpvf_mg(sv, pat, &args);
6715 =for apidoc sv_setpvf
6717 Processes its arguments like C<sprintf> and sets an SV to the formatted
6718 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6724 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6727 va_start(args, pat);
6728 sv_vsetpvf(sv, pat, &args);
6733 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6735 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6739 =for apidoc sv_setpvf_mg
6741 Like C<sv_setpvf>, but also handles 'set' magic.
6747 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6750 va_start(args, pat);
6751 sv_vsetpvf_mg(sv, pat, &args);
6756 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6758 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6762 #if defined(PERL_IMPLICIT_CONTEXT)
6764 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6768 va_start(args, pat);
6769 sv_vcatpvf(sv, pat, &args);
6774 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6778 va_start(args, pat);
6779 sv_vcatpvf_mg(sv, pat, &args);
6785 =for apidoc sv_catpvf
6787 Processes its arguments like C<sprintf> and appends the formatted
6788 output to an SV. If the appended data contains "wide" characters
6789 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6790 and characters >255 formatted with %c), the original SV might get
6791 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6792 C<SvSETMAGIC()> must typically be called after calling this function
6793 to handle 'set' magic.
6798 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6801 va_start(args, pat);
6802 sv_vcatpvf(sv, pat, &args);
6807 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6809 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6813 =for apidoc sv_catpvf_mg
6815 Like C<sv_catpvf>, but also handles 'set' magic.
6821 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6824 va_start(args, pat);
6825 sv_vcatpvf_mg(sv, pat, &args);
6830 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6832 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6837 =for apidoc sv_vsetpvfn
6839 Works like C<vcatpvfn> but copies the text into the SV instead of
6846 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6848 sv_setpvn(sv, "", 0);
6849 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6853 S_expect_number(pTHX_ char** pattern)
6856 switch (**pattern) {
6857 case '1': case '2': case '3':
6858 case '4': case '5': case '6':
6859 case '7': case '8': case '9':
6860 while (isDIGIT(**pattern))
6861 var = var * 10 + (*(*pattern)++ - '0');
6865 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6868 =for apidoc sv_vcatpvfn
6870 Processes its arguments like C<vsprintf> and appends the formatted output
6871 to an SV. Uses an array of SVs if the C style variable argument list is
6872 missing (NULL). When running with taint checks enabled, indicates via
6873 C<maybe_tainted> if results are untrustworthy (often due to the use of
6880 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6887 static char nullstr[] = "(null)";
6890 /* no matter what, this is a string now */
6891 (void)SvPV_force(sv, origlen);
6893 /* special-case "", "%s", and "%_" */
6896 if (patlen == 2 && pat[0] == '%') {
6900 char *s = va_arg(*args, char*);
6901 sv_catpv(sv, s ? s : nullstr);
6903 else if (svix < svmax) {
6904 sv_catsv(sv, *svargs);
6905 if (DO_UTF8(*svargs))
6911 argsv = va_arg(*args, SV*);
6912 sv_catsv(sv, argsv);
6917 /* See comment on '_' below */
6922 patend = (char*)pat + patlen;
6923 for (p = (char*)pat; p < patend; p = q) {
6926 bool vectorize = FALSE;
6927 bool vectorarg = FALSE;
6928 bool vec_utf = FALSE;
6934 bool has_precis = FALSE;
6936 bool is_utf = FALSE;
6939 U8 utf8buf[UTF8_MAXLEN+1];
6940 STRLEN esignlen = 0;
6942 char *eptr = Nullch;
6944 /* Times 4: a decimal digit takes more than 3 binary digits.
6945 * NV_DIG: mantissa takes than many decimal digits.
6946 * Plus 32: Playing safe. */
6947 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6948 /* large enough for "%#.#f" --chip */
6949 /* what about long double NVs? --jhi */
6952 U8 *vecstr = Null(U8*);
6964 STRLEN dotstrlen = 1;
6965 I32 efix = 0; /* explicit format parameter index */
6966 I32 ewix = 0; /* explicit width index */
6967 I32 epix = 0; /* explicit precision index */
6968 I32 evix = 0; /* explicit vector index */
6969 bool asterisk = FALSE;
6971 /* echo everything up to the next format specification */
6972 for (q = p; q < patend && *q != '%'; ++q) ;
6974 sv_catpvn(sv, p, q - p);
6981 We allow format specification elements in this order:
6982 \d+\$ explicit format parameter index
6984 \*?(\d+\$)?v vector with optional (optionally specified) arg
6985 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6986 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6988 [%bcdefginopsux_DFOUX] format (mandatory)
6990 if (EXPECT_NUMBER(q, width)) {
7031 if (EXPECT_NUMBER(q, ewix))
7040 if ((vectorarg = asterisk)) {
7050 EXPECT_NUMBER(q, width);
7055 vecsv = va_arg(*args, SV*);
7057 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7058 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7059 dotstr = SvPVx(vecsv, dotstrlen);
7064 vecsv = va_arg(*args, SV*);
7065 vecstr = (U8*)SvPVx(vecsv,veclen);
7066 vec_utf = DO_UTF8(vecsv);
7068 else if (efix ? efix <= svmax : svix < svmax) {
7069 vecsv = svargs[efix ? efix-1 : svix++];
7070 vecstr = (U8*)SvPVx(vecsv,veclen);
7071 vec_utf = DO_UTF8(vecsv);
7081 i = va_arg(*args, int);
7083 i = (ewix ? ewix <= svmax : svix < svmax) ?
7084 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7086 width = (i < 0) ? -i : i;
7096 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7099 i = va_arg(*args, int);
7101 i = (ewix ? ewix <= svmax : svix < svmax)
7102 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7103 precis = (i < 0) ? 0 : i;
7108 precis = precis * 10 + (*q++ - '0');
7116 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7127 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7128 if (*(q + 1) == 'l') { /* lld, llf */
7151 argsv = (efix ? efix <= svmax : svix < svmax) ?
7152 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7159 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7161 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7163 eptr = (char*)utf8buf;
7164 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7176 eptr = va_arg(*args, char*);
7178 #ifdef MACOS_TRADITIONAL
7179 /* On MacOS, %#s format is used for Pascal strings */
7184 elen = strlen(eptr);
7187 elen = sizeof nullstr - 1;
7191 eptr = SvPVx(argsv, elen);
7192 if (DO_UTF8(argsv)) {
7193 if (has_precis && precis < elen) {
7195 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7198 if (width) { /* fudge width (can't fudge elen) */
7199 width += elen - sv_len_utf8(argsv);
7208 * The "%_" hack might have to be changed someday,
7209 * if ISO or ANSI decide to use '_' for something.
7210 * So we keep it hidden from users' code.
7214 argsv = va_arg(*args, SV*);
7215 eptr = SvPVx(argsv, elen);
7221 if (has_precis && elen > precis)
7230 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7248 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7258 case 'h': iv = (short)va_arg(*args, int); break;
7259 default: iv = va_arg(*args, int); break;
7260 case 'l': iv = va_arg(*args, long); break;
7261 case 'V': iv = va_arg(*args, IV); break;
7263 case 'q': iv = va_arg(*args, Quad_t); break;
7270 case 'h': iv = (short)iv; break;
7272 case 'l': iv = (long)iv; break;
7275 case 'q': iv = (Quad_t)iv; break;
7282 esignbuf[esignlen++] = plus;
7286 esignbuf[esignlen++] = '-';
7328 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7338 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7339 default: uv = va_arg(*args, unsigned); break;
7340 case 'l': uv = va_arg(*args, unsigned long); break;
7341 case 'V': uv = va_arg(*args, UV); break;
7343 case 'q': uv = va_arg(*args, Quad_t); break;
7350 case 'h': uv = (unsigned short)uv; break;
7352 case 'l': uv = (unsigned long)uv; break;
7355 case 'q': uv = (Quad_t)uv; break;
7361 eptr = ebuf + sizeof ebuf;
7367 p = (char*)((c == 'X')
7368 ? "0123456789ABCDEF" : "0123456789abcdef");
7374 esignbuf[esignlen++] = '0';
7375 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7381 *--eptr = '0' + dig;
7383 if (alt && *eptr != '0')
7389 *--eptr = '0' + dig;
7392 esignbuf[esignlen++] = '0';
7393 esignbuf[esignlen++] = 'b';
7396 default: /* it had better be ten or less */
7397 #if defined(PERL_Y2KWARN)
7398 if (ckWARN(WARN_Y2K)) {
7400 char *s = SvPV(sv,n);
7401 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7402 && (n == 2 || !isDIGIT(s[n-3])))
7404 Perl_warner(aTHX_ WARN_Y2K,
7405 "Possible Y2K bug: %%%c %s",
7406 c, "format string following '19'");
7412 *--eptr = '0' + dig;
7413 } while (uv /= base);
7416 elen = (ebuf + sizeof ebuf) - eptr;
7419 zeros = precis - elen;
7420 else if (precis == 0 && elen == 1 && *eptr == '0')
7425 /* FLOATING POINT */
7428 c = 'f'; /* maybe %F isn't supported here */
7434 /* This is evil, but floating point is even more evil */
7437 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7440 if (c != 'e' && c != 'E') {
7442 (void)Perl_frexp(nv, &i);
7443 if (i == PERL_INT_MIN)
7444 Perl_die(aTHX_ "panic: frexp");
7446 need = BIT_DIGITS(i);
7448 need += has_precis ? precis : 6; /* known default */
7452 need += 20; /* fudge factor */
7453 if (PL_efloatsize < need) {
7454 Safefree(PL_efloatbuf);
7455 PL_efloatsize = need + 20; /* more fudge */
7456 New(906, PL_efloatbuf, PL_efloatsize, char);
7457 PL_efloatbuf[0] = '\0';
7460 eptr = ebuf + sizeof ebuf;
7463 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7465 /* Copy the one or more characters in a long double
7466 * format before the 'base' ([efgEFG]) character to
7467 * the format string. */
7468 static char const prifldbl[] = PERL_PRIfldbl;
7469 char const *p = prifldbl + sizeof(prifldbl) - 3;
7470 while (p >= prifldbl) { *--eptr = *p--; }
7475 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7480 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7492 /* No taint. Otherwise we are in the strange situation
7493 * where printf() taints but print($float) doesn't.
7495 (void)sprintf(PL_efloatbuf, eptr, nv);
7497 eptr = PL_efloatbuf;
7498 elen = strlen(PL_efloatbuf);
7505 i = SvCUR(sv) - origlen;
7508 case 'h': *(va_arg(*args, short*)) = i; break;
7509 default: *(va_arg(*args, int*)) = i; break;
7510 case 'l': *(va_arg(*args, long*)) = i; break;
7511 case 'V': *(va_arg(*args, IV*)) = i; break;
7513 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7518 sv_setuv_mg(argsv, (UV)i);
7519 continue; /* not "break" */
7526 if (!args && ckWARN(WARN_PRINTF) &&
7527 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7528 SV *msg = sv_newmortal();
7529 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7530 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7533 Perl_sv_catpvf(aTHX_ msg,
7534 "\"%%%c\"", c & 0xFF);
7536 Perl_sv_catpvf(aTHX_ msg,
7537 "\"%%\\%03"UVof"\"",
7540 sv_catpv(msg, "end of string");
7541 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7544 /* output mangled stuff ... */
7550 /* ... right here, because formatting flags should not apply */
7551 SvGROW(sv, SvCUR(sv) + elen + 1);
7553 Copy(eptr, p, elen, char);
7556 SvCUR(sv) = p - SvPVX(sv);
7557 continue; /* not "break" */
7560 have = esignlen + zeros + elen;
7561 need = (have > width ? have : width);
7564 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7566 if (esignlen && fill == '0') {
7567 for (i = 0; i < esignlen; i++)
7571 memset(p, fill, gap);
7574 if (esignlen && fill != '0') {
7575 for (i = 0; i < esignlen; i++)
7579 for (i = zeros; i; i--)
7583 Copy(eptr, p, elen, char);
7587 memset(p, ' ', gap);
7592 Copy(dotstr, p, dotstrlen, char);
7596 vectorize = FALSE; /* done iterating over vecstr */
7601 SvCUR(sv) = p - SvPVX(sv);
7609 #if defined(USE_ITHREADS)
7611 #if defined(USE_THREADS)
7612 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7615 #ifndef GpREFCNT_inc
7616 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7620 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7621 #define av_dup(s) (AV*)sv_dup((SV*)s)
7622 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7623 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7624 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7625 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7626 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7627 #define io_dup(s) (IO*)sv_dup((SV*)s)
7628 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7629 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7630 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7631 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7632 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7635 Perl_re_dup(pTHX_ REGEXP *r)
7637 /* XXX fix when pmop->op_pmregexp becomes shared */
7638 return ReREFCNT_inc(r);
7642 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7646 return (PerlIO*)NULL;
7648 /* look for it in the table first */
7649 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7653 /* create anew and remember what it is */
7654 ret = PerlIO_fdupopen(aTHX_ fp);
7655 ptr_table_store(PL_ptr_table, fp, ret);
7660 Perl_dirp_dup(pTHX_ DIR *dp)
7669 Perl_gp_dup(pTHX_ GP *gp)
7674 /* look for it in the table first */
7675 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7679 /* create anew and remember what it is */
7680 Newz(0, ret, 1, GP);
7681 ptr_table_store(PL_ptr_table, gp, ret);
7684 ret->gp_refcnt = 0; /* must be before any other dups! */
7685 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7686 ret->gp_io = io_dup_inc(gp->gp_io);
7687 ret->gp_form = cv_dup_inc(gp->gp_form);
7688 ret->gp_av = av_dup_inc(gp->gp_av);
7689 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7690 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7691 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7692 ret->gp_cvgen = gp->gp_cvgen;
7693 ret->gp_flags = gp->gp_flags;
7694 ret->gp_line = gp->gp_line;
7695 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7700 Perl_mg_dup(pTHX_ MAGIC *mg)
7702 MAGIC *mgprev = (MAGIC*)NULL;
7705 return (MAGIC*)NULL;
7706 /* look for it in the table first */
7707 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7711 for (; mg; mg = mg->mg_moremagic) {
7713 Newz(0, nmg, 1, MAGIC);
7715 mgprev->mg_moremagic = nmg;
7718 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7719 nmg->mg_private = mg->mg_private;
7720 nmg->mg_type = mg->mg_type;
7721 nmg->mg_flags = mg->mg_flags;
7722 if (mg->mg_type == PERL_MAGIC_qr) {
7723 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7726 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7727 ? sv_dup_inc(mg->mg_obj)
7728 : sv_dup(mg->mg_obj);
7730 nmg->mg_len = mg->mg_len;
7731 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7732 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7733 if (mg->mg_len >= 0) {
7734 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7735 if (mg->mg_type == PERL_MAGIC_overload_table &&
7736 AMT_AMAGIC((AMT*)mg->mg_ptr))
7738 AMT *amtp = (AMT*)mg->mg_ptr;
7739 AMT *namtp = (AMT*)nmg->mg_ptr;
7741 for (i = 1; i < NofAMmeth; i++) {
7742 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7746 else if (mg->mg_len == HEf_SVKEY)
7747 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7755 Perl_ptr_table_new(pTHX)
7758 Newz(0, tbl, 1, PTR_TBL_t);
7761 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7766 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7768 PTR_TBL_ENT_t *tblent;
7769 UV hash = PTR2UV(sv);
7771 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7772 for (; tblent; tblent = tblent->next) {
7773 if (tblent->oldval == sv)
7774 return tblent->newval;
7780 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7782 PTR_TBL_ENT_t *tblent, **otblent;
7783 /* XXX this may be pessimal on platforms where pointers aren't good
7784 * hash values e.g. if they grow faster in the most significant
7786 UV hash = PTR2UV(oldv);
7790 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7791 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7792 if (tblent->oldval == oldv) {
7793 tblent->newval = newv;
7798 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7799 tblent->oldval = oldv;
7800 tblent->newval = newv;
7801 tblent->next = *otblent;
7804 if (i && tbl->tbl_items > tbl->tbl_max)
7805 ptr_table_split(tbl);
7809 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7811 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7812 UV oldsize = tbl->tbl_max + 1;
7813 UV newsize = oldsize * 2;
7816 Renew(ary, newsize, PTR_TBL_ENT_t*);
7817 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7818 tbl->tbl_max = --newsize;
7820 for (i=0; i < oldsize; i++, ary++) {
7821 PTR_TBL_ENT_t **curentp, **entp, *ent;
7824 curentp = ary + oldsize;
7825 for (entp = ary, ent = *ary; ent; ent = *entp) {
7826 if ((newsize & PTR2UV(ent->oldval)) != i) {
7828 ent->next = *curentp;
7839 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7841 register PTR_TBL_ENT_t **array;
7842 register PTR_TBL_ENT_t *entry;
7843 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7847 if (!tbl || !tbl->tbl_items) {
7851 array = tbl->tbl_ary;
7858 entry = entry->next;
7862 if (++riter > max) {
7865 entry = array[riter];
7873 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7878 ptr_table_clear(tbl);
7879 Safefree(tbl->tbl_ary);
7888 S_gv_share(pTHX_ SV *sstr)
7891 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7893 if (GvIO(gv) || GvFORM(gv)) {
7894 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7896 else if (!GvCV(gv)) {
7900 /* CvPADLISTs cannot be shared */
7901 if (!CvXSUB(GvCV(gv))) {
7906 if (!GvSHARED(gv)) {
7908 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7909 HvNAME(GvSTASH(gv)), GvNAME(gv));
7915 * write attempts will die with
7916 * "Modification of a read-only value attempted"
7922 SvREADONLY_on(GvSV(gv));
7929 SvREADONLY_on(GvAV(gv));
7936 SvREADONLY_on(GvAV(gv));
7939 return sstr; /* he_dup() will SvREFCNT_inc() */
7943 Perl_sv_dup(pTHX_ SV *sstr)
7947 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7949 /* look for it in the table first */
7950 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7954 /* create anew and remember what it is */
7956 ptr_table_store(PL_ptr_table, sstr, dstr);
7959 SvFLAGS(dstr) = SvFLAGS(sstr);
7960 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7961 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7964 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7965 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7966 PL_watch_pvx, SvPVX(sstr));
7969 switch (SvTYPE(sstr)) {
7974 SvANY(dstr) = new_XIV();
7975 SvIVX(dstr) = SvIVX(sstr);
7978 SvANY(dstr) = new_XNV();
7979 SvNVX(dstr) = SvNVX(sstr);
7982 SvANY(dstr) = new_XRV();
7983 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7984 ? sv_dup_inc(SvRV(sstr))
7985 : sv_dup(SvRV(sstr));
7988 SvANY(dstr) = new_XPV();
7989 SvCUR(dstr) = SvCUR(sstr);
7990 SvLEN(dstr) = SvLEN(sstr);
7992 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7993 ? sv_dup_inc(SvRV(sstr))
7994 : sv_dup(SvRV(sstr));
7995 else if (SvPVX(sstr) && SvLEN(sstr))
7996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8001 SvANY(dstr) = new_XPVIV();
8002 SvCUR(dstr) = SvCUR(sstr);
8003 SvLEN(dstr) = SvLEN(sstr);
8004 SvIVX(dstr) = SvIVX(sstr);
8006 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8007 ? sv_dup_inc(SvRV(sstr))
8008 : sv_dup(SvRV(sstr));
8009 else if (SvPVX(sstr) && SvLEN(sstr))
8010 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8012 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8015 SvANY(dstr) = new_XPVNV();
8016 SvCUR(dstr) = SvCUR(sstr);
8017 SvLEN(dstr) = SvLEN(sstr);
8018 SvIVX(dstr) = SvIVX(sstr);
8019 SvNVX(dstr) = SvNVX(sstr);
8021 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8022 ? sv_dup_inc(SvRV(sstr))
8023 : sv_dup(SvRV(sstr));
8024 else if (SvPVX(sstr) && SvLEN(sstr))
8025 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8027 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8030 SvANY(dstr) = new_XPVMG();
8031 SvCUR(dstr) = SvCUR(sstr);
8032 SvLEN(dstr) = SvLEN(sstr);
8033 SvIVX(dstr) = SvIVX(sstr);
8034 SvNVX(dstr) = SvNVX(sstr);
8035 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8036 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8038 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8039 ? sv_dup_inc(SvRV(sstr))
8040 : sv_dup(SvRV(sstr));
8041 else if (SvPVX(sstr) && SvLEN(sstr))
8042 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8044 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8047 SvANY(dstr) = new_XPVBM();
8048 SvCUR(dstr) = SvCUR(sstr);
8049 SvLEN(dstr) = SvLEN(sstr);
8050 SvIVX(dstr) = SvIVX(sstr);
8051 SvNVX(dstr) = SvNVX(sstr);
8052 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8053 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8055 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8056 ? sv_dup_inc(SvRV(sstr))
8057 : sv_dup(SvRV(sstr));
8058 else if (SvPVX(sstr) && SvLEN(sstr))
8059 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8061 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8062 BmRARE(dstr) = BmRARE(sstr);
8063 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8064 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8067 SvANY(dstr) = new_XPVLV();
8068 SvCUR(dstr) = SvCUR(sstr);
8069 SvLEN(dstr) = SvLEN(sstr);
8070 SvIVX(dstr) = SvIVX(sstr);
8071 SvNVX(dstr) = SvNVX(sstr);
8072 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8073 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8075 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8076 ? sv_dup_inc(SvRV(sstr))
8077 : sv_dup(SvRV(sstr));
8078 else if (SvPVX(sstr) && SvLEN(sstr))
8079 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8081 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8082 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8083 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8084 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8085 LvTYPE(dstr) = LvTYPE(sstr);
8088 if (GvSHARED((GV*)sstr)) {
8090 if ((share = gv_share(sstr))) {
8094 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8095 HvNAME(GvSTASH(share)), GvNAME(share));
8100 SvANY(dstr) = new_XPVGV();
8101 SvCUR(dstr) = SvCUR(sstr);
8102 SvLEN(dstr) = SvLEN(sstr);
8103 SvIVX(dstr) = SvIVX(sstr);
8104 SvNVX(dstr) = SvNVX(sstr);
8105 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8106 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8108 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8109 ? sv_dup_inc(SvRV(sstr))
8110 : sv_dup(SvRV(sstr));
8111 else if (SvPVX(sstr) && SvLEN(sstr))
8112 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8114 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8115 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8116 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8117 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8118 GvFLAGS(dstr) = GvFLAGS(sstr);
8119 GvGP(dstr) = gp_dup(GvGP(sstr));
8120 (void)GpREFCNT_inc(GvGP(dstr));
8123 SvANY(dstr) = new_XPVIO();
8124 SvCUR(dstr) = SvCUR(sstr);
8125 SvLEN(dstr) = SvLEN(sstr);
8126 SvIVX(dstr) = SvIVX(sstr);
8127 SvNVX(dstr) = SvNVX(sstr);
8128 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8129 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8131 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8132 ? sv_dup_inc(SvRV(sstr))
8133 : sv_dup(SvRV(sstr));
8134 else if (SvPVX(sstr) && SvLEN(sstr))
8135 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8137 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8138 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8139 if (IoOFP(sstr) == IoIFP(sstr))
8140 IoOFP(dstr) = IoIFP(dstr);
8142 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8143 /* PL_rsfp_filters entries have fake IoDIRP() */
8144 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8145 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8147 IoDIRP(dstr) = IoDIRP(sstr);
8148 IoLINES(dstr) = IoLINES(sstr);
8149 IoPAGE(dstr) = IoPAGE(sstr);
8150 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8151 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8152 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8153 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8154 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8155 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8156 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8157 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8158 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8159 IoTYPE(dstr) = IoTYPE(sstr);
8160 IoFLAGS(dstr) = IoFLAGS(sstr);
8163 SvANY(dstr) = new_XPVAV();
8164 SvCUR(dstr) = SvCUR(sstr);
8165 SvLEN(dstr) = SvLEN(sstr);
8166 SvIVX(dstr) = SvIVX(sstr);
8167 SvNVX(dstr) = SvNVX(sstr);
8168 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8169 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8170 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8171 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8172 if (AvARRAY((AV*)sstr)) {
8173 SV **dst_ary, **src_ary;
8174 SSize_t items = AvFILLp((AV*)sstr) + 1;
8176 src_ary = AvARRAY((AV*)sstr);
8177 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8178 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8179 SvPVX(dstr) = (char*)dst_ary;
8180 AvALLOC((AV*)dstr) = dst_ary;
8181 if (AvREAL((AV*)sstr)) {
8183 *dst_ary++ = sv_dup_inc(*src_ary++);
8187 *dst_ary++ = sv_dup(*src_ary++);
8189 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8190 while (items-- > 0) {
8191 *dst_ary++ = &PL_sv_undef;
8195 SvPVX(dstr) = Nullch;
8196 AvALLOC((AV*)dstr) = (SV**)NULL;
8200 SvANY(dstr) = new_XPVHV();
8201 SvCUR(dstr) = SvCUR(sstr);
8202 SvLEN(dstr) = SvLEN(sstr);
8203 SvIVX(dstr) = SvIVX(sstr);
8204 SvNVX(dstr) = SvNVX(sstr);
8205 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8206 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8207 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8208 if (HvARRAY((HV*)sstr)) {
8210 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8211 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8212 Newz(0, dxhv->xhv_array,
8213 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8214 while (i <= sxhv->xhv_max) {
8215 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8216 !!HvSHAREKEYS(sstr));
8219 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8222 SvPVX(dstr) = Nullch;
8223 HvEITER((HV*)dstr) = (HE*)NULL;
8225 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8226 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8229 SvANY(dstr) = new_XPVFM();
8230 FmLINES(dstr) = FmLINES(sstr);
8234 SvANY(dstr) = new_XPVCV();
8236 SvCUR(dstr) = SvCUR(sstr);
8237 SvLEN(dstr) = SvLEN(sstr);
8238 SvIVX(dstr) = SvIVX(sstr);
8239 SvNVX(dstr) = SvNVX(sstr);
8240 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8241 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8242 if (SvPVX(sstr) && SvLEN(sstr))
8243 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8245 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8246 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8247 CvSTART(dstr) = CvSTART(sstr);
8248 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8249 CvXSUB(dstr) = CvXSUB(sstr);
8250 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8251 CvGV(dstr) = gv_dup(CvGV(sstr));
8252 CvDEPTH(dstr) = CvDEPTH(sstr);
8253 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8254 /* XXX padlists are real, but pretend to be not */
8255 AvREAL_on(CvPADLIST(sstr));
8256 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8257 AvREAL_off(CvPADLIST(sstr));
8258 AvREAL_off(CvPADLIST(dstr));
8261 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8262 if (!CvANON(sstr) || CvCLONED(sstr))
8263 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8265 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8266 CvFLAGS(dstr) = CvFLAGS(sstr);
8269 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8273 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8280 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8285 return (PERL_CONTEXT*)NULL;
8287 /* look for it in the table first */
8288 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8292 /* create anew and remember what it is */
8293 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8294 ptr_table_store(PL_ptr_table, cxs, ncxs);
8297 PERL_CONTEXT *cx = &cxs[ix];
8298 PERL_CONTEXT *ncx = &ncxs[ix];
8299 ncx->cx_type = cx->cx_type;
8300 if (CxTYPE(cx) == CXt_SUBST) {
8301 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8304 ncx->blk_oldsp = cx->blk_oldsp;
8305 ncx->blk_oldcop = cx->blk_oldcop;
8306 ncx->blk_oldretsp = cx->blk_oldretsp;
8307 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8308 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8309 ncx->blk_oldpm = cx->blk_oldpm;
8310 ncx->blk_gimme = cx->blk_gimme;
8311 switch (CxTYPE(cx)) {
8313 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8314 ? cv_dup_inc(cx->blk_sub.cv)
8315 : cv_dup(cx->blk_sub.cv));
8316 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8317 ? av_dup_inc(cx->blk_sub.argarray)
8319 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8320 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8321 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8322 ncx->blk_sub.lval = cx->blk_sub.lval;
8325 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8326 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8327 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8328 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8329 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8332 ncx->blk_loop.label = cx->blk_loop.label;
8333 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8334 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8335 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8336 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8337 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8338 ? cx->blk_loop.iterdata
8339 : gv_dup((GV*)cx->blk_loop.iterdata));
8340 ncx->blk_loop.oldcurpad
8341 = (SV**)ptr_table_fetch(PL_ptr_table,
8342 cx->blk_loop.oldcurpad);
8343 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8344 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8345 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8346 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8347 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8350 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8351 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8352 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8353 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8366 Perl_si_dup(pTHX_ PERL_SI *si)
8371 return (PERL_SI*)NULL;
8373 /* look for it in the table first */
8374 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8378 /* create anew and remember what it is */
8379 Newz(56, nsi, 1, PERL_SI);
8380 ptr_table_store(PL_ptr_table, si, nsi);
8382 nsi->si_stack = av_dup_inc(si->si_stack);
8383 nsi->si_cxix = si->si_cxix;
8384 nsi->si_cxmax = si->si_cxmax;
8385 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8386 nsi->si_type = si->si_type;
8387 nsi->si_prev = si_dup(si->si_prev);
8388 nsi->si_next = si_dup(si->si_next);
8389 nsi->si_markoff = si->si_markoff;
8394 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8395 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8396 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8397 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8398 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8399 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8400 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8401 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8402 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8403 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8404 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8405 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8408 #define pv_dup_inc(p) SAVEPV(p)
8409 #define pv_dup(p) SAVEPV(p)
8410 #define svp_dup_inc(p,pp) any_dup(p,pp)
8413 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8420 /* look for it in the table first */
8421 ret = ptr_table_fetch(PL_ptr_table, v);
8425 /* see if it is part of the interpreter structure */
8426 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8427 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8435 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8437 ANY *ss = proto_perl->Tsavestack;
8438 I32 ix = proto_perl->Tsavestack_ix;
8439 I32 max = proto_perl->Tsavestack_max;
8452 void (*dptr) (void*);
8453 void (*dxptr) (pTHXo_ void*);
8456 Newz(54, nss, max, ANY);
8462 case SAVEt_ITEM: /* normal string */
8463 sv = (SV*)POPPTR(ss,ix);
8464 TOPPTR(nss,ix) = sv_dup_inc(sv);
8465 sv = (SV*)POPPTR(ss,ix);
8466 TOPPTR(nss,ix) = sv_dup_inc(sv);
8468 case SAVEt_SV: /* scalar reference */
8469 sv = (SV*)POPPTR(ss,ix);
8470 TOPPTR(nss,ix) = sv_dup_inc(sv);
8471 gv = (GV*)POPPTR(ss,ix);
8472 TOPPTR(nss,ix) = gv_dup_inc(gv);
8474 case SAVEt_GENERIC_PVREF: /* generic char* */
8475 c = (char*)POPPTR(ss,ix);
8476 TOPPTR(nss,ix) = pv_dup(c);
8477 ptr = POPPTR(ss,ix);
8478 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8480 case SAVEt_GENERIC_SVREF: /* generic sv */
8481 case SAVEt_SVREF: /* scalar reference */
8482 sv = (SV*)POPPTR(ss,ix);
8483 TOPPTR(nss,ix) = sv_dup_inc(sv);
8484 ptr = POPPTR(ss,ix);
8485 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8487 case SAVEt_AV: /* array reference */
8488 av = (AV*)POPPTR(ss,ix);
8489 TOPPTR(nss,ix) = av_dup_inc(av);
8490 gv = (GV*)POPPTR(ss,ix);
8491 TOPPTR(nss,ix) = gv_dup(gv);
8493 case SAVEt_HV: /* hash reference */
8494 hv = (HV*)POPPTR(ss,ix);
8495 TOPPTR(nss,ix) = hv_dup_inc(hv);
8496 gv = (GV*)POPPTR(ss,ix);
8497 TOPPTR(nss,ix) = gv_dup(gv);
8499 case SAVEt_INT: /* int reference */
8500 ptr = POPPTR(ss,ix);
8501 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8502 intval = (int)POPINT(ss,ix);
8503 TOPINT(nss,ix) = intval;
8505 case SAVEt_LONG: /* long reference */
8506 ptr = POPPTR(ss,ix);
8507 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8508 longval = (long)POPLONG(ss,ix);
8509 TOPLONG(nss,ix) = longval;
8511 case SAVEt_I32: /* I32 reference */
8512 case SAVEt_I16: /* I16 reference */
8513 case SAVEt_I8: /* I8 reference */
8514 ptr = POPPTR(ss,ix);
8515 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8519 case SAVEt_IV: /* IV reference */
8520 ptr = POPPTR(ss,ix);
8521 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8525 case SAVEt_SPTR: /* SV* reference */
8526 ptr = POPPTR(ss,ix);
8527 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8528 sv = (SV*)POPPTR(ss,ix);
8529 TOPPTR(nss,ix) = sv_dup(sv);
8531 case SAVEt_VPTR: /* random* reference */
8532 ptr = POPPTR(ss,ix);
8533 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8534 ptr = POPPTR(ss,ix);
8535 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8537 case SAVEt_PPTR: /* char* reference */
8538 ptr = POPPTR(ss,ix);
8539 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8540 c = (char*)POPPTR(ss,ix);
8541 TOPPTR(nss,ix) = pv_dup(c);
8543 case SAVEt_HPTR: /* HV* reference */
8544 ptr = POPPTR(ss,ix);
8545 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8546 hv = (HV*)POPPTR(ss,ix);
8547 TOPPTR(nss,ix) = hv_dup(hv);
8549 case SAVEt_APTR: /* AV* reference */
8550 ptr = POPPTR(ss,ix);
8551 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8552 av = (AV*)POPPTR(ss,ix);
8553 TOPPTR(nss,ix) = av_dup(av);
8556 gv = (GV*)POPPTR(ss,ix);
8557 TOPPTR(nss,ix) = gv_dup(gv);
8559 case SAVEt_GP: /* scalar reference */
8560 gp = (GP*)POPPTR(ss,ix);
8561 TOPPTR(nss,ix) = gp = gp_dup(gp);
8562 (void)GpREFCNT_inc(gp);
8563 gv = (GV*)POPPTR(ss,ix);
8564 TOPPTR(nss,ix) = gv_dup_inc(c);
8565 c = (char*)POPPTR(ss,ix);
8566 TOPPTR(nss,ix) = pv_dup(c);
8573 case SAVEt_MORTALIZESV:
8574 sv = (SV*)POPPTR(ss,ix);
8575 TOPPTR(nss,ix) = sv_dup_inc(sv);
8578 ptr = POPPTR(ss,ix);
8579 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8580 /* these are assumed to be refcounted properly */
8581 switch (((OP*)ptr)->op_type) {
8588 TOPPTR(nss,ix) = ptr;
8593 TOPPTR(nss,ix) = Nullop;
8598 TOPPTR(nss,ix) = Nullop;
8601 c = (char*)POPPTR(ss,ix);
8602 TOPPTR(nss,ix) = pv_dup_inc(c);
8605 longval = POPLONG(ss,ix);
8606 TOPLONG(nss,ix) = longval;
8609 hv = (HV*)POPPTR(ss,ix);
8610 TOPPTR(nss,ix) = hv_dup_inc(hv);
8611 c = (char*)POPPTR(ss,ix);
8612 TOPPTR(nss,ix) = pv_dup_inc(c);
8616 case SAVEt_DESTRUCTOR:
8617 ptr = POPPTR(ss,ix);
8618 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8619 dptr = POPDPTR(ss,ix);
8620 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8622 case SAVEt_DESTRUCTOR_X:
8623 ptr = POPPTR(ss,ix);
8624 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8625 dxptr = POPDXPTR(ss,ix);
8626 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8628 case SAVEt_REGCONTEXT:
8634 case SAVEt_STACK_POS: /* Position on Perl stack */
8638 case SAVEt_AELEM: /* array element */
8639 sv = (SV*)POPPTR(ss,ix);
8640 TOPPTR(nss,ix) = sv_dup_inc(sv);
8643 av = (AV*)POPPTR(ss,ix);
8644 TOPPTR(nss,ix) = av_dup_inc(av);
8646 case SAVEt_HELEM: /* hash element */
8647 sv = (SV*)POPPTR(ss,ix);
8648 TOPPTR(nss,ix) = sv_dup_inc(sv);
8649 sv = (SV*)POPPTR(ss,ix);
8650 TOPPTR(nss,ix) = sv_dup_inc(sv);
8651 hv = (HV*)POPPTR(ss,ix);
8652 TOPPTR(nss,ix) = hv_dup_inc(hv);
8655 ptr = POPPTR(ss,ix);
8656 TOPPTR(nss,ix) = ptr;
8663 av = (AV*)POPPTR(ss,ix);
8664 TOPPTR(nss,ix) = av_dup(av);
8667 longval = (long)POPLONG(ss,ix);
8668 TOPLONG(nss,ix) = longval;
8669 ptr = POPPTR(ss,ix);
8670 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8671 sv = (SV*)POPPTR(ss,ix);
8672 TOPPTR(nss,ix) = sv_dup(sv);
8675 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8687 perl_clone(PerlInterpreter *proto_perl, UV flags)
8690 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8693 #ifdef PERL_IMPLICIT_SYS
8694 return perl_clone_using(proto_perl, flags,
8696 proto_perl->IMemShared,
8697 proto_perl->IMemParse,
8707 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8708 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8709 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8710 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8711 struct IPerlDir* ipD, struct IPerlSock* ipS,
8712 struct IPerlProc* ipP)
8714 /* XXX many of the string copies here can be optimized if they're
8715 * constants; they need to be allocated as common memory and just
8716 * their pointers copied. */
8720 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8722 PERL_SET_THX(pPerl);
8723 # else /* !PERL_OBJECT */
8724 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8725 PERL_SET_THX(my_perl);
8728 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8734 # else /* !DEBUGGING */
8735 Zero(my_perl, 1, PerlInterpreter);
8736 # endif /* DEBUGGING */
8740 PL_MemShared = ipMS;
8748 # endif /* PERL_OBJECT */
8749 #else /* !PERL_IMPLICIT_SYS */
8751 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8752 PERL_SET_THX(my_perl);
8755 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8761 # else /* !DEBUGGING */
8762 Zero(my_perl, 1, PerlInterpreter);
8763 # endif /* DEBUGGING */
8764 #endif /* PERL_IMPLICIT_SYS */
8767 PL_xiv_arenaroot = NULL;
8769 PL_xnv_arenaroot = NULL;
8771 PL_xrv_arenaroot = NULL;
8773 PL_xpv_arenaroot = NULL;
8775 PL_xpviv_arenaroot = NULL;
8776 PL_xpviv_root = NULL;
8777 PL_xpvnv_arenaroot = NULL;
8778 PL_xpvnv_root = NULL;
8779 PL_xpvcv_arenaroot = NULL;
8780 PL_xpvcv_root = NULL;
8781 PL_xpvav_arenaroot = NULL;
8782 PL_xpvav_root = NULL;
8783 PL_xpvhv_arenaroot = NULL;
8784 PL_xpvhv_root = NULL;
8785 PL_xpvmg_arenaroot = NULL;
8786 PL_xpvmg_root = NULL;
8787 PL_xpvlv_arenaroot = NULL;
8788 PL_xpvlv_root = NULL;
8789 PL_xpvbm_arenaroot = NULL;
8790 PL_xpvbm_root = NULL;
8791 PL_he_arenaroot = NULL;
8793 PL_nice_chunk = NULL;
8794 PL_nice_chunk_size = 0;
8797 PL_sv_root = Nullsv;
8798 PL_sv_arenaroot = Nullsv;
8800 PL_debug = proto_perl->Idebug;
8802 /* create SV map for pointer relocation */
8803 PL_ptr_table = ptr_table_new();
8805 /* initialize these special pointers as early as possible */
8806 SvANY(&PL_sv_undef) = NULL;
8807 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8808 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8809 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8812 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8814 SvANY(&PL_sv_no) = new_XPVNV();
8816 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8817 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8818 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8819 SvCUR(&PL_sv_no) = 0;
8820 SvLEN(&PL_sv_no) = 1;
8821 SvNVX(&PL_sv_no) = 0;
8822 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8825 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8827 SvANY(&PL_sv_yes) = new_XPVNV();
8829 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8830 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8831 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8832 SvCUR(&PL_sv_yes) = 1;
8833 SvLEN(&PL_sv_yes) = 2;
8834 SvNVX(&PL_sv_yes) = 1;
8835 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8837 /* create shared string table */
8838 PL_strtab = newHV();
8839 HvSHAREKEYS_off(PL_strtab);
8840 hv_ksplit(PL_strtab, 512);
8841 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8843 PL_compiling = proto_perl->Icompiling;
8844 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8845 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8846 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8847 if (!specialWARN(PL_compiling.cop_warnings))
8848 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8849 if (!specialCopIO(PL_compiling.cop_io))
8850 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8851 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8853 /* pseudo environmental stuff */
8854 PL_origargc = proto_perl->Iorigargc;
8856 New(0, PL_origargv, i+1, char*);
8857 PL_origargv[i] = '\0';
8859 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8861 PL_envgv = gv_dup(proto_perl->Ienvgv);
8862 PL_incgv = gv_dup(proto_perl->Iincgv);
8863 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8864 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8865 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8866 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8869 PL_minus_c = proto_perl->Iminus_c;
8870 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8871 PL_localpatches = proto_perl->Ilocalpatches;
8872 PL_splitstr = proto_perl->Isplitstr;
8873 PL_preprocess = proto_perl->Ipreprocess;
8874 PL_minus_n = proto_perl->Iminus_n;
8875 PL_minus_p = proto_perl->Iminus_p;
8876 PL_minus_l = proto_perl->Iminus_l;
8877 PL_minus_a = proto_perl->Iminus_a;
8878 PL_minus_F = proto_perl->Iminus_F;
8879 PL_doswitches = proto_perl->Idoswitches;
8880 PL_dowarn = proto_perl->Idowarn;
8881 PL_doextract = proto_perl->Idoextract;
8882 PL_sawampersand = proto_perl->Isawampersand;
8883 PL_unsafe = proto_perl->Iunsafe;
8884 PL_inplace = SAVEPV(proto_perl->Iinplace);
8885 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8886 PL_perldb = proto_perl->Iperldb;
8887 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8889 /* magical thingies */
8890 /* XXX time(&PL_basetime) when asked for? */
8891 PL_basetime = proto_perl->Ibasetime;
8892 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8894 PL_maxsysfd = proto_perl->Imaxsysfd;
8895 PL_multiline = proto_perl->Imultiline;
8896 PL_statusvalue = proto_perl->Istatusvalue;
8898 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8901 /* shortcuts to various I/O objects */
8902 PL_stdingv = gv_dup(proto_perl->Istdingv);
8903 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8904 PL_defgv = gv_dup(proto_perl->Idefgv);
8905 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8906 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8907 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8909 /* shortcuts to regexp stuff */
8910 PL_replgv = gv_dup(proto_perl->Ireplgv);
8912 /* shortcuts to misc objects */
8913 PL_errgv = gv_dup(proto_perl->Ierrgv);
8915 /* shortcuts to debugging objects */
8916 PL_DBgv = gv_dup(proto_perl->IDBgv);
8917 PL_DBline = gv_dup(proto_perl->IDBline);
8918 PL_DBsub = gv_dup(proto_perl->IDBsub);
8919 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8920 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8921 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8922 PL_lineary = av_dup(proto_perl->Ilineary);
8923 PL_dbargs = av_dup(proto_perl->Idbargs);
8926 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8927 PL_curstash = hv_dup(proto_perl->Tcurstash);
8928 PL_debstash = hv_dup(proto_perl->Idebstash);
8929 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8930 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8932 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8933 PL_endav = av_dup_inc(proto_perl->Iendav);
8934 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8935 PL_initav = av_dup_inc(proto_perl->Iinitav);
8937 PL_sub_generation = proto_perl->Isub_generation;
8939 /* funky return mechanisms */
8940 PL_forkprocess = proto_perl->Iforkprocess;
8942 /* subprocess state */
8943 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8945 /* internal state */
8946 PL_tainting = proto_perl->Itainting;
8947 PL_maxo = proto_perl->Imaxo;
8948 if (proto_perl->Iop_mask)
8949 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8951 PL_op_mask = Nullch;
8953 /* current interpreter roots */
8954 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8955 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8956 PL_main_start = proto_perl->Imain_start;
8957 PL_eval_root = proto_perl->Ieval_root;
8958 PL_eval_start = proto_perl->Ieval_start;
8960 /* runtime control stuff */
8961 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8962 PL_copline = proto_perl->Icopline;
8964 PL_filemode = proto_perl->Ifilemode;
8965 PL_lastfd = proto_perl->Ilastfd;
8966 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8969 PL_gensym = proto_perl->Igensym;
8970 PL_preambled = proto_perl->Ipreambled;
8971 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8972 PL_laststatval = proto_perl->Ilaststatval;
8973 PL_laststype = proto_perl->Ilaststype;
8974 PL_mess_sv = Nullsv;
8976 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8977 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8979 /* interpreter atexit processing */
8980 PL_exitlistlen = proto_perl->Iexitlistlen;
8981 if (PL_exitlistlen) {
8982 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8983 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8986 PL_exitlist = (PerlExitListEntry*)NULL;
8987 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8989 PL_profiledata = NULL;
8990 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8991 /* PL_rsfp_filters entries have fake IoDIRP() */
8992 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8994 PL_compcv = cv_dup(proto_perl->Icompcv);
8995 PL_comppad = av_dup(proto_perl->Icomppad);
8996 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8997 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8998 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8999 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9000 proto_perl->Tcurpad);
9002 #ifdef HAVE_INTERP_INTERN
9003 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9006 /* more statics moved here */
9007 PL_generation = proto_perl->Igeneration;
9008 PL_DBcv = cv_dup(proto_perl->IDBcv);
9010 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9011 PL_in_clean_all = proto_perl->Iin_clean_all;
9013 PL_uid = proto_perl->Iuid;
9014 PL_euid = proto_perl->Ieuid;
9015 PL_gid = proto_perl->Igid;
9016 PL_egid = proto_perl->Iegid;
9017 PL_nomemok = proto_perl->Inomemok;
9018 PL_an = proto_perl->Ian;
9019 PL_cop_seqmax = proto_perl->Icop_seqmax;
9020 PL_op_seqmax = proto_perl->Iop_seqmax;
9021 PL_evalseq = proto_perl->Ievalseq;
9022 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9023 PL_origalen = proto_perl->Iorigalen;
9024 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9025 PL_osname = SAVEPV(proto_perl->Iosname);
9026 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9027 PL_sighandlerp = proto_perl->Isighandlerp;
9030 PL_runops = proto_perl->Irunops;
9032 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9035 PL_cshlen = proto_perl->Icshlen;
9036 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9039 PL_lex_state = proto_perl->Ilex_state;
9040 PL_lex_defer = proto_perl->Ilex_defer;
9041 PL_lex_expect = proto_perl->Ilex_expect;
9042 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9043 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9044 PL_lex_starts = proto_perl->Ilex_starts;
9045 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9046 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9047 PL_lex_op = proto_perl->Ilex_op;
9048 PL_lex_inpat = proto_perl->Ilex_inpat;
9049 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9050 PL_lex_brackets = proto_perl->Ilex_brackets;
9051 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9052 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9053 PL_lex_casemods = proto_perl->Ilex_casemods;
9054 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9055 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9057 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9058 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9059 PL_nexttoke = proto_perl->Inexttoke;
9061 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9062 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9063 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9064 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9065 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9066 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9067 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9068 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9069 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9070 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9071 PL_pending_ident = proto_perl->Ipending_ident;
9072 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9074 PL_expect = proto_perl->Iexpect;
9076 PL_multi_start = proto_perl->Imulti_start;
9077 PL_multi_end = proto_perl->Imulti_end;
9078 PL_multi_open = proto_perl->Imulti_open;
9079 PL_multi_close = proto_perl->Imulti_close;
9081 PL_error_count = proto_perl->Ierror_count;
9082 PL_subline = proto_perl->Isubline;
9083 PL_subname = sv_dup_inc(proto_perl->Isubname);
9085 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9086 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9087 PL_padix = proto_perl->Ipadix;
9088 PL_padix_floor = proto_perl->Ipadix_floor;
9089 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9091 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9092 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9093 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9094 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9095 PL_last_lop_op = proto_perl->Ilast_lop_op;
9096 PL_in_my = proto_perl->Iin_my;
9097 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9099 PL_cryptseen = proto_perl->Icryptseen;
9102 PL_hints = proto_perl->Ihints;
9104 PL_amagic_generation = proto_perl->Iamagic_generation;
9106 #ifdef USE_LOCALE_COLLATE
9107 PL_collation_ix = proto_perl->Icollation_ix;
9108 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9109 PL_collation_standard = proto_perl->Icollation_standard;
9110 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9111 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9112 #endif /* USE_LOCALE_COLLATE */
9114 #ifdef USE_LOCALE_NUMERIC
9115 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9116 PL_numeric_standard = proto_perl->Inumeric_standard;
9117 PL_numeric_local = proto_perl->Inumeric_local;
9118 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9119 #endif /* !USE_LOCALE_NUMERIC */
9121 /* utf8 character classes */
9122 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9123 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9124 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9125 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9126 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9127 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9128 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9129 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9130 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9131 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9132 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9133 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9134 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9135 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9136 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9137 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9138 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9141 PL_last_swash_hv = Nullhv; /* reinits on demand */
9142 PL_last_swash_klen = 0;
9143 PL_last_swash_key[0]= '\0';
9144 PL_last_swash_tmps = (U8*)NULL;
9145 PL_last_swash_slen = 0;
9147 /* perly.c globals */
9148 PL_yydebug = proto_perl->Iyydebug;
9149 PL_yynerrs = proto_perl->Iyynerrs;
9150 PL_yyerrflag = proto_perl->Iyyerrflag;
9151 PL_yychar = proto_perl->Iyychar;
9152 PL_yyval = proto_perl->Iyyval;
9153 PL_yylval = proto_perl->Iyylval;
9155 PL_glob_index = proto_perl->Iglob_index;
9156 PL_srand_called = proto_perl->Isrand_called;
9157 PL_uudmap['M'] = 0; /* reinits on demand */
9158 PL_bitcount = Nullch; /* reinits on demand */
9160 if (proto_perl->Ipsig_pend) {
9161 Newz(0, PL_psig_pend, SIG_SIZE, int);
9164 PL_psig_pend = (int*)NULL;
9167 if (proto_perl->Ipsig_ptr) {
9168 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9169 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9170 for (i = 1; i < SIG_SIZE; i++) {
9171 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9172 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9176 PL_psig_ptr = (SV**)NULL;
9177 PL_psig_name = (SV**)NULL;
9180 /* thrdvar.h stuff */
9182 if (flags & CLONEf_COPY_STACKS) {
9183 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9184 PL_tmps_ix = proto_perl->Ttmps_ix;
9185 PL_tmps_max = proto_perl->Ttmps_max;
9186 PL_tmps_floor = proto_perl->Ttmps_floor;
9187 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9189 while (i <= PL_tmps_ix) {
9190 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9194 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9195 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9196 Newz(54, PL_markstack, i, I32);
9197 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9198 - proto_perl->Tmarkstack);
9199 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9200 - proto_perl->Tmarkstack);
9201 Copy(proto_perl->Tmarkstack, PL_markstack,
9202 PL_markstack_ptr - PL_markstack + 1, I32);
9204 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9205 * NOTE: unlike the others! */
9206 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9207 PL_scopestack_max = proto_perl->Tscopestack_max;
9208 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9209 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9211 /* next push_return() sets PL_retstack[PL_retstack_ix]
9212 * NOTE: unlike the others! */
9213 PL_retstack_ix = proto_perl->Tretstack_ix;
9214 PL_retstack_max = proto_perl->Tretstack_max;
9215 Newz(54, PL_retstack, PL_retstack_max, OP*);
9216 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9218 /* NOTE: si_dup() looks at PL_markstack */
9219 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9221 /* PL_curstack = PL_curstackinfo->si_stack; */
9222 PL_curstack = av_dup(proto_perl->Tcurstack);
9223 PL_mainstack = av_dup(proto_perl->Tmainstack);
9225 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9226 PL_stack_base = AvARRAY(PL_curstack);
9227 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9228 - proto_perl->Tstack_base);
9229 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9231 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9232 * NOTE: unlike the others! */
9233 PL_savestack_ix = proto_perl->Tsavestack_ix;
9234 PL_savestack_max = proto_perl->Tsavestack_max;
9235 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9236 PL_savestack = ss_dup(proto_perl);
9240 ENTER; /* perl_destruct() wants to LEAVE; */
9243 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9244 PL_top_env = &PL_start_env;
9246 PL_op = proto_perl->Top;
9249 PL_Xpv = (XPV*)NULL;
9250 PL_na = proto_perl->Tna;
9252 PL_statbuf = proto_perl->Tstatbuf;
9253 PL_statcache = proto_perl->Tstatcache;
9254 PL_statgv = gv_dup(proto_perl->Tstatgv);
9255 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9257 PL_timesbuf = proto_perl->Ttimesbuf;
9260 PL_tainted = proto_perl->Ttainted;
9261 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9262 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9263 PL_rs = sv_dup_inc(proto_perl->Trs);
9264 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9265 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9266 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9267 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9268 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9269 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9270 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9272 PL_restartop = proto_perl->Trestartop;
9273 PL_in_eval = proto_perl->Tin_eval;
9274 PL_delaymagic = proto_perl->Tdelaymagic;
9275 PL_dirty = proto_perl->Tdirty;
9276 PL_localizing = proto_perl->Tlocalizing;
9278 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9279 PL_protect = proto_perl->Tprotect;
9281 PL_errors = sv_dup_inc(proto_perl->Terrors);
9282 PL_av_fetch_sv = Nullsv;
9283 PL_hv_fetch_sv = Nullsv;
9284 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9285 PL_modcount = proto_perl->Tmodcount;
9286 PL_lastgotoprobe = Nullop;
9287 PL_dumpindent = proto_perl->Tdumpindent;
9289 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9290 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9291 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9292 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9293 PL_sortcxix = proto_perl->Tsortcxix;
9294 PL_efloatbuf = Nullch; /* reinits on demand */
9295 PL_efloatsize = 0; /* reinits on demand */
9299 PL_screamfirst = NULL;
9300 PL_screamnext = NULL;
9301 PL_maxscream = -1; /* reinits on demand */
9302 PL_lastscream = Nullsv;
9304 PL_watchaddr = NULL;
9305 PL_watchok = Nullch;
9307 PL_regdummy = proto_perl->Tregdummy;
9308 PL_regcomp_parse = Nullch;
9309 PL_regxend = Nullch;
9310 PL_regcode = (regnode*)NULL;
9313 PL_regprecomp = Nullch;
9318 PL_seen_zerolen = 0;
9320 PL_regcomp_rx = (regexp*)NULL;
9322 PL_colorset = 0; /* reinits PL_colors[] */
9323 /*PL_colors[6] = {0,0,0,0,0,0};*/
9324 PL_reg_whilem_seen = 0;
9325 PL_reginput = Nullch;
9328 PL_regstartp = (I32*)NULL;
9329 PL_regendp = (I32*)NULL;
9330 PL_reglastparen = (U32*)NULL;
9331 PL_regtill = Nullch;
9332 PL_reg_start_tmp = (char**)NULL;
9333 PL_reg_start_tmpl = 0;
9334 PL_regdata = (struct reg_data*)NULL;
9337 PL_reg_eval_set = 0;
9339 PL_regprogram = (regnode*)NULL;
9341 PL_regcc = (CURCUR*)NULL;
9342 PL_reg_call_cc = (struct re_cc_state*)NULL;
9343 PL_reg_re = (regexp*)NULL;
9344 PL_reg_ganch = Nullch;
9346 PL_reg_magic = (MAGIC*)NULL;
9348 PL_reg_oldcurpm = (PMOP*)NULL;
9349 PL_reg_curpm = (PMOP*)NULL;
9350 PL_reg_oldsaved = Nullch;
9351 PL_reg_oldsavedlen = 0;
9353 PL_reg_leftiter = 0;
9354 PL_reg_poscache = Nullch;
9355 PL_reg_poscache_size= 0;
9357 /* RE engine - function pointers */
9358 PL_regcompp = proto_perl->Tregcompp;
9359 PL_regexecp = proto_perl->Tregexecp;
9360 PL_regint_start = proto_perl->Tregint_start;
9361 PL_regint_string = proto_perl->Tregint_string;
9362 PL_regfree = proto_perl->Tregfree;
9364 PL_reginterp_cnt = 0;
9365 PL_reg_starttry = 0;
9367 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9368 ptr_table_free(PL_ptr_table);
9369 PL_ptr_table = NULL;
9373 return (PerlInterpreter*)pPerl;
9379 #else /* !USE_ITHREADS */
9385 #endif /* USE_ITHREADS */
9388 do_report_used(pTHXo_ SV *sv)
9390 if (SvTYPE(sv) != SVTYPEMASK) {
9391 PerlIO_printf(Perl_debug_log, "****\n");
9397 do_clean_objs(pTHXo_ SV *sv)
9401 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9402 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9403 if (SvWEAKREF(sv)) {
9414 /* XXX Might want to check arrays, etc. */
9417 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9419 do_clean_named_objs(pTHXo_ SV *sv)
9421 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9422 if ( SvOBJECT(GvSV(sv)) ||
9423 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9424 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9425 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9426 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9428 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9436 do_clean_all(pTHXo_ SV *sv)
9438 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9439 SvFLAGS(sv) |= SVf_BREAK;