3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
140 PL_nice_chunk_size = 0;
143 char *chunk; /* must use New here to match call to */
144 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
145 sv_add_arena(chunk, 1008, 0);
152 S_visit(pTHX_ SVFUNC_t f)
159 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
160 svend = &sva[SvREFCNT(sva)];
161 for (sv = sva + 1; sv < svend; ++sv) {
162 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
172 Perl_sv_report_used(pTHX)
174 visit(do_report_used);
178 Perl_sv_clean_objs(pTHX)
180 PL_in_clean_objs = TRUE;
181 visit(do_clean_objs);
182 #ifndef DISABLE_DESTRUCTOR_KLUDGE
183 /* some barnacles may yet remain, clinging to typeglobs */
184 visit(do_clean_named_objs);
186 PL_in_clean_objs = FALSE;
190 Perl_sv_clean_all(pTHX)
193 PL_in_clean_all = TRUE;
194 cleaned = visit(do_clean_all);
195 PL_in_clean_all = FALSE;
200 Perl_sv_free_arenas(pTHX)
204 XPV *arena, *arenanext;
206 /* Free arenas here, but be careful about fake ones. (We assume
207 contiguity of the fake ones with the corresponding real ones.) */
209 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
210 svanext = (SV*) SvANY(sva);
211 while (svanext && SvFAKE(svanext))
212 svanext = (SV*) SvANY(svanext);
215 Safefree((void *)sva);
218 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
219 arenanext = (XPV*)arena->xpv_pv;
222 PL_xiv_arenaroot = 0;
224 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
225 arenanext = (XPV*)arena->xpv_pv;
228 PL_xnv_arenaroot = 0;
230 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
231 arenanext = (XPV*)arena->xpv_pv;
234 PL_xrv_arenaroot = 0;
236 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
237 arenanext = (XPV*)arena->xpv_pv;
240 PL_xpv_arenaroot = 0;
242 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
243 arenanext = (XPV*)arena->xpv_pv;
246 PL_xpviv_arenaroot = 0;
248 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
249 arenanext = (XPV*)arena->xpv_pv;
252 PL_xpvnv_arenaroot = 0;
254 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
255 arenanext = (XPV*)arena->xpv_pv;
258 PL_xpvcv_arenaroot = 0;
260 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
261 arenanext = (XPV*)arena->xpv_pv;
264 PL_xpvav_arenaroot = 0;
266 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
267 arenanext = (XPV*)arena->xpv_pv;
270 PL_xpvhv_arenaroot = 0;
272 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
273 arenanext = (XPV*)arena->xpv_pv;
276 PL_xpvmg_arenaroot = 0;
278 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
279 arenanext = (XPV*)arena->xpv_pv;
282 PL_xpvlv_arenaroot = 0;
284 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
285 arenanext = (XPV*)arena->xpv_pv;
288 PL_xpvbm_arenaroot = 0;
290 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
291 arenanext = (XPV*)arena->xpv_pv;
297 Safefree(PL_nice_chunk);
298 PL_nice_chunk = Nullch;
299 PL_nice_chunk_size = 0;
305 Perl_report_uninit(pTHX)
308 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
309 " in ", PL_op_desc[PL_op->op_type]);
311 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
323 * See comment in more_xiv() -- RAM.
325 PL_xiv_root = *(IV**)xiv;
327 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
331 S_del_xiv(pTHX_ XPVIV *p)
333 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
335 *(IV**)xiv = PL_xiv_root;
346 New(705, ptr, 1008/sizeof(XPV), XPV);
347 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
348 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
351 xivend = &xiv[1008 / sizeof(IV) - 1];
352 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
354 while (xiv < xivend) {
355 *(IV**)xiv = (IV *)(xiv + 1);
369 PL_xnv_root = *(NV**)xnv;
371 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
375 S_del_xnv(pTHX_ XPVNV *p)
377 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
379 *(NV**)xnv = PL_xnv_root;
390 New(711, ptr, 1008/sizeof(XPV), XPV);
391 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
392 PL_xnv_arenaroot = ptr;
395 xnvend = &xnv[1008 / sizeof(NV) - 1];
396 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
398 while (xnv < xnvend) {
399 *(NV**)xnv = (NV*)(xnv + 1);
413 PL_xrv_root = (XRV*)xrv->xrv_rv;
419 S_del_xrv(pTHX_ XRV *p)
422 p->xrv_rv = (SV*)PL_xrv_root;
431 register XRV* xrvend;
433 New(712, ptr, 1008/sizeof(XPV), XPV);
434 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
435 PL_xrv_arenaroot = ptr;
438 xrvend = &xrv[1008 / sizeof(XRV) - 1];
439 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
441 while (xrv < xrvend) {
442 xrv->xrv_rv = (SV*)(xrv + 1);
456 PL_xpv_root = (XPV*)xpv->xpv_pv;
462 S_del_xpv(pTHX_ XPV *p)
465 p->xpv_pv = (char*)PL_xpv_root;
474 register XPV* xpvend;
475 New(713, xpv, 1008/sizeof(XPV), XPV);
476 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
477 PL_xpv_arenaroot = xpv;
479 xpvend = &xpv[1008 / sizeof(XPV) - 1];
481 while (xpv < xpvend) {
482 xpv->xpv_pv = (char*)(xpv + 1);
495 xpviv = PL_xpviv_root;
496 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
502 S_del_xpviv(pTHX_ XPVIV *p)
505 p->xpv_pv = (char*)PL_xpviv_root;
513 register XPVIV* xpviv;
514 register XPVIV* xpvivend;
515 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
516 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
517 PL_xpviv_arenaroot = xpviv;
519 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
520 PL_xpviv_root = ++xpviv;
521 while (xpviv < xpvivend) {
522 xpviv->xpv_pv = (char*)(xpviv + 1);
535 xpvnv = PL_xpvnv_root;
536 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
542 S_del_xpvnv(pTHX_ XPVNV *p)
545 p->xpv_pv = (char*)PL_xpvnv_root;
553 register XPVNV* xpvnv;
554 register XPVNV* xpvnvend;
555 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
556 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
557 PL_xpvnv_arenaroot = xpvnv;
559 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
560 PL_xpvnv_root = ++xpvnv;
561 while (xpvnv < xpvnvend) {
562 xpvnv->xpv_pv = (char*)(xpvnv + 1);
575 xpvcv = PL_xpvcv_root;
576 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
582 S_del_xpvcv(pTHX_ XPVCV *p)
585 p->xpv_pv = (char*)PL_xpvcv_root;
593 register XPVCV* xpvcv;
594 register XPVCV* xpvcvend;
595 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
596 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
597 PL_xpvcv_arenaroot = xpvcv;
599 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
600 PL_xpvcv_root = ++xpvcv;
601 while (xpvcv < xpvcvend) {
602 xpvcv->xpv_pv = (char*)(xpvcv + 1);
615 xpvav = PL_xpvav_root;
616 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
622 S_del_xpvav(pTHX_ XPVAV *p)
625 p->xav_array = (char*)PL_xpvav_root;
633 register XPVAV* xpvav;
634 register XPVAV* xpvavend;
635 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
636 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
637 PL_xpvav_arenaroot = xpvav;
639 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
640 PL_xpvav_root = ++xpvav;
641 while (xpvav < xpvavend) {
642 xpvav->xav_array = (char*)(xpvav + 1);
645 xpvav->xav_array = 0;
655 xpvhv = PL_xpvhv_root;
656 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
662 S_del_xpvhv(pTHX_ XPVHV *p)
665 p->xhv_array = (char*)PL_xpvhv_root;
673 register XPVHV* xpvhv;
674 register XPVHV* xpvhvend;
675 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
676 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
677 PL_xpvhv_arenaroot = xpvhv;
679 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
680 PL_xpvhv_root = ++xpvhv;
681 while (xpvhv < xpvhvend) {
682 xpvhv->xhv_array = (char*)(xpvhv + 1);
685 xpvhv->xhv_array = 0;
695 xpvmg = PL_xpvmg_root;
696 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
702 S_del_xpvmg(pTHX_ XPVMG *p)
705 p->xpv_pv = (char*)PL_xpvmg_root;
713 register XPVMG* xpvmg;
714 register XPVMG* xpvmgend;
715 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
716 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
717 PL_xpvmg_arenaroot = xpvmg;
719 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
720 PL_xpvmg_root = ++xpvmg;
721 while (xpvmg < xpvmgend) {
722 xpvmg->xpv_pv = (char*)(xpvmg + 1);
735 xpvlv = PL_xpvlv_root;
736 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
742 S_del_xpvlv(pTHX_ XPVLV *p)
745 p->xpv_pv = (char*)PL_xpvlv_root;
753 register XPVLV* xpvlv;
754 register XPVLV* xpvlvend;
755 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
756 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
757 PL_xpvlv_arenaroot = xpvlv;
759 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
760 PL_xpvlv_root = ++xpvlv;
761 while (xpvlv < xpvlvend) {
762 xpvlv->xpv_pv = (char*)(xpvlv + 1);
775 xpvbm = PL_xpvbm_root;
776 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
782 S_del_xpvbm(pTHX_ XPVBM *p)
785 p->xpv_pv = (char*)PL_xpvbm_root;
793 register XPVBM* xpvbm;
794 register XPVBM* xpvbmend;
795 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
796 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
797 PL_xpvbm_arenaroot = xpvbm;
799 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
800 PL_xpvbm_root = ++xpvbm;
801 while (xpvbm < xpvbmend) {
802 xpvbm->xpv_pv = (char*)(xpvbm + 1);
809 # define my_safemalloc(s) (void*)safexmalloc(717,s)
810 # define my_safefree(p) safexfree((char*)p)
812 # define my_safemalloc(s) (void*)safemalloc(s)
813 # define my_safefree(p) safefree((char*)p)
818 #define new_XIV() my_safemalloc(sizeof(XPVIV))
819 #define del_XIV(p) my_safefree(p)
821 #define new_XNV() my_safemalloc(sizeof(XPVNV))
822 #define del_XNV(p) my_safefree(p)
824 #define new_XRV() my_safemalloc(sizeof(XRV))
825 #define del_XRV(p) my_safefree(p)
827 #define new_XPV() my_safemalloc(sizeof(XPV))
828 #define del_XPV(p) my_safefree(p)
830 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
831 #define del_XPVIV(p) my_safefree(p)
833 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
834 #define del_XPVNV(p) my_safefree(p)
836 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
837 #define del_XPVCV(p) my_safefree(p)
839 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
840 #define del_XPVAV(p) my_safefree(p)
842 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
843 #define del_XPVHV(p) my_safefree(p)
845 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
846 #define del_XPVMG(p) my_safefree(p)
848 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
849 #define del_XPVLV(p) my_safefree(p)
851 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
852 #define del_XPVBM(p) my_safefree(p)
856 #define new_XIV() (void*)new_xiv()
857 #define del_XIV(p) del_xiv((XPVIV*) p)
859 #define new_XNV() (void*)new_xnv()
860 #define del_XNV(p) del_xnv((XPVNV*) p)
862 #define new_XRV() (void*)new_xrv()
863 #define del_XRV(p) del_xrv((XRV*) p)
865 #define new_XPV() (void*)new_xpv()
866 #define del_XPV(p) del_xpv((XPV *)p)
868 #define new_XPVIV() (void*)new_xpviv()
869 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
871 #define new_XPVNV() (void*)new_xpvnv()
872 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
874 #define new_XPVCV() (void*)new_xpvcv()
875 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
877 #define new_XPVAV() (void*)new_xpvav()
878 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
880 #define new_XPVHV() (void*)new_xpvhv()
881 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
883 #define new_XPVMG() (void*)new_xpvmg()
884 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
886 #define new_XPVLV() (void*)new_xpvlv()
887 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
889 #define new_XPVBM() (void*)new_xpvbm()
890 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
894 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
895 #define del_XPVGV(p) my_safefree(p)
897 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
898 #define del_XPVFM(p) my_safefree(p)
900 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
901 #define del_XPVIO(p) my_safefree(p)
904 =for apidoc sv_upgrade
906 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
913 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
923 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
927 if (SvTYPE(sv) == mt)
933 switch (SvTYPE(sv)) {
954 else if (mt < SVt_PVIV)
971 pv = (char*)SvRV(sv);
991 else if (mt == SVt_NV)
1002 del_XPVIV(SvANY(sv));
1012 del_XPVNV(SvANY(sv));
1020 magic = SvMAGIC(sv);
1021 stash = SvSTASH(sv);
1022 del_XPVMG(SvANY(sv));
1025 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1030 Perl_croak(aTHX_ "Can't upgrade to undef");
1032 SvANY(sv) = new_XIV();
1036 SvANY(sv) = new_XNV();
1040 SvANY(sv) = new_XRV();
1044 SvANY(sv) = new_XPV();
1050 SvANY(sv) = new_XPVIV();
1060 SvANY(sv) = new_XPVNV();
1068 SvANY(sv) = new_XPVMG();
1074 SvMAGIC(sv) = magic;
1075 SvSTASH(sv) = stash;
1078 SvANY(sv) = new_XPVLV();
1084 SvMAGIC(sv) = magic;
1085 SvSTASH(sv) = stash;
1092 SvANY(sv) = new_XPVAV();
1100 SvMAGIC(sv) = magic;
1101 SvSTASH(sv) = stash;
1107 SvANY(sv) = new_XPVHV();
1115 SvMAGIC(sv) = magic;
1116 SvSTASH(sv) = stash;
1123 SvANY(sv) = new_XPVCV();
1124 Zero(SvANY(sv), 1, XPVCV);
1130 SvMAGIC(sv) = magic;
1131 SvSTASH(sv) = stash;
1134 SvANY(sv) = new_XPVGV();
1140 SvMAGIC(sv) = magic;
1141 SvSTASH(sv) = stash;
1149 SvANY(sv) = new_XPVBM();
1155 SvMAGIC(sv) = magic;
1156 SvSTASH(sv) = stash;
1162 SvANY(sv) = new_XPVFM();
1163 Zero(SvANY(sv), 1, XPVFM);
1169 SvMAGIC(sv) = magic;
1170 SvSTASH(sv) = stash;
1173 SvANY(sv) = new_XPVIO();
1174 Zero(SvANY(sv), 1, XPVIO);
1180 SvMAGIC(sv) = magic;
1181 SvSTASH(sv) = stash;
1182 IoPAGE_LEN(sv) = 60;
1185 SvFLAGS(sv) &= ~SVTYPEMASK;
1191 Perl_sv_backoff(pTHX_ register SV *sv)
1195 char *s = SvPVX(sv);
1196 SvLEN(sv) += SvIVX(sv);
1197 SvPVX(sv) -= SvIVX(sv);
1199 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1201 SvFLAGS(sv) &= ~SVf_OOK;
1208 Expands the character buffer in the SV. This will use C<sv_unref> and will
1209 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1216 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1220 #ifdef HAS_64K_LIMIT
1221 if (newlen >= 0x10000) {
1222 PerlIO_printf(Perl_debug_log,
1223 "Allocation too large: %"UVxf"\n", (UV)newlen);
1226 #endif /* HAS_64K_LIMIT */
1229 if (SvTYPE(sv) < SVt_PV) {
1230 sv_upgrade(sv, SVt_PV);
1233 else if (SvOOK(sv)) { /* pv is offset? */
1236 if (newlen > SvLEN(sv))
1237 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1238 #ifdef HAS_64K_LIMIT
1239 if (newlen >= 0x10000)
1245 if (newlen > SvLEN(sv)) { /* need more room? */
1246 if (SvLEN(sv) && s) {
1247 #if defined(MYMALLOC) && !defined(LEAKTEST)
1248 STRLEN l = malloced_size((void*)SvPVX(sv));
1254 Renew(s,newlen,char);
1257 New(703,s,newlen,char);
1259 SvLEN_set(sv, newlen);
1265 =for apidoc sv_setiv
1267 Copies an integer into the given SV. Does not handle 'set' magic. See
1274 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1276 SV_CHECK_THINKFIRST(sv);
1277 switch (SvTYPE(sv)) {
1279 sv_upgrade(sv, SVt_IV);
1282 sv_upgrade(sv, SVt_PVNV);
1286 sv_upgrade(sv, SVt_PVIV);
1295 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1296 PL_op_desc[PL_op->op_type]);
1298 (void)SvIOK_only(sv); /* validate number */
1304 =for apidoc sv_setiv_mg
1306 Like C<sv_setiv>, but also handles 'set' magic.
1312 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1319 =for apidoc sv_setuv
1321 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1328 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1330 /* With these two if statements:
1331 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1334 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1336 If you wish to remove them, please benchmark to see what the effect is
1338 if (u <= (UV)IV_MAX) {
1339 sv_setiv(sv, (IV)u);
1348 =for apidoc sv_setuv_mg
1350 Like C<sv_setuv>, but also handles 'set' magic.
1356 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1358 /* With these two if statements:
1359 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1362 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1364 If you wish to remove them, please benchmark to see what the effect is
1366 if (u <= (UV)IV_MAX) {
1367 sv_setiv(sv, (IV)u);
1377 =for apidoc sv_setnv
1379 Copies a double into the given SV. Does not handle 'set' magic. See
1386 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1388 SV_CHECK_THINKFIRST(sv);
1389 switch (SvTYPE(sv)) {
1392 sv_upgrade(sv, SVt_NV);
1397 sv_upgrade(sv, SVt_PVNV);
1406 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1407 PL_op_name[PL_op->op_type]);
1410 (void)SvNOK_only(sv); /* validate number */
1415 =for apidoc sv_setnv_mg
1417 Like C<sv_setnv>, but also handles 'set' magic.
1423 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1430 S_not_a_number(pTHX_ SV *sv)
1434 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1435 /* each *s can expand to 4 chars + "...\0",
1436 i.e. need room for 8 chars */
1439 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1441 if (ch & 128 && !isPRINT_LC(ch)) {
1450 else if (ch == '\r') {
1454 else if (ch == '\f') {
1458 else if (ch == '\\') {
1462 else if (ch == '\0') {
1466 else if (isPRINT_LC(ch))
1481 Perl_warner(aTHX_ WARN_NUMERIC,
1482 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1483 PL_op_desc[PL_op->op_type]);
1485 Perl_warner(aTHX_ WARN_NUMERIC,
1486 "Argument \"%s\" isn't numeric", tmpbuf);
1489 #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not
1490 int). value returned in pointed-
1492 #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */
1493 #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */
1494 #define IS_NUMBER_NEG 0x08 /* leading minus sign */
1495 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1498 S_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
1501 const char *send = pv + len;
1502 const UV max_div_10 = UV_MAX / 10;
1503 const char max_mod_10 = UV_MAX % 10 + '0';
1507 STRLEN radixlen = 1;
1514 numtype = IS_NUMBER_NEG;
1519 #ifdef USE_LOCALE_NUMERIC
1520 if (PL_numeric_radix_sv && IN_LOCALE)
1521 radix = SvPV(PL_numeric_radix_sv, radixlen);
1524 /* next must be digit or the radix separator or beginning of infinity */
1526 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1528 UV value = *s - '0';
1529 /* This construction seems to be more optimiser friendly.
1530 (without it gcc does the isDIGIT test and the *s - '0' separately)
1531 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1532 In theory the optimiser could deduce how far to unroll the loop
1533 before checking for overflow. */
1534 int digit = *++s - '0';
1535 if (digit >= 0 && digit <= 9) {
1536 value = value * 10 + digit;
1538 if (digit >= 0 && digit <= 9) {
1539 value = value * 10 + digit;
1541 if (digit >= 0 && digit <= 9) {
1542 value = value * 10 + digit;
1544 if (digit >= 0 && digit <= 9) {
1545 value = value * 10 + digit;
1547 if (digit >= 0 && digit <= 9) {
1548 value = value * 10 + digit;
1550 if (digit >= 0 && digit <= 9) {
1551 value = value * 10 + digit;
1553 if (digit >= 0 && digit <= 9) {
1554 value = value * 10 + digit;
1556 if (digit >= 0 && digit <= 9) {
1557 value = value * 10 + digit;
1558 /* Now got 9 digits, so need to check
1559 each time for overflow. */
1561 while (digit >= 0 && digit <= 9
1562 && (value < max_div_10
1563 || (value == max_div_10
1564 && *s <= max_mod_10))) {
1565 value = value * 10 + digit;
1568 if (digit >= 0 && digit <= 9) {
1569 /* value overflowed.
1570 skip the remaining digits, don't
1571 worry about setting *valuep. */
1574 } while (isDIGIT(*s));
1576 IS_NUMBER_GREATER_THAN_UV_MAX;
1587 numtype |= IS_NUMBER_IN_UV;
1592 if (s + radixlen <= send && memEQ(s, radix, radixlen))
1594 #ifdef USE_LOCALE_NUMERIC
1595 /* if we did change the radix and the radix is not the "."
1596 * retry with the "." (in case of mixed data) */
1597 else if (IN_LOCALE && !(*radix == '.' && radixlen == 1) && *s == '.') {
1604 numtype |= IS_NUMBER_NOT_INT;
1605 while (isDIGIT(*s)) /* optional digits after the radix */
1610 if (s + radixlen <= send && memEQ(s, radix, radixlen))
1612 #ifdef USE_LOCALE_NUMERIC
1613 else if (IN_LOCALE && !(*radix == '.' && radixlen == 1) && *s == '.') {
1620 numtype |= IS_NUMBER_NOT_INT;
1621 /* no digits before the radix means we need digits after it */
1625 } while (isDIGIT(*s));
1626 numtype |= IS_NUMBER_IN_UV;
1628 /* integer approximation is valid - it's 0. */
1635 else if (*s == 'I' || *s == 'i') {
1636 s++; if (*s != 'N' && *s != 'n') return 0;
1637 s++; if (*s != 'F' && *s != 'f') return 0;
1638 s++; if (*s == 'I' || *s == 'i') {
1639 s++; if (*s != 'N' && *s != 'n') return 0;
1640 s++; if (*s != 'I' && *s != 'i') return 0;
1641 s++; if (*s != 'T' && *s != 't') return 0;
1642 s++; if (*s != 'Y' && *s != 'y') return 0;
1647 else /* Add test for NaN here. */
1652 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
1653 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
1655 /* we can have an optional exponent part */
1656 if (*s == 'e' || *s == 'E') {
1657 /* The only flag we keep is sign. Blow away any "it's UV" */
1658 numtype &= IS_NUMBER_NEG;
1659 numtype |= IS_NUMBER_NOT_INT;
1661 if (*s == '-' || *s == '+')
1666 } while (isDIGIT(*s));
1676 if (len == 10 && memEQ(pv, "0 but true", 10)) {
1679 return IS_NUMBER_IN_UV;
1685 =for apidoc looks_like_number
1687 Test if an the content of an SV looks like a number (or is a
1688 number). C<Inf> and C<Infinity> are treated as numbers (so will not
1689 issue a non-numeric warning), even if your atof() doesn't grok them.
1695 Perl_looks_like_number(pTHX_ SV *sv)
1697 register char *sbegin;
1704 else if (SvPOKp(sv))
1705 sbegin = SvPV(sv, len);
1707 return 1; /* Historic. Wrong? */
1708 return grok_number(sbegin, len, NULL);
1711 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1712 until proven guilty, assume that things are not that bad... */
1714 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1715 an IV (an assumption perl has been based on to date) it becomes necessary
1716 to remove the assumption that the NV always carries enough precision to
1717 recreate the IV whenever needed, and that the NV is the canonical form.
1718 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1719 precision as an side effect of conversion (which would lead to insanity
1720 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1721 1) to distinguish between IV/UV/NV slots that have cached a valid
1722 conversion where precision was lost and IV/UV/NV slots that have a
1723 valid conversion which has lost no precision
1724 2) to ensure that if a numeric conversion to one form is request that
1725 would lose precision, the precise conversion (or differently
1726 imprecise conversion) is also performed and cached, to prevent
1727 requests for different numeric formats on the same SV causing
1728 lossy conversion chains. (lossless conversion chains are perfectly
1733 SvIOKp is true if the IV slot contains a valid value
1734 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1735 SvNOKp is true if the NV slot contains a valid value
1736 SvNOK is true only if the NV value is accurate
1739 while converting from PV to NV check to see if converting that NV to an
1740 IV(or UV) would lose accuracy over a direct conversion from PV to
1741 IV(or UV). If it would, cache both conversions, return NV, but mark
1742 SV as IOK NOKp (ie not NOK).
1744 while converting from PV to IV check to see if converting that IV to an
1745 NV would lose accuracy over a direct conversion from PV to NV. If it
1746 would, cache both conversions, flag similarly.
1748 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1749 correctly because if IV & NV were set NV *always* overruled.
1750 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1751 changes - now IV and NV together means that the two are interchangeable
1752 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1754 The benefit of this is operations such as pp_add know that if SvIOK is
1755 true for both left and right operands, then integer addition can be
1756 used instead of floating point. (for cases where the result won't
1757 overflow) Before, floating point was always used, which could lead to
1758 loss of precision compared with integer addition.
1760 * making IV and NV equal status should make maths accurate on 64 bit
1762 * may speed up maths somewhat if pp_add and friends start to use
1763 integers when possible instead of fp. (hopefully the overhead in
1764 looking for SvIOK and checking for overflow will not outweigh the
1765 fp to integer speedup)
1766 * will slow down integer operations (callers of SvIV) on "inaccurate"
1767 values, as the change from SvIOK to SvIOKp will cause a call into
1768 sv_2iv each time rather than a macro access direct to the IV slot
1769 * should speed up number->string conversion on integers as IV is
1770 favoured when IV and NV equally accurate
1772 ####################################################################
1773 You had better be using SvIOK_notUV if you want an IV for arithmetic
1774 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1775 SvUOK is true iff UV.
1776 ####################################################################
1778 Your mileage will vary depending your CPUs relative fp to integer
1782 #ifndef NV_PRESERVES_UV
1783 #define IS_NUMBER_UNDERFLOW_IV 1
1784 #define IS_NUMBER_UNDERFLOW_UV 2
1785 #define IS_NUMBER_IV_AND_UV 2
1786 #define IS_NUMBER_OVERFLOW_IV 4
1787 #define IS_NUMBER_OVERFLOW_UV 5
1789 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1791 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1793 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));
1794 if (SvNVX(sv) < (NV)IV_MIN) {
1795 (void)SvIOKp_on(sv);
1798 return IS_NUMBER_UNDERFLOW_IV;
1800 if (SvNVX(sv) > (NV)UV_MAX) {
1801 (void)SvIOKp_on(sv);
1805 return IS_NUMBER_OVERFLOW_UV;
1807 (void)SvIOKp_on(sv);
1809 /* Can't use strtol etc to convert this string. (See truth table in
1811 if (SvNVX(sv) <= (UV)IV_MAX) {
1812 SvIVX(sv) = I_V(SvNVX(sv));
1813 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1814 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1816 /* Integer is imprecise. NOK, IOKp */
1818 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1821 SvUVX(sv) = U_V(SvNVX(sv));
1822 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1823 if (SvUVX(sv) == UV_MAX) {
1824 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1825 possibly be preserved by NV. Hence, it must be overflow.
1827 return IS_NUMBER_OVERFLOW_UV;
1829 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1831 /* Integer is imprecise. NOK, IOKp */
1833 return IS_NUMBER_OVERFLOW_IV;
1835 #endif /* NV_PRESERVES_UV*/
1838 Perl_sv_2iv(pTHX_ register SV *sv)
1842 if (SvGMAGICAL(sv)) {
1847 return I_V(SvNVX(sv));
1849 if (SvPOKp(sv) && SvLEN(sv))
1852 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1853 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1859 if (SvTHINKFIRST(sv)) {
1862 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1863 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1864 return SvIV(tmpstr);
1865 return PTR2IV(SvRV(sv));
1867 if (SvREADONLY(sv) && SvFAKE(sv)) {
1868 sv_force_normal(sv);
1870 if (SvREADONLY(sv) && !SvOK(sv)) {
1871 if (ckWARN(WARN_UNINITIALIZED))
1878 return (IV)(SvUVX(sv));
1885 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1886 * without also getting a cached IV/UV from it at the same time
1887 * (ie PV->NV conversion should detect loss of accuracy and cache
1888 * IV or UV at same time to avoid this. NWC */
1890 if (SvTYPE(sv) == SVt_NV)
1891 sv_upgrade(sv, SVt_PVNV);
1893 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1894 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1895 certainly cast into the IV range at IV_MAX, whereas the correct
1896 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1898 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1899 SvIVX(sv) = I_V(SvNVX(sv));
1900 if (SvNVX(sv) == (NV) SvIVX(sv)
1901 #ifndef NV_PRESERVES_UV
1902 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1903 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1904 /* Don't flag it as "accurately an integer" if the number
1905 came from a (by definition imprecise) NV operation, and
1906 we're outside the range of NV integer precision */
1909 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1910 DEBUG_c(PerlIO_printf(Perl_debug_log,
1911 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1917 /* IV not precise. No need to convert from PV, as NV
1918 conversion would already have cached IV if it detected
1919 that PV->IV would be better than PV->NV->IV
1920 flags already correct - don't set public IOK. */
1921 DEBUG_c(PerlIO_printf(Perl_debug_log,
1922 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1927 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1928 but the cast (NV)IV_MIN rounds to a the value less (more
1929 negative) than IV_MIN which happens to be equal to SvNVX ??
1930 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1931 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1932 (NV)UVX == NVX are both true, but the values differ. :-(
1933 Hopefully for 2s complement IV_MIN is something like
1934 0x8000000000000000 which will be exact. NWC */
1937 SvUVX(sv) = U_V(SvNVX(sv));
1939 (SvNVX(sv) == (NV) SvUVX(sv))
1940 #ifndef NV_PRESERVES_UV
1941 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1942 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1943 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1944 /* Don't flag it as "accurately an integer" if the number
1945 came from a (by definition imprecise) NV operation, and
1946 we're outside the range of NV integer precision */
1952 DEBUG_c(PerlIO_printf(Perl_debug_log,
1953 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1957 return (IV)SvUVX(sv);
1960 else if (SvPOKp(sv) && SvLEN(sv)) {
1962 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
1963 /* We want to avoid a possible problem when we cache an IV which
1964 may be later translated to an NV, and the resulting NV is not
1965 the same as the direct translation of the initial string
1966 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1967 be careful to ensure that the value with the .456 is around if the
1968 NV value is requested in the future).
1970 This means that if we cache such an IV, we need to cache the
1971 NV as well. Moreover, we trade speed for space, and do not
1972 cache the NV if we are sure it's not needed.
1975 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1976 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1977 == IS_NUMBER_IN_UV) {
1978 /* It's defintately an integer, only upgrade to PVIV */
1979 if (SvTYPE(sv) < SVt_PVIV)
1980 sv_upgrade(sv, SVt_PVIV);
1982 } else if (SvTYPE(sv) < SVt_PVNV)
1983 sv_upgrade(sv, SVt_PVNV);
1985 /* If NV preserves UV then we only use the UV value if we know that
1986 we aren't going to call atof() below. If NVs don't preserve UVs
1987 then the value returned may have more precision than atof() will
1988 return, even though value isn't perfectly accurate. */
1989 if ((numtype & (IS_NUMBER_IN_UV
1990 #ifdef NV_PRESERVES_UV
1993 )) == IS_NUMBER_IN_UV) {
1994 /* This won't turn off the public IOK flag if it was set above */
1995 (void)SvIOKp_on(sv);
1997 if (!(numtype & IS_NUMBER_NEG)) {
1999 if (value <= (UV)IV_MAX) {
2000 SvIVX(sv) = (IV)value;
2006 /* 2s complement assumption */
2007 if (value <= (UV)IV_MIN) {
2008 SvIVX(sv) = -(IV)value;
2010 /* Too negative for an IV. This is a double upgrade, but
2011 I'm assuming it will be be rare. */
2012 if (SvTYPE(sv) < SVt_PVNV)
2013 sv_upgrade(sv, SVt_PVNV);
2017 SvNVX(sv) = -(NV)value;
2022 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2023 will be in the previous block to set the IV slot, and the next
2024 block to set the NV slot. So no else here. */
2026 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2027 != IS_NUMBER_IN_UV) {
2028 /* It wasn't an (integer that doesn't overflow the UV). */
2029 SvNVX(sv) = Atof(SvPVX(sv));
2031 if (! numtype && ckWARN(WARN_NUMERIC))
2034 #if defined(USE_LONG_DOUBLE)
2035 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2036 PTR2UV(sv), SvNVX(sv)));
2038 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2039 PTR2UV(sv), SvNVX(sv)));
2043 #ifdef NV_PRESERVES_UV
2044 (void)SvIOKp_on(sv);
2046 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2047 SvIVX(sv) = I_V(SvNVX(sv));
2048 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2051 /* Integer is imprecise. NOK, IOKp */
2053 /* UV will not work better than IV */
2055 if (SvNVX(sv) > (NV)UV_MAX) {
2057 /* Integer is inaccurate. NOK, IOKp, is UV */
2061 SvUVX(sv) = U_V(SvNVX(sv));
2062 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2063 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2067 /* Integer is imprecise. NOK, IOKp, is UV */
2073 #else /* NV_PRESERVES_UV */
2074 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2075 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2076 /* The IV slot will have been set from value returned by
2077 grok_number above. The NV slot has just been set using
2080 assert (SvIOKp(sv));
2082 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2083 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2084 /* Small enough to preserve all bits. */
2085 (void)SvIOKp_on(sv);
2087 SvIVX(sv) = I_V(SvNVX(sv));
2088 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2090 /* Assumption: first non-preserved integer is < IV_MAX,
2091 this NV is in the preserved range, therefore: */
2092 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2094 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);
2098 0 0 already failed to read UV.
2099 0 1 already failed to read UV.
2100 1 0 you won't get here in this case. IV/UV
2101 slot set, public IOK, Atof() unneeded.
2102 1 1 already read UV.
2103 so there's no point in sv_2iuv_non_preserve() attempting
2104 to use atol, strtol, strtoul etc. */
2105 if (sv_2iuv_non_preserve (sv, numtype)
2106 >= IS_NUMBER_OVERFLOW_IV)
2110 #endif /* NV_PRESERVES_UV */
2113 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2115 if (SvTYPE(sv) < SVt_IV)
2116 /* Typically the caller expects that sv_any is not NULL now. */
2117 sv_upgrade(sv, SVt_IV);
2120 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2121 PTR2UV(sv),SvIVX(sv)));
2122 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2126 Perl_sv_2uv(pTHX_ register SV *sv)
2130 if (SvGMAGICAL(sv)) {
2135 return U_V(SvNVX(sv));
2136 if (SvPOKp(sv) && SvLEN(sv))
2139 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2140 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2146 if (SvTHINKFIRST(sv)) {
2149 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2150 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2151 return SvUV(tmpstr);
2152 return PTR2UV(SvRV(sv));
2154 if (SvREADONLY(sv) && SvFAKE(sv)) {
2155 sv_force_normal(sv);
2157 if (SvREADONLY(sv) && !SvOK(sv)) {
2158 if (ckWARN(WARN_UNINITIALIZED))
2168 return (UV)SvIVX(sv);
2172 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2173 * without also getting a cached IV/UV from it at the same time
2174 * (ie PV->NV conversion should detect loss of accuracy and cache
2175 * IV or UV at same time to avoid this. */
2176 /* IV-over-UV optimisation - choose to cache IV if possible */
2178 if (SvTYPE(sv) == SVt_NV)
2179 sv_upgrade(sv, SVt_PVNV);
2181 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2182 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2183 SvIVX(sv) = I_V(SvNVX(sv));
2184 if (SvNVX(sv) == (NV) SvIVX(sv)
2185 #ifndef NV_PRESERVES_UV
2186 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2187 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2188 /* Don't flag it as "accurately an integer" if the number
2189 came from a (by definition imprecise) NV operation, and
2190 we're outside the range of NV integer precision */
2193 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2194 DEBUG_c(PerlIO_printf(Perl_debug_log,
2195 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2201 /* IV not precise. No need to convert from PV, as NV
2202 conversion would already have cached IV if it detected
2203 that PV->IV would be better than PV->NV->IV
2204 flags already correct - don't set public IOK. */
2205 DEBUG_c(PerlIO_printf(Perl_debug_log,
2206 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2211 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2212 but the cast (NV)IV_MIN rounds to a the value less (more
2213 negative) than IV_MIN which happens to be equal to SvNVX ??
2214 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2215 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2216 (NV)UVX == NVX are both true, but the values differ. :-(
2217 Hopefully for 2s complement IV_MIN is something like
2218 0x8000000000000000 which will be exact. NWC */
2221 SvUVX(sv) = U_V(SvNVX(sv));
2223 (SvNVX(sv) == (NV) SvUVX(sv))
2224 #ifndef NV_PRESERVES_UV
2225 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2226 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2227 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2228 /* Don't flag it as "accurately an integer" if the number
2229 came from a (by definition imprecise) NV operation, and
2230 we're outside the range of NV integer precision */
2235 DEBUG_c(PerlIO_printf(Perl_debug_log,
2236 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2242 else if (SvPOKp(sv) && SvLEN(sv)) {
2244 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2246 /* We want to avoid a possible problem when we cache a UV which
2247 may be later translated to an NV, and the resulting NV is not
2248 the translation of the initial data.
2250 This means that if we cache such a UV, we need to cache the
2251 NV as well. Moreover, we trade speed for space, and do not
2252 cache the NV if not needed.
2255 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2256 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2257 == IS_NUMBER_IN_UV) {
2258 /* It's defintately an integer, only upgrade to PVIV */
2259 if (SvTYPE(sv) < SVt_PVIV)
2260 sv_upgrade(sv, SVt_PVIV);
2262 } else if (SvTYPE(sv) < SVt_PVNV)
2263 sv_upgrade(sv, SVt_PVNV);
2265 /* If NV preserves UV then we only use the UV value if we know that
2266 we aren't going to call atof() below. If NVs don't preserve UVs
2267 then the value returned may have more precision than atof() will
2268 return, even though it isn't accurate. */
2269 if ((numtype & (IS_NUMBER_IN_UV
2270 #ifdef NV_PRESERVES_UV
2273 )) == IS_NUMBER_IN_UV) {
2274 /* This won't turn off the public IOK flag if it was set above */
2275 (void)SvIOKp_on(sv);
2277 if (!(numtype & IS_NUMBER_NEG)) {
2279 if (value <= (UV)IV_MAX) {
2280 SvIVX(sv) = (IV)value;
2282 /* it didn't overflow, and it was positive. */
2287 /* 2s complement assumption */
2288 if (value <= (UV)IV_MIN) {
2289 SvIVX(sv) = -(IV)value;
2291 /* Too negative for an IV. This is a double upgrade, but
2292 I'm assuming it will be be rare. */
2293 if (SvTYPE(sv) < SVt_PVNV)
2294 sv_upgrade(sv, SVt_PVNV);
2298 SvNVX(sv) = -(NV)value;
2304 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2305 != IS_NUMBER_IN_UV) {
2306 /* It wasn't an integer, or it overflowed the UV. */
2307 SvNVX(sv) = Atof(SvPVX(sv));
2309 if (! numtype && ckWARN(WARN_NUMERIC))
2312 #if defined(USE_LONG_DOUBLE)
2313 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2314 PTR2UV(sv), SvNVX(sv)));
2316 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2317 PTR2UV(sv), SvNVX(sv)));
2320 #ifdef NV_PRESERVES_UV
2321 (void)SvIOKp_on(sv);
2323 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2324 SvIVX(sv) = I_V(SvNVX(sv));
2325 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2328 /* Integer is imprecise. NOK, IOKp */
2330 /* UV will not work better than IV */
2332 if (SvNVX(sv) > (NV)UV_MAX) {
2334 /* Integer is inaccurate. NOK, IOKp, is UV */
2338 SvUVX(sv) = U_V(SvNVX(sv));
2339 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2340 NV preservse UV so can do correct comparison. */
2341 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2345 /* Integer is imprecise. NOK, IOKp, is UV */
2350 #else /* NV_PRESERVES_UV */
2351 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2352 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2353 /* The UV slot will have been set from value returned by
2354 grok_number above. The NV slot has just been set using
2357 assert (SvIOKp(sv));
2359 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2360 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2361 /* Small enough to preserve all bits. */
2362 (void)SvIOKp_on(sv);
2364 SvIVX(sv) = I_V(SvNVX(sv));
2365 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2367 /* Assumption: first non-preserved integer is < IV_MAX,
2368 this NV is in the preserved range, therefore: */
2369 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2371 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);
2374 sv_2iuv_non_preserve (sv, numtype);
2376 #endif /* NV_PRESERVES_UV */
2380 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2381 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2384 if (SvTYPE(sv) < SVt_IV)
2385 /* Typically the caller expects that sv_any is not NULL now. */
2386 sv_upgrade(sv, SVt_IV);
2390 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2391 PTR2UV(sv),SvUVX(sv)));
2392 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2396 Perl_sv_2nv(pTHX_ register SV *sv)
2400 if (SvGMAGICAL(sv)) {
2404 if (SvPOKp(sv) && SvLEN(sv)) {
2405 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2406 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2408 return Atof(SvPVX(sv));
2412 return (NV)SvUVX(sv);
2414 return (NV)SvIVX(sv);
2417 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2418 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2424 if (SvTHINKFIRST(sv)) {
2427 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2428 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2429 return SvNV(tmpstr);
2430 return PTR2NV(SvRV(sv));
2432 if (SvREADONLY(sv) && SvFAKE(sv)) {
2433 sv_force_normal(sv);
2435 if (SvREADONLY(sv) && !SvOK(sv)) {
2436 if (ckWARN(WARN_UNINITIALIZED))
2441 if (SvTYPE(sv) < SVt_NV) {
2442 if (SvTYPE(sv) == SVt_IV)
2443 sv_upgrade(sv, SVt_PVNV);
2445 sv_upgrade(sv, SVt_NV);
2446 #ifdef USE_LONG_DOUBLE
2448 STORE_NUMERIC_LOCAL_SET_STANDARD();
2449 PerlIO_printf(Perl_debug_log,
2450 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2451 PTR2UV(sv), SvNVX(sv));
2452 RESTORE_NUMERIC_LOCAL();
2456 STORE_NUMERIC_LOCAL_SET_STANDARD();
2457 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2458 PTR2UV(sv), SvNVX(sv));
2459 RESTORE_NUMERIC_LOCAL();
2463 else if (SvTYPE(sv) < SVt_PVNV)
2464 sv_upgrade(sv, SVt_PVNV);
2465 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2468 else if (SvIOKp(sv)) {
2469 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2470 #ifdef NV_PRESERVES_UV
2473 /* Only set the public NV OK flag if this NV preserves the IV */
2474 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2475 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2476 : (SvIVX(sv) == I_V(SvNVX(sv))))
2482 else if (SvPOKp(sv) && SvLEN(sv)) {
2484 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2485 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2487 #ifdef NV_PRESERVES_UV
2488 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2489 == IS_NUMBER_IN_UV) {
2490 /* It's defintately an integer */
2491 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2493 SvNVX(sv) = Atof(SvPVX(sv));
2496 SvNVX(sv) = Atof(SvPVX(sv));
2497 /* Only set the public NV OK flag if this NV preserves the value in
2498 the PV at least as well as an IV/UV would.
2499 Not sure how to do this 100% reliably. */
2500 /* if that shift count is out of range then Configure's test is
2501 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2503 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2504 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2505 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2506 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2507 /* Can't use strtol etc to convert this string, so don't try.
2508 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2511 /* value has been set. It may not be precise. */
2512 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2513 /* 2s complement assumption for (UV)IV_MIN */
2514 SvNOK_on(sv); /* Integer is too negative. */
2519 if (numtype & IS_NUMBER_NEG) {
2520 SvIVX(sv) = -(IV)value;
2521 } else if (value <= (UV)IV_MAX) {
2522 SvIVX(sv) = (IV)value;
2528 if (numtype & IS_NUMBER_NOT_INT) {
2529 /* I believe that even if the original PV had decimals,
2530 they are lost beyond the limit of the FP precision.
2531 However, neither is canonical, so both only get p
2532 flags. NWC, 2000/11/25 */
2533 /* Both already have p flags, so do nothing */
2536 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2537 if (SvIVX(sv) == I_V(nv)) {
2542 /* It had no "." so it must be integer. */
2545 /* between IV_MAX and NV(UV_MAX).
2546 Could be slightly > UV_MAX */
2548 if (numtype & IS_NUMBER_NOT_INT) {
2549 /* UV and NV both imprecise. */
2551 UV nv_as_uv = U_V(nv);
2553 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2564 #endif /* NV_PRESERVES_UV */
2567 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2569 if (SvTYPE(sv) < SVt_NV)
2570 /* Typically the caller expects that sv_any is not NULL now. */
2571 /* XXX Ilya implies that this is a bug in callers that assume this
2572 and ideally should be fixed. */
2573 sv_upgrade(sv, SVt_NV);
2576 #if defined(USE_LONG_DOUBLE)
2578 STORE_NUMERIC_LOCAL_SET_STANDARD();
2579 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2580 PTR2UV(sv), SvNVX(sv));
2581 RESTORE_NUMERIC_LOCAL();
2585 STORE_NUMERIC_LOCAL_SET_STANDARD();
2586 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2587 PTR2UV(sv), SvNVX(sv));
2588 RESTORE_NUMERIC_LOCAL();
2594 /* Caller must validate PVX */
2596 S_asIV(pTHX_ SV *sv)
2599 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2601 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2602 == IS_NUMBER_IN_UV) {
2603 /* It's defintately an integer */
2604 if (numtype & IS_NUMBER_NEG) {
2605 if (value < (UV)IV_MIN)
2608 if (value < (UV)IV_MAX)
2613 if (ckWARN(WARN_NUMERIC))
2616 return I_V(Atof(SvPVX(sv)));
2620 S_asUV(pTHX_ SV *sv)
2623 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2625 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2626 == IS_NUMBER_IN_UV) {
2627 /* It's defintately an integer */
2628 if (!(numtype & IS_NUMBER_NEG))
2632 if (ckWARN(WARN_NUMERIC))
2635 return U_V(Atof(SvPVX(sv)));
2639 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2642 return sv_2pv(sv, &n_a);
2645 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2647 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2649 char *ptr = buf + TYPE_CHARS(UV);
2663 *--ptr = '0' + (uv % 10);
2672 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2674 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2678 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2683 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2684 char *tmpbuf = tbuf;
2690 if (SvGMAGICAL(sv)) {
2691 if (flags & SV_GMAGIC)
2699 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2701 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2706 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2711 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2712 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2719 if (SvTHINKFIRST(sv)) {
2722 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2723 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2724 return SvPV(tmpstr,*lp);
2731 switch (SvTYPE(sv)) {
2733 if ( ((SvFLAGS(sv) &
2734 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2735 == (SVs_OBJECT|SVs_RMG))
2736 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2737 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2738 regexp *re = (regexp *)mg->mg_obj;
2741 char *fptr = "msix";
2746 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2748 while((ch = *fptr++)) {
2750 reflags[left++] = ch;
2753 reflags[right--] = ch;
2758 reflags[left] = '-';
2762 mg->mg_len = re->prelen + 4 + left;
2763 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2764 Copy("(?", mg->mg_ptr, 2, char);
2765 Copy(reflags, mg->mg_ptr+2, left, char);
2766 Copy(":", mg->mg_ptr+left+2, 1, char);
2767 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2768 mg->mg_ptr[mg->mg_len - 1] = ')';
2769 mg->mg_ptr[mg->mg_len] = 0;
2771 PL_reginterp_cnt += re->program[0].next_off;
2783 case SVt_PVBM: if (SvROK(sv))
2786 s = "SCALAR"; break;
2787 case SVt_PVLV: s = "LVALUE"; break;
2788 case SVt_PVAV: s = "ARRAY"; break;
2789 case SVt_PVHV: s = "HASH"; break;
2790 case SVt_PVCV: s = "CODE"; break;
2791 case SVt_PVGV: s = "GLOB"; break;
2792 case SVt_PVFM: s = "FORMAT"; break;
2793 case SVt_PVIO: s = "IO"; break;
2794 default: s = "UNKNOWN"; break;
2798 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2801 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2807 if (SvREADONLY(sv) && !SvOK(sv)) {
2808 if (ckWARN(WARN_UNINITIALIZED))
2814 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2815 /* I'm assuming that if both IV and NV are equally valid then
2816 converting the IV is going to be more efficient */
2817 U32 isIOK = SvIOK(sv);
2818 U32 isUIOK = SvIsUV(sv);
2819 char buf[TYPE_CHARS(UV)];
2822 if (SvTYPE(sv) < SVt_PVIV)
2823 sv_upgrade(sv, SVt_PVIV);
2825 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2827 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2828 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2829 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2830 SvCUR_set(sv, ebuf - ptr);
2840 else if (SvNOKp(sv)) {
2841 if (SvTYPE(sv) < SVt_PVNV)
2842 sv_upgrade(sv, SVt_PVNV);
2843 /* The +20 is pure guesswork. Configure test needed. --jhi */
2844 SvGROW(sv, NV_DIG + 20);
2846 olderrno = errno; /* some Xenix systems wipe out errno here */
2848 if (SvNVX(sv) == 0.0)
2849 (void)strcpy(s,"0");
2853 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2856 #ifdef FIXNEGATIVEZERO
2857 if (*s == '-' && s[1] == '0' && !s[2])
2867 if (ckWARN(WARN_UNINITIALIZED)
2868 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2871 if (SvTYPE(sv) < SVt_PV)
2872 /* Typically the caller expects that sv_any is not NULL now. */
2873 sv_upgrade(sv, SVt_PV);
2876 *lp = s - SvPVX(sv);
2879 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2880 PTR2UV(sv),SvPVX(sv)));
2884 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2885 /* Sneaky stuff here */
2889 tsv = newSVpv(tmpbuf, 0);
2905 len = strlen(tmpbuf);
2907 #ifdef FIXNEGATIVEZERO
2908 if (len == 2 && t[0] == '-' && t[1] == '0') {
2913 (void)SvUPGRADE(sv, SVt_PV);
2915 s = SvGROW(sv, len + 1);
2924 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2927 return sv_2pvbyte(sv, &n_a);
2931 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2933 sv_utf8_downgrade(sv,0);
2934 return SvPV(sv,*lp);
2938 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2941 return sv_2pvutf8(sv, &n_a);
2945 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2947 sv_utf8_upgrade(sv);
2948 return SvPV(sv,*lp);
2951 /* This function is only called on magical items */
2953 Perl_sv_2bool(pTHX_ register SV *sv)
2962 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2963 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2964 return SvTRUE(tmpsv);
2965 return SvRV(sv) != 0;
2968 register XPV* Xpvtmp;
2969 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2970 (*Xpvtmp->xpv_pv > '0' ||
2971 Xpvtmp->xpv_cur > 1 ||
2972 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2979 return SvIVX(sv) != 0;
2982 return SvNVX(sv) != 0.0;
2990 =for apidoc sv_utf8_upgrade
2992 Convert the PV of an SV to its UTF8-encoded form.
2993 Forces the SV to string form it it is not already.
2994 Always sets the SvUTF8 flag to avoid future validity checks even
2995 if all the bytes have hibit clear.
3001 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3003 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3007 =for apidoc sv_utf8_upgrade_flags
3009 Convert the PV of an SV to its UTF8-encoded form.
3010 Forces the SV to string form it it is not already.
3011 Always sets the SvUTF8 flag to avoid future validity checks even
3012 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3013 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3014 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3020 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3030 (void) sv_2pv_flags(sv,&len, flags);
3038 if (SvREADONLY(sv) && SvFAKE(sv)) {
3039 sv_force_normal(sv);
3042 /* This function could be much more efficient if we had a FLAG in SVs
3043 * to signal if there are any hibit chars in the PV.
3044 * Given that there isn't make loop fast as possible
3046 s = (U8 *) SvPVX(sv);
3047 e = (U8 *) SvEND(sv);
3051 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3057 len = SvCUR(sv) + 1; /* Plus the \0 */
3058 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3059 SvCUR(sv) = len - 1;
3061 Safefree(s); /* No longer using what was there before. */
3062 SvLEN(sv) = len; /* No longer know the real size. */
3064 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3070 =for apidoc sv_utf8_downgrade
3072 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3073 This may not be possible if the PV contains non-byte encoding characters;
3074 if this is the case, either returns false or, if C<fail_ok> is not
3081 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3083 if (SvPOK(sv) && SvUTF8(sv)) {
3088 if (SvREADONLY(sv) && SvFAKE(sv))
3089 sv_force_normal(sv);
3090 s = (U8 *) SvPV(sv, len);
3091 if (!utf8_to_bytes(s, &len)) {
3094 #ifdef USE_BYTES_DOWNGRADES
3095 else if (IN_BYTES) {
3097 U8 *e = (U8 *) SvEND(sv);
3100 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3101 if (first && ch > 255) {
3103 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3104 PL_op_desc[PL_op->op_type]);
3106 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3113 len = (d - (U8 *) SvPVX(sv));
3118 Perl_croak(aTHX_ "Wide character in %s",
3119 PL_op_desc[PL_op->op_type]);
3121 Perl_croak(aTHX_ "Wide character");
3132 =for apidoc sv_utf8_encode
3134 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3135 flag so that it looks like octets again. Used as a building block
3136 for encode_utf8 in Encode.xs
3142 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3144 (void) sv_utf8_upgrade(sv);
3149 =for apidoc sv_utf8_decode
3151 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3152 turn of SvUTF8 if needed so that we see characters. Used as a building block
3153 for decode_utf8 in Encode.xs
3161 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3167 /* The octets may have got themselves encoded - get them back as bytes */
3168 if (!sv_utf8_downgrade(sv, TRUE))
3171 /* it is actually just a matter of turning the utf8 flag on, but
3172 * we want to make sure everything inside is valid utf8 first.
3174 c = (U8 *) SvPVX(sv);
3175 if (!is_utf8_string(c, SvCUR(sv)+1))
3177 e = (U8 *) SvEND(sv);
3180 if (!UTF8_IS_INVARIANT(ch)) {
3190 /* Note: sv_setsv() should not be called with a source string that needs
3191 * to be reused, since it may destroy the source string if it is marked
3196 =for apidoc sv_setsv
3198 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3199 The source SV may be destroyed if it is mortal. Does not handle 'set'
3200 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3206 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3207 for binary compatibility only
3210 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3212 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3216 =for apidoc sv_setsv_flags
3218 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3219 The source SV may be destroyed if it is mortal. Does not handle 'set'
3220 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3221 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3222 in terms of this function.
3228 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3230 register U32 sflags;
3236 SV_CHECK_THINKFIRST(dstr);
3238 sstr = &PL_sv_undef;
3239 stype = SvTYPE(sstr);
3240 dtype = SvTYPE(dstr);
3244 /* There's a lot of redundancy below but we're going for speed here */
3249 if (dtype != SVt_PVGV) {
3250 (void)SvOK_off(dstr);
3258 sv_upgrade(dstr, SVt_IV);
3261 sv_upgrade(dstr, SVt_PVNV);
3265 sv_upgrade(dstr, SVt_PVIV);
3268 (void)SvIOK_only(dstr);
3269 SvIVX(dstr) = SvIVX(sstr);
3272 if (SvTAINTED(sstr))
3283 sv_upgrade(dstr, SVt_NV);
3288 sv_upgrade(dstr, SVt_PVNV);
3291 SvNVX(dstr) = SvNVX(sstr);
3292 (void)SvNOK_only(dstr);
3293 if (SvTAINTED(sstr))
3301 sv_upgrade(dstr, SVt_RV);
3302 else if (dtype == SVt_PVGV &&
3303 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3306 if (GvIMPORTED(dstr) != GVf_IMPORTED
3307 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3309 GvIMPORTED_on(dstr);
3320 sv_upgrade(dstr, SVt_PV);
3323 if (dtype < SVt_PVIV)
3324 sv_upgrade(dstr, SVt_PVIV);
3327 if (dtype < SVt_PVNV)
3328 sv_upgrade(dstr, SVt_PVNV);
3335 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3336 PL_op_name[PL_op->op_type]);
3338 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3342 if (dtype <= SVt_PVGV) {
3344 if (dtype != SVt_PVGV) {
3345 char *name = GvNAME(sstr);
3346 STRLEN len = GvNAMELEN(sstr);
3347 sv_upgrade(dstr, SVt_PVGV);
3348 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3349 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3350 GvNAME(dstr) = savepvn(name, len);
3351 GvNAMELEN(dstr) = len;
3352 SvFAKE_on(dstr); /* can coerce to non-glob */
3354 /* ahem, death to those who redefine active sort subs */
3355 else if (PL_curstackinfo->si_type == PERLSI_SORT
3356 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3357 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3360 #ifdef GV_SHARED_CHECK
3361 if (GvSHARED((GV*)dstr)) {
3362 Perl_croak(aTHX_ PL_no_modify);
3366 (void)SvOK_off(dstr);
3367 GvINTRO_off(dstr); /* one-shot flag */
3369 GvGP(dstr) = gp_ref(GvGP(sstr));
3370 if (SvTAINTED(sstr))
3372 if (GvIMPORTED(dstr) != GVf_IMPORTED
3373 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3375 GvIMPORTED_on(dstr);
3383 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3385 if (SvTYPE(sstr) != stype) {
3386 stype = SvTYPE(sstr);
3387 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3391 if (stype == SVt_PVLV)
3392 (void)SvUPGRADE(dstr, SVt_PVNV);
3394 (void)SvUPGRADE(dstr, stype);
3397 sflags = SvFLAGS(sstr);
3399 if (sflags & SVf_ROK) {
3400 if (dtype >= SVt_PV) {
3401 if (dtype == SVt_PVGV) {
3402 SV *sref = SvREFCNT_inc(SvRV(sstr));
3404 int intro = GvINTRO(dstr);
3406 #ifdef GV_SHARED_CHECK
3407 if (GvSHARED((GV*)dstr)) {
3408 Perl_croak(aTHX_ PL_no_modify);
3415 GvINTRO_off(dstr); /* one-shot flag */
3416 Newz(602,gp, 1, GP);
3417 GvGP(dstr) = gp_ref(gp);
3418 GvSV(dstr) = NEWSV(72,0);
3419 GvLINE(dstr) = CopLINE(PL_curcop);
3420 GvEGV(dstr) = (GV*)dstr;
3423 switch (SvTYPE(sref)) {
3426 SAVESPTR(GvAV(dstr));
3428 dref = (SV*)GvAV(dstr);
3429 GvAV(dstr) = (AV*)sref;
3430 if (!GvIMPORTED_AV(dstr)
3431 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3433 GvIMPORTED_AV_on(dstr);
3438 SAVESPTR(GvHV(dstr));
3440 dref = (SV*)GvHV(dstr);
3441 GvHV(dstr) = (HV*)sref;
3442 if (!GvIMPORTED_HV(dstr)
3443 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3445 GvIMPORTED_HV_on(dstr);
3450 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3451 SvREFCNT_dec(GvCV(dstr));
3452 GvCV(dstr) = Nullcv;
3453 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3454 PL_sub_generation++;
3456 SAVESPTR(GvCV(dstr));
3459 dref = (SV*)GvCV(dstr);
3460 if (GvCV(dstr) != (CV*)sref) {
3461 CV* cv = GvCV(dstr);
3463 if (!GvCVGEN((GV*)dstr) &&
3464 (CvROOT(cv) || CvXSUB(cv)))
3466 /* ahem, death to those who redefine
3467 * active sort subs */
3468 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3469 PL_sortcop == CvSTART(cv))
3471 "Can't redefine active sort subroutine %s",
3472 GvENAME((GV*)dstr));
3473 /* Redefining a sub - warning is mandatory if
3474 it was a const and its value changed. */
3475 if (ckWARN(WARN_REDEFINE)
3477 && (!CvCONST((CV*)sref)
3478 || sv_cmp(cv_const_sv(cv),
3479 cv_const_sv((CV*)sref)))))
3481 Perl_warner(aTHX_ WARN_REDEFINE,
3483 ? "Constant subroutine %s redefined"
3484 : "Subroutine %s redefined",
3485 GvENAME((GV*)dstr));
3488 cv_ckproto(cv, (GV*)dstr,
3489 SvPOK(sref) ? SvPVX(sref) : Nullch);
3491 GvCV(dstr) = (CV*)sref;
3492 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3493 GvASSUMECV_on(dstr);
3494 PL_sub_generation++;
3496 if (!GvIMPORTED_CV(dstr)
3497 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3499 GvIMPORTED_CV_on(dstr);
3504 SAVESPTR(GvIOp(dstr));
3506 dref = (SV*)GvIOp(dstr);
3507 GvIOp(dstr) = (IO*)sref;
3511 SAVESPTR(GvFORM(dstr));
3513 dref = (SV*)GvFORM(dstr);
3514 GvFORM(dstr) = (CV*)sref;
3518 SAVESPTR(GvSV(dstr));
3520 dref = (SV*)GvSV(dstr);
3522 if (!GvIMPORTED_SV(dstr)
3523 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3525 GvIMPORTED_SV_on(dstr);
3533 if (SvTAINTED(sstr))
3538 (void)SvOOK_off(dstr); /* backoff */
3540 Safefree(SvPVX(dstr));
3541 SvLEN(dstr)=SvCUR(dstr)=0;
3544 (void)SvOK_off(dstr);
3545 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3547 if (sflags & SVp_NOK) {
3549 /* Only set the public OK flag if the source has public OK. */
3550 if (sflags & SVf_NOK)
3551 SvFLAGS(dstr) |= SVf_NOK;
3552 SvNVX(dstr) = SvNVX(sstr);
3554 if (sflags & SVp_IOK) {
3555 (void)SvIOKp_on(dstr);
3556 if (sflags & SVf_IOK)
3557 SvFLAGS(dstr) |= SVf_IOK;
3558 if (sflags & SVf_IVisUV)
3560 SvIVX(dstr) = SvIVX(sstr);
3562 if (SvAMAGIC(sstr)) {
3566 else if (sflags & SVp_POK) {
3569 * Check to see if we can just swipe the string. If so, it's a
3570 * possible small lose on short strings, but a big win on long ones.
3571 * It might even be a win on short strings if SvPVX(dstr)
3572 * has to be allocated and SvPVX(sstr) has to be freed.
3575 if (SvTEMP(sstr) && /* slated for free anyway? */
3576 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3577 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3578 SvLEN(sstr) && /* and really is a string */
3579 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3581 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3583 SvFLAGS(dstr) &= ~SVf_OOK;
3584 Safefree(SvPVX(dstr) - SvIVX(dstr));
3586 else if (SvLEN(dstr))
3587 Safefree(SvPVX(dstr));
3589 (void)SvPOK_only(dstr);
3590 SvPV_set(dstr, SvPVX(sstr));
3591 SvLEN_set(dstr, SvLEN(sstr));
3592 SvCUR_set(dstr, SvCUR(sstr));
3595 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3596 SvPV_set(sstr, Nullch);
3601 else { /* have to copy actual string */
3602 STRLEN len = SvCUR(sstr);
3604 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3605 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3606 SvCUR_set(dstr, len);
3607 *SvEND(dstr) = '\0';
3608 (void)SvPOK_only(dstr);
3610 if (sflags & SVf_UTF8)
3613 if (sflags & SVp_NOK) {
3615 if (sflags & SVf_NOK)
3616 SvFLAGS(dstr) |= SVf_NOK;
3617 SvNVX(dstr) = SvNVX(sstr);
3619 if (sflags & SVp_IOK) {
3620 (void)SvIOKp_on(dstr);
3621 if (sflags & SVf_IOK)
3622 SvFLAGS(dstr) |= SVf_IOK;
3623 if (sflags & SVf_IVisUV)
3625 SvIVX(dstr) = SvIVX(sstr);
3628 else if (sflags & SVp_IOK) {
3629 if (sflags & SVf_IOK)
3630 (void)SvIOK_only(dstr);
3632 (void)SvOK_off(dstr);
3633 (void)SvIOKp_on(dstr);
3635 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3636 if (sflags & SVf_IVisUV)
3638 SvIVX(dstr) = SvIVX(sstr);
3639 if (sflags & SVp_NOK) {
3640 if (sflags & SVf_NOK)
3641 (void)SvNOK_on(dstr);
3643 (void)SvNOKp_on(dstr);
3644 SvNVX(dstr) = SvNVX(sstr);
3647 else if (sflags & SVp_NOK) {
3648 if (sflags & SVf_NOK)
3649 (void)SvNOK_only(dstr);
3651 (void)SvOK_off(dstr);
3654 SvNVX(dstr) = SvNVX(sstr);
3657 if (dtype == SVt_PVGV) {
3658 if (ckWARN(WARN_MISC))
3659 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3662 (void)SvOK_off(dstr);
3664 if (SvTAINTED(sstr))
3669 =for apidoc sv_setsv_mg
3671 Like C<sv_setsv>, but also handles 'set' magic.
3677 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3679 sv_setsv(dstr,sstr);
3684 =for apidoc sv_setpvn
3686 Copies a string into an SV. The C<len> parameter indicates the number of
3687 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3693 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3695 register char *dptr;
3697 SV_CHECK_THINKFIRST(sv);
3703 /* len is STRLEN which is unsigned, need to copy to signed */
3706 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3708 (void)SvUPGRADE(sv, SVt_PV);
3710 SvGROW(sv, len + 1);
3712 Move(ptr,dptr,len,char);
3715 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3720 =for apidoc sv_setpvn_mg
3722 Like C<sv_setpvn>, but also handles 'set' magic.
3728 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3730 sv_setpvn(sv,ptr,len);
3735 =for apidoc sv_setpv
3737 Copies a string into an SV. The string must be null-terminated. Does not
3738 handle 'set' magic. See C<sv_setpv_mg>.
3744 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3746 register STRLEN len;
3748 SV_CHECK_THINKFIRST(sv);
3754 (void)SvUPGRADE(sv, SVt_PV);
3756 SvGROW(sv, len + 1);
3757 Move(ptr,SvPVX(sv),len+1,char);
3759 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3764 =for apidoc sv_setpv_mg
3766 Like C<sv_setpv>, but also handles 'set' magic.
3772 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3779 =for apidoc sv_usepvn
3781 Tells an SV to use C<ptr> to find its string value. Normally the string is
3782 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3783 The C<ptr> should point to memory that was allocated by C<malloc>. The
3784 string length, C<len>, must be supplied. This function will realloc the
3785 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3786 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3787 See C<sv_usepvn_mg>.
3793 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3795 SV_CHECK_THINKFIRST(sv);
3796 (void)SvUPGRADE(sv, SVt_PV);
3801 (void)SvOOK_off(sv);
3802 if (SvPVX(sv) && SvLEN(sv))
3803 Safefree(SvPVX(sv));
3804 Renew(ptr, len+1, char);
3807 SvLEN_set(sv, len+1);
3809 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3814 =for apidoc sv_usepvn_mg
3816 Like C<sv_usepvn>, but also handles 'set' magic.
3822 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3824 sv_usepvn(sv,ptr,len);
3829 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3831 if (SvREADONLY(sv)) {
3833 char *pvx = SvPVX(sv);
3834 STRLEN len = SvCUR(sv);
3835 U32 hash = SvUVX(sv);
3836 SvGROW(sv, len + 1);
3837 Move(pvx,SvPVX(sv),len,char);
3841 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3843 else if (PL_curcop != &PL_compiling)
3844 Perl_croak(aTHX_ PL_no_modify);
3847 sv_unref_flags(sv, flags);
3848 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3853 Perl_sv_force_normal(pTHX_ register SV *sv)
3855 sv_force_normal_flags(sv, 0);
3861 Efficient removal of characters from the beginning of the string buffer.
3862 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3863 the string buffer. The C<ptr> becomes the first character of the adjusted
3870 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3874 register STRLEN delta;
3876 if (!ptr || !SvPOKp(sv))
3878 SV_CHECK_THINKFIRST(sv);
3879 if (SvTYPE(sv) < SVt_PVIV)
3880 sv_upgrade(sv,SVt_PVIV);
3883 if (!SvLEN(sv)) { /* make copy of shared string */
3884 char *pvx = SvPVX(sv);
3885 STRLEN len = SvCUR(sv);
3886 SvGROW(sv, len + 1);
3887 Move(pvx,SvPVX(sv),len,char);
3891 SvFLAGS(sv) |= SVf_OOK;
3893 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3894 delta = ptr - SvPVX(sv);
3902 =for apidoc sv_catpvn
3904 Concatenates the string onto the end of the string which is in the SV. The
3905 C<len> indicates number of bytes to copy. If the SV has the UTF8
3906 status set, then the bytes appended should be valid UTF8.
3907 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3912 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3913 for binary compatibility only
3916 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3918 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3922 =for apidoc sv_catpvn_flags
3924 Concatenates the string onto the end of the string which is in the SV. The
3925 C<len> indicates number of bytes to copy. If the SV has the UTF8
3926 status set, then the bytes appended should be valid UTF8.
3927 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3928 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3929 in terms of this function.
3935 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3940 dstr = SvPV_force_flags(dsv, dlen, flags);
3941 SvGROW(dsv, dlen + slen + 1);
3944 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3947 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3952 =for apidoc sv_catpvn_mg
3954 Like C<sv_catpvn>, but also handles 'set' magic.
3960 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3962 sv_catpvn(sv,ptr,len);
3967 =for apidoc sv_catsv
3969 Concatenates the string from SV C<ssv> onto the end of the string in
3970 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3971 not 'set' magic. See C<sv_catsv_mg>.
3975 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3976 for binary compatibility only
3979 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3981 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3985 =for apidoc sv_catsv_flags
3987 Concatenates the string from SV C<ssv> onto the end of the string in
3988 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3989 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3990 and C<sv_catsv_nomg> are implemented in terms of this function.
3995 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4001 if ((spv = SvPV(ssv, slen))) {
4002 bool sutf8 = DO_UTF8(ssv);
4005 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4007 dutf8 = DO_UTF8(dsv);
4009 if (dutf8 != sutf8) {
4011 /* Not modifying source SV, so taking a temporary copy. */
4012 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4014 sv_utf8_upgrade(csv);
4015 spv = SvPV(csv, slen);
4018 sv_utf8_upgrade_nomg(dsv);
4020 sv_catpvn_nomg(dsv, spv, slen);
4025 =for apidoc sv_catsv_mg
4027 Like C<sv_catsv>, but also handles 'set' magic.
4033 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4040 =for apidoc sv_catpv
4042 Concatenates the string onto the end of the string which is in the SV.
4043 If the SV has the UTF8 status set, then the bytes appended should be
4044 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4049 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4051 register STRLEN len;
4057 junk = SvPV_force(sv, tlen);
4059 SvGROW(sv, tlen + len + 1);
4062 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4064 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4069 =for apidoc sv_catpv_mg
4071 Like C<sv_catpv>, but also handles 'set' magic.
4077 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4084 Perl_newSV(pTHX_ STRLEN len)
4090 sv_upgrade(sv, SVt_PV);
4091 SvGROW(sv, len + 1);
4096 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4099 =for apidoc sv_magic
4101 Adds magic to an SV.
4107 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4111 if (SvREADONLY(sv)) {
4112 if (PL_curcop != &PL_compiling
4113 /* XXX this used to be !strchr("gBf", how), which seems to
4114 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4115 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4116 * to the list of things to check - DAPM 19-May-01 */
4117 && how != PERL_MAGIC_regex_global
4118 && how != PERL_MAGIC_bm
4119 && how != PERL_MAGIC_fm
4120 && how != PERL_MAGIC_sv
4123 Perl_croak(aTHX_ PL_no_modify);
4126 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4127 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4128 if (how == PERL_MAGIC_taint)
4134 (void)SvUPGRADE(sv, SVt_PVMG);
4136 Newz(702,mg, 1, MAGIC);
4137 mg->mg_moremagic = SvMAGIC(sv);
4140 /* Some magic sontains a reference loop, where the sv and object refer to
4141 each other. To prevent a avoid a reference loop that would prevent such
4142 objects being freed, we look for such loops and if we find one we avoid
4143 incrementing the object refcount. */
4144 if (!obj || obj == sv ||
4145 how == PERL_MAGIC_arylen ||
4146 how == PERL_MAGIC_qr ||
4147 (SvTYPE(obj) == SVt_PVGV &&
4148 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4149 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4150 GvFORM(obj) == (CV*)sv)))
4155 mg->mg_obj = SvREFCNT_inc(obj);
4156 mg->mg_flags |= MGf_REFCOUNTED;
4159 mg->mg_len = namlen;
4162 mg->mg_ptr = savepvn(name, namlen);
4163 else if (namlen == HEf_SVKEY)
4164 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4169 mg->mg_virtual = &PL_vtbl_sv;
4171 case PERL_MAGIC_overload:
4172 mg->mg_virtual = &PL_vtbl_amagic;
4174 case PERL_MAGIC_overload_elem:
4175 mg->mg_virtual = &PL_vtbl_amagicelem;
4177 case PERL_MAGIC_overload_table:
4178 mg->mg_virtual = &PL_vtbl_ovrld;
4181 mg->mg_virtual = &PL_vtbl_bm;
4183 case PERL_MAGIC_regdata:
4184 mg->mg_virtual = &PL_vtbl_regdata;
4186 case PERL_MAGIC_regdatum:
4187 mg->mg_virtual = &PL_vtbl_regdatum;
4189 case PERL_MAGIC_env:
4190 mg->mg_virtual = &PL_vtbl_env;
4193 mg->mg_virtual = &PL_vtbl_fm;
4195 case PERL_MAGIC_envelem:
4196 mg->mg_virtual = &PL_vtbl_envelem;
4198 case PERL_MAGIC_regex_global:
4199 mg->mg_virtual = &PL_vtbl_mglob;
4201 case PERL_MAGIC_isa:
4202 mg->mg_virtual = &PL_vtbl_isa;
4204 case PERL_MAGIC_isaelem:
4205 mg->mg_virtual = &PL_vtbl_isaelem;
4207 case PERL_MAGIC_nkeys:
4208 mg->mg_virtual = &PL_vtbl_nkeys;
4210 case PERL_MAGIC_dbfile:
4214 case PERL_MAGIC_dbline:
4215 mg->mg_virtual = &PL_vtbl_dbline;
4218 case PERL_MAGIC_mutex:
4219 mg->mg_virtual = &PL_vtbl_mutex;
4221 #endif /* USE_THREADS */
4222 #ifdef USE_LOCALE_COLLATE
4223 case PERL_MAGIC_collxfrm:
4224 mg->mg_virtual = &PL_vtbl_collxfrm;
4226 #endif /* USE_LOCALE_COLLATE */
4227 case PERL_MAGIC_tied:
4228 mg->mg_virtual = &PL_vtbl_pack;
4230 case PERL_MAGIC_tiedelem:
4231 case PERL_MAGIC_tiedscalar:
4232 mg->mg_virtual = &PL_vtbl_packelem;
4235 mg->mg_virtual = &PL_vtbl_regexp;
4237 case PERL_MAGIC_sig:
4238 mg->mg_virtual = &PL_vtbl_sig;
4240 case PERL_MAGIC_sigelem:
4241 mg->mg_virtual = &PL_vtbl_sigelem;
4243 case PERL_MAGIC_taint:
4244 mg->mg_virtual = &PL_vtbl_taint;
4247 case PERL_MAGIC_uvar:
4248 mg->mg_virtual = &PL_vtbl_uvar;
4250 case PERL_MAGIC_vec:
4251 mg->mg_virtual = &PL_vtbl_vec;
4253 case PERL_MAGIC_substr:
4254 mg->mg_virtual = &PL_vtbl_substr;
4256 case PERL_MAGIC_defelem:
4257 mg->mg_virtual = &PL_vtbl_defelem;
4259 case PERL_MAGIC_glob:
4260 mg->mg_virtual = &PL_vtbl_glob;
4262 case PERL_MAGIC_arylen:
4263 mg->mg_virtual = &PL_vtbl_arylen;
4265 case PERL_MAGIC_pos:
4266 mg->mg_virtual = &PL_vtbl_pos;
4268 case PERL_MAGIC_backref:
4269 mg->mg_virtual = &PL_vtbl_backref;
4271 case PERL_MAGIC_ext:
4272 /* Reserved for use by extensions not perl internals. */
4273 /* Useful for attaching extension internal data to perl vars. */
4274 /* Note that multiple extensions may clash if magical scalars */
4275 /* etc holding private data from one are passed to another. */
4279 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4283 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4287 =for apidoc sv_unmagic
4289 Removes magic from an SV.
4295 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4299 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4302 for (mg = *mgp; mg; mg = *mgp) {
4303 if (mg->mg_type == type) {
4304 MGVTBL* vtbl = mg->mg_virtual;
4305 *mgp = mg->mg_moremagic;
4306 if (vtbl && vtbl->svt_free)
4307 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4308 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4309 if (mg->mg_len >= 0)
4310 Safefree(mg->mg_ptr);
4311 else if (mg->mg_len == HEf_SVKEY)
4312 SvREFCNT_dec((SV*)mg->mg_ptr);
4314 if (mg->mg_flags & MGf_REFCOUNTED)
4315 SvREFCNT_dec(mg->mg_obj);
4319 mgp = &mg->mg_moremagic;
4323 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4330 =for apidoc sv_rvweaken
4338 Perl_sv_rvweaken(pTHX_ SV *sv)
4341 if (!SvOK(sv)) /* let undefs pass */
4344 Perl_croak(aTHX_ "Can't weaken a nonreference");
4345 else if (SvWEAKREF(sv)) {
4346 if (ckWARN(WARN_MISC))
4347 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4351 sv_add_backref(tsv, sv);
4358 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4362 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4363 av = (AV*)mg->mg_obj;
4366 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4367 SvREFCNT_dec(av); /* for sv_magic */
4373 S_sv_del_backref(pTHX_ SV *sv)
4380 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4381 Perl_croak(aTHX_ "panic: del_backref");
4382 av = (AV *)mg->mg_obj;
4387 svp[i] = &PL_sv_undef; /* XXX */
4394 =for apidoc sv_insert
4396 Inserts a string at the specified offset/length within the SV. Similar to
4397 the Perl substr() function.
4403 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4407 register char *midend;
4408 register char *bigend;
4414 Perl_croak(aTHX_ "Can't modify non-existent substring");
4415 SvPV_force(bigstr, curlen);
4416 (void)SvPOK_only_UTF8(bigstr);
4417 if (offset + len > curlen) {
4418 SvGROW(bigstr, offset+len+1);
4419 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4420 SvCUR_set(bigstr, offset+len);
4424 i = littlelen - len;
4425 if (i > 0) { /* string might grow */
4426 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4427 mid = big + offset + len;
4428 midend = bigend = big + SvCUR(bigstr);
4431 while (midend > mid) /* shove everything down */
4432 *--bigend = *--midend;
4433 Move(little,big+offset,littlelen,char);
4439 Move(little,SvPVX(bigstr)+offset,len,char);
4444 big = SvPVX(bigstr);
4447 bigend = big + SvCUR(bigstr);
4449 if (midend > bigend)
4450 Perl_croak(aTHX_ "panic: sv_insert");
4452 if (mid - big > bigend - midend) { /* faster to shorten from end */
4454 Move(little, mid, littlelen,char);
4457 i = bigend - midend;
4459 Move(midend, mid, i,char);
4463 SvCUR_set(bigstr, mid - big);
4466 else if ((i = mid - big)) { /* faster from front */
4467 midend -= littlelen;
4469 sv_chop(bigstr,midend-i);
4474 Move(little, mid, littlelen,char);
4476 else if (littlelen) {
4477 midend -= littlelen;
4478 sv_chop(bigstr,midend);
4479 Move(little,midend,littlelen,char);
4482 sv_chop(bigstr,midend);
4488 =for apidoc sv_replace
4490 Make the first argument a copy of the second, then delete the original.
4496 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4498 U32 refcnt = SvREFCNT(sv);
4499 SV_CHECK_THINKFIRST(sv);
4500 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4501 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4502 if (SvMAGICAL(sv)) {
4506 sv_upgrade(nsv, SVt_PVMG);
4507 SvMAGIC(nsv) = SvMAGIC(sv);
4508 SvFLAGS(nsv) |= SvMAGICAL(sv);
4514 assert(!SvREFCNT(sv));
4515 StructCopy(nsv,sv,SV);
4516 SvREFCNT(sv) = refcnt;
4517 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4522 =for apidoc sv_clear
4524 Clear an SV, making it empty. Does not free the memory used by the SV
4531 Perl_sv_clear(pTHX_ register SV *sv)
4535 assert(SvREFCNT(sv) == 0);
4538 if (PL_defstash) { /* Still have a symbol table? */
4543 Zero(&tmpref, 1, SV);
4544 sv_upgrade(&tmpref, SVt_RV);
4546 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4547 SvREFCNT(&tmpref) = 1;
4550 stash = SvSTASH(sv);
4551 destructor = StashHANDLER(stash,DESTROY);
4554 PUSHSTACKi(PERLSI_DESTROY);
4555 SvRV(&tmpref) = SvREFCNT_inc(sv);
4560 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4566 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4568 del_XRV(SvANY(&tmpref));
4571 if (PL_in_clean_objs)
4572 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4574 /* DESTROY gave object new lease on life */
4580 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4581 SvOBJECT_off(sv); /* Curse the object. */
4582 if (SvTYPE(sv) != SVt_PVIO)
4583 --PL_sv_objcount; /* XXX Might want something more general */
4586 if (SvTYPE(sv) >= SVt_PVMG) {
4589 if (SvFLAGS(sv) & SVpad_TYPED)
4590 SvREFCNT_dec(SvSTASH(sv));
4593 switch (SvTYPE(sv)) {
4596 IoIFP(sv) != PerlIO_stdin() &&
4597 IoIFP(sv) != PerlIO_stdout() &&
4598 IoIFP(sv) != PerlIO_stderr())
4600 io_close((IO*)sv, FALSE);
4602 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4603 PerlDir_close(IoDIRP(sv));
4604 IoDIRP(sv) = (DIR*)NULL;
4605 Safefree(IoTOP_NAME(sv));
4606 Safefree(IoFMT_NAME(sv));
4607 Safefree(IoBOTTOM_NAME(sv));
4622 SvREFCNT_dec(LvTARG(sv));
4626 Safefree(GvNAME(sv));
4627 /* cannot decrease stash refcount yet, as we might recursively delete
4628 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4629 of stash until current sv is completely gone.
4630 -- JohnPC, 27 Mar 1998 */
4631 stash = GvSTASH(sv);
4637 (void)SvOOK_off(sv);
4645 SvREFCNT_dec(SvRV(sv));
4647 else if (SvPVX(sv) && SvLEN(sv))
4648 Safefree(SvPVX(sv));
4649 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4650 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4662 switch (SvTYPE(sv)) {
4678 del_XPVIV(SvANY(sv));
4681 del_XPVNV(SvANY(sv));
4684 del_XPVMG(SvANY(sv));
4687 del_XPVLV(SvANY(sv));
4690 del_XPVAV(SvANY(sv));
4693 del_XPVHV(SvANY(sv));
4696 del_XPVCV(SvANY(sv));
4699 del_XPVGV(SvANY(sv));
4700 /* code duplication for increased performance. */
4701 SvFLAGS(sv) &= SVf_BREAK;
4702 SvFLAGS(sv) |= SVTYPEMASK;
4703 /* decrease refcount of the stash that owns this GV, if any */
4705 SvREFCNT_dec(stash);
4706 return; /* not break, SvFLAGS reset already happened */
4708 del_XPVBM(SvANY(sv));
4711 del_XPVFM(SvANY(sv));
4714 del_XPVIO(SvANY(sv));
4717 SvFLAGS(sv) &= SVf_BREAK;
4718 SvFLAGS(sv) |= SVTYPEMASK;
4722 Perl_sv_newref(pTHX_ SV *sv)
4725 ATOMIC_INC(SvREFCNT(sv));
4732 Free the memory used by an SV.
4738 Perl_sv_free(pTHX_ SV *sv)
4740 int refcount_is_zero;
4744 if (SvREFCNT(sv) == 0) {
4745 if (SvFLAGS(sv) & SVf_BREAK)
4747 if (PL_in_clean_all) /* All is fair */
4749 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4750 /* make sure SvREFCNT(sv)==0 happens very seldom */
4751 SvREFCNT(sv) = (~(U32)0)/2;
4754 if (ckWARN_d(WARN_INTERNAL))
4755 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4758 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4759 if (!refcount_is_zero)
4763 if (ckWARN_d(WARN_DEBUGGING))
4764 Perl_warner(aTHX_ WARN_DEBUGGING,
4765 "Attempt to free temp prematurely: SV 0x%"UVxf,
4770 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4771 /* make sure SvREFCNT(sv)==0 happens very seldom */
4772 SvREFCNT(sv) = (~(U32)0)/2;
4783 Returns the length of the string in the SV. See also C<SvCUR>.
4789 Perl_sv_len(pTHX_ register SV *sv)
4798 len = mg_length(sv);
4800 junk = SvPV(sv, len);
4805 =for apidoc sv_len_utf8
4807 Returns the number of characters in the string in an SV, counting wide
4808 UTF8 bytes as a single character.
4814 Perl_sv_len_utf8(pTHX_ register SV *sv)
4820 return mg_length(sv);
4824 U8 *s = (U8*)SvPV(sv, len);
4826 return Perl_utf8_length(aTHX_ s, s + len);
4831 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4836 I32 uoffset = *offsetp;
4842 start = s = (U8*)SvPV(sv, len);
4844 while (s < send && uoffset--)
4848 *offsetp = s - start;
4852 while (s < send && ulen--)
4862 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4871 s = (U8*)SvPV(sv, len);
4873 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4874 send = s + *offsetp;
4878 /* Call utf8n_to_uvchr() to validate the sequence */
4879 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4894 Returns a boolean indicating whether the strings in the two SVs are
4901 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4915 pv1 = SvPV(sv1, cur1);
4922 pv2 = SvPV(sv2, cur2);
4924 /* do not utf8ize the comparands as a side-effect */
4925 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4926 bool is_utf8 = TRUE;
4927 /* UTF-8ness differs */
4928 if (PL_hints & HINT_UTF8_DISTINCT)
4932 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4933 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4938 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4939 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4944 /* Downgrade not possible - cannot be eq */
4950 eq = memEQ(pv1, pv2, cur1);
4961 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4962 string in C<sv1> is less than, equal to, or greater than the string in
4969 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4974 bool pv1tmp = FALSE;
4975 bool pv2tmp = FALSE;
4982 pv1 = SvPV(sv1, cur1);
4989 pv2 = SvPV(sv2, cur2);
4991 /* do not utf8ize the comparands as a side-effect */
4992 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4993 if (PL_hints & HINT_UTF8_DISTINCT)
4994 return SvUTF8(sv1) ? 1 : -1;
4997 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5001 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5007 cmp = cur2 ? -1 : 0;
5011 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5014 cmp = retval < 0 ? -1 : 1;
5015 } else if (cur1 == cur2) {
5018 cmp = cur1 < cur2 ? -1 : 1;
5031 =for apidoc sv_cmp_locale
5033 Compares the strings in two SVs in a locale-aware manner. See
5040 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5042 #ifdef USE_LOCALE_COLLATE
5048 if (PL_collation_standard)
5052 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5054 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5056 if (!pv1 || !len1) {
5067 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5070 return retval < 0 ? -1 : 1;
5073 * When the result of collation is equality, that doesn't mean
5074 * that there are no differences -- some locales exclude some
5075 * characters from consideration. So to avoid false equalities,
5076 * we use the raw string as a tiebreaker.
5082 #endif /* USE_LOCALE_COLLATE */
5084 return sv_cmp(sv1, sv2);
5087 #ifdef USE_LOCALE_COLLATE
5089 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5090 * scalar data of the variable transformed to such a format that
5091 * a normal memory comparison can be used to compare the data
5092 * according to the locale settings.
5095 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5099 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5100 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5105 Safefree(mg->mg_ptr);
5107 if ((xf = mem_collxfrm(s, len, &xlen))) {
5108 if (SvREADONLY(sv)) {
5111 return xf + sizeof(PL_collation_ix);
5114 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5115 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5128 if (mg && mg->mg_ptr) {
5130 return mg->mg_ptr + sizeof(PL_collation_ix);
5138 #endif /* USE_LOCALE_COLLATE */
5143 Get a line from the filehandle and store it into the SV, optionally
5144 appending to the currently-stored string.
5150 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5154 register STDCHAR rslast;
5155 register STDCHAR *bp;
5159 SV_CHECK_THINKFIRST(sv);
5160 (void)SvUPGRADE(sv, SVt_PV);
5164 if (RsSNARF(PL_rs)) {
5168 else if (RsRECORD(PL_rs)) {
5169 I32 recsize, bytesread;
5172 /* Grab the size of the record we're getting */
5173 recsize = SvIV(SvRV(PL_rs));
5174 (void)SvPOK_only(sv); /* Validate pointer */
5175 buffer = SvGROW(sv, recsize + 1);
5178 /* VMS wants read instead of fread, because fread doesn't respect */
5179 /* RMS record boundaries. This is not necessarily a good thing to be */
5180 /* doing, but we've got no other real choice */
5181 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5183 bytesread = PerlIO_read(fp, buffer, recsize);
5185 SvCUR_set(sv, bytesread);
5186 buffer[bytesread] = '\0';
5187 if (PerlIO_isutf8(fp))
5191 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5193 else if (RsPARA(PL_rs)) {
5198 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5199 if (PerlIO_isutf8(fp)) {
5200 rsptr = SvPVutf8(PL_rs, rslen);
5203 if (SvUTF8(PL_rs)) {
5204 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5205 Perl_croak(aTHX_ "Wide character in $/");
5208 rsptr = SvPV(PL_rs, rslen);
5212 rslast = rslen ? rsptr[rslen - 1] : '\0';
5214 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5215 do { /* to make sure file boundaries work right */
5218 i = PerlIO_getc(fp);
5222 PerlIO_ungetc(fp,i);
5228 /* See if we know enough about I/O mechanism to cheat it ! */
5230 /* This used to be #ifdef test - it is made run-time test for ease
5231 of abstracting out stdio interface. One call should be cheap
5232 enough here - and may even be a macro allowing compile
5236 if (PerlIO_fast_gets(fp)) {
5239 * We're going to steal some values from the stdio struct
5240 * and put EVERYTHING in the innermost loop into registers.
5242 register STDCHAR *ptr;
5246 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5247 /* An ungetc()d char is handled separately from the regular
5248 * buffer, so we getc() it back out and stuff it in the buffer.
5250 i = PerlIO_getc(fp);
5251 if (i == EOF) return 0;
5252 *(--((*fp)->_ptr)) = (unsigned char) i;
5256 /* Here is some breathtakingly efficient cheating */
5258 cnt = PerlIO_get_cnt(fp); /* get count into register */
5259 (void)SvPOK_only(sv); /* validate pointer */
5260 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5261 if (cnt > 80 && SvLEN(sv) > append) {
5262 shortbuffered = cnt - SvLEN(sv) + append + 1;
5263 cnt -= shortbuffered;
5267 /* remember that cnt can be negative */
5268 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5273 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5274 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5275 DEBUG_P(PerlIO_printf(Perl_debug_log,
5276 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5277 DEBUG_P(PerlIO_printf(Perl_debug_log,
5278 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5279 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5280 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5285 while (cnt > 0) { /* this | eat */
5287 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5288 goto thats_all_folks; /* screams | sed :-) */
5292 Copy(ptr, bp, cnt, char); /* this | eat */
5293 bp += cnt; /* screams | dust */
5294 ptr += cnt; /* louder | sed :-) */
5299 if (shortbuffered) { /* oh well, must extend */
5300 cnt = shortbuffered;
5302 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5304 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5305 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5309 DEBUG_P(PerlIO_printf(Perl_debug_log,
5310 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5311 PTR2UV(ptr),(long)cnt));
5312 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5313 DEBUG_P(PerlIO_printf(Perl_debug_log,
5314 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5315 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5316 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5317 /* This used to call 'filbuf' in stdio form, but as that behaves like
5318 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5319 another abstraction. */
5320 i = PerlIO_getc(fp); /* get more characters */
5321 DEBUG_P(PerlIO_printf(Perl_debug_log,
5322 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5323 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5324 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5325 cnt = PerlIO_get_cnt(fp);
5326 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5327 DEBUG_P(PerlIO_printf(Perl_debug_log,
5328 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5330 if (i == EOF) /* all done for ever? */
5331 goto thats_really_all_folks;
5333 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5335 SvGROW(sv, bpx + cnt + 2);
5336 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5338 *bp++ = i; /* store character from PerlIO_getc */
5340 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5341 goto thats_all_folks;
5345 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5346 memNE((char*)bp - rslen, rsptr, rslen))
5347 goto screamer; /* go back to the fray */
5348 thats_really_all_folks:
5350 cnt += shortbuffered;
5351 DEBUG_P(PerlIO_printf(Perl_debug_log,
5352 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5353 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5354 DEBUG_P(PerlIO_printf(Perl_debug_log,
5355 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5356 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5357 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5359 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5360 DEBUG_P(PerlIO_printf(Perl_debug_log,
5361 "Screamer: done, len=%ld, string=|%.*s|\n",
5362 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5367 /*The big, slow, and stupid way */
5370 /* Need to work around EPOC SDK features */
5371 /* On WINS: MS VC5 generates calls to _chkstk, */
5372 /* if a `large' stack frame is allocated */
5373 /* gcc on MARM does not generate calls like these */
5379 register STDCHAR *bpe = buf + sizeof(buf);
5381 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5382 ; /* keep reading */
5386 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5387 /* Accomodate broken VAXC compiler, which applies U8 cast to
5388 * both args of ?: operator, causing EOF to change into 255
5390 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5394 sv_catpvn(sv, (char *) buf, cnt);
5396 sv_setpvn(sv, (char *) buf, cnt);
5398 if (i != EOF && /* joy */
5400 SvCUR(sv) < rslen ||
5401 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5405 * If we're reading from a TTY and we get a short read,
5406 * indicating that the user hit his EOF character, we need
5407 * to notice it now, because if we try to read from the TTY
5408 * again, the EOF condition will disappear.
5410 * The comparison of cnt to sizeof(buf) is an optimization
5411 * that prevents unnecessary calls to feof().
5415 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5420 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5421 while (i != EOF) { /* to make sure file boundaries work right */
5422 i = PerlIO_getc(fp);
5424 PerlIO_ungetc(fp,i);
5430 if (PerlIO_isutf8(fp))
5435 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5442 Auto-increment of the value in the SV.
5448 Perl_sv_inc(pTHX_ register SV *sv)
5457 if (SvTHINKFIRST(sv)) {
5458 if (SvREADONLY(sv)) {
5459 if (PL_curcop != &PL_compiling)
5460 Perl_croak(aTHX_ PL_no_modify);
5464 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5466 i = PTR2IV(SvRV(sv));
5471 flags = SvFLAGS(sv);
5472 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5473 /* It's (privately or publicly) a float, but not tested as an
5474 integer, so test it to see. */
5476 flags = SvFLAGS(sv);
5478 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5479 /* It's publicly an integer, or privately an integer-not-float */
5482 if (SvUVX(sv) == UV_MAX)
5483 sv_setnv(sv, (NV)UV_MAX + 1.0);
5485 (void)SvIOK_only_UV(sv);
5488 if (SvIVX(sv) == IV_MAX)
5489 sv_setuv(sv, (UV)IV_MAX + 1);
5491 (void)SvIOK_only(sv);
5497 if (flags & SVp_NOK) {
5498 (void)SvNOK_only(sv);
5503 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5504 if ((flags & SVTYPEMASK) < SVt_PVIV)
5505 sv_upgrade(sv, SVt_IV);
5506 (void)SvIOK_only(sv);
5511 while (isALPHA(*d)) d++;
5512 while (isDIGIT(*d)) d++;
5514 #ifdef PERL_PRESERVE_IVUV
5515 /* Got to punt this an an integer if needs be, but we don't issue
5516 warnings. Probably ought to make the sv_iv_please() that does
5517 the conversion if possible, and silently. */
5518 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5519 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5520 /* Need to try really hard to see if it's an integer.
5521 9.22337203685478e+18 is an integer.
5522 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5523 so $a="9.22337203685478e+18"; $a+0; $a++
5524 needs to be the same as $a="9.22337203685478e+18"; $a++
5531 /* sv_2iv *should* have made this an NV */
5532 if (flags & SVp_NOK) {
5533 (void)SvNOK_only(sv);
5537 /* I don't think we can get here. Maybe I should assert this
5538 And if we do get here I suspect that sv_setnv will croak. NWC
5540 #if defined(USE_LONG_DOUBLE)
5541 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",
5542 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5544 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5545 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5548 #endif /* PERL_PRESERVE_IVUV */
5549 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5553 while (d >= SvPVX(sv)) {
5561 /* MKS: The original code here died if letters weren't consecutive.
5562 * at least it didn't have to worry about non-C locales. The
5563 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5564 * arranged in order (although not consecutively) and that only
5565 * [A-Za-z] are accepted by isALPHA in the C locale.
5567 if (*d != 'z' && *d != 'Z') {
5568 do { ++*d; } while (!isALPHA(*d));
5571 *(d--) -= 'z' - 'a';
5576 *(d--) -= 'z' - 'a' + 1;
5580 /* oh,oh, the number grew */
5581 SvGROW(sv, SvCUR(sv) + 2);
5583 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5594 Auto-decrement of the value in the SV.
5600 Perl_sv_dec(pTHX_ register SV *sv)
5608 if (SvTHINKFIRST(sv)) {
5609 if (SvREADONLY(sv)) {
5610 if (PL_curcop != &PL_compiling)
5611 Perl_croak(aTHX_ PL_no_modify);
5615 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5617 i = PTR2IV(SvRV(sv));
5622 /* Unlike sv_inc we don't have to worry about string-never-numbers
5623 and keeping them magic. But we mustn't warn on punting */
5624 flags = SvFLAGS(sv);
5625 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5626 /* It's publicly an integer, or privately an integer-not-float */
5629 if (SvUVX(sv) == 0) {
5630 (void)SvIOK_only(sv);
5634 (void)SvIOK_only_UV(sv);
5638 if (SvIVX(sv) == IV_MIN)
5639 sv_setnv(sv, (NV)IV_MIN - 1.0);
5641 (void)SvIOK_only(sv);
5647 if (flags & SVp_NOK) {
5649 (void)SvNOK_only(sv);
5652 if (!(flags & SVp_POK)) {
5653 if ((flags & SVTYPEMASK) < SVt_PVNV)
5654 sv_upgrade(sv, SVt_NV);
5656 (void)SvNOK_only(sv);
5659 #ifdef PERL_PRESERVE_IVUV
5661 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5662 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5663 /* Need to try really hard to see if it's an integer.
5664 9.22337203685478e+18 is an integer.
5665 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5666 so $a="9.22337203685478e+18"; $a+0; $a--
5667 needs to be the same as $a="9.22337203685478e+18"; $a--
5674 /* sv_2iv *should* have made this an NV */
5675 if (flags & SVp_NOK) {
5676 (void)SvNOK_only(sv);
5680 /* I don't think we can get here. Maybe I should assert this
5681 And if we do get here I suspect that sv_setnv will croak. NWC
5683 #if defined(USE_LONG_DOUBLE)
5684 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",
5685 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5687 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5688 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5692 #endif /* PERL_PRESERVE_IVUV */
5693 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5697 =for apidoc sv_mortalcopy
5699 Creates a new SV which is a copy of the original SV. The new SV is marked
5705 /* Make a string that will exist for the duration of the expression
5706 * evaluation. Actually, it may have to last longer than that, but
5707 * hopefully we won't free it until it has been assigned to a
5708 * permanent location. */
5711 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5716 sv_setsv(sv,oldstr);
5718 PL_tmps_stack[++PL_tmps_ix] = sv;
5724 =for apidoc sv_newmortal
5726 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5732 Perl_sv_newmortal(pTHX)
5737 SvFLAGS(sv) = SVs_TEMP;
5739 PL_tmps_stack[++PL_tmps_ix] = sv;
5744 =for apidoc sv_2mortal
5746 Marks an SV as mortal. The SV will be destroyed when the current context
5752 /* same thing without the copying */
5755 Perl_sv_2mortal(pTHX_ register SV *sv)
5759 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5762 PL_tmps_stack[++PL_tmps_ix] = sv;
5770 Creates a new SV and copies a string into it. The reference count for the
5771 SV is set to 1. If C<len> is zero, Perl will compute the length using
5772 strlen(). For efficiency, consider using C<newSVpvn> instead.
5778 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5785 sv_setpvn(sv,s,len);
5790 =for apidoc newSVpvn
5792 Creates a new SV and copies a string into it. The reference count for the
5793 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5794 string. You are responsible for ensuring that the source string is at least
5801 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5806 sv_setpvn(sv,s,len);
5811 =for apidoc newSVpvn_share
5813 Creates a new SV and populates it with a string from
5814 the string table. Turns on READONLY and FAKE.
5815 The idea here is that as string table is used for shared hash
5816 keys these strings will have SvPVX == HeKEY and hash lookup
5817 will avoid string compare.
5823 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5826 bool is_utf8 = FALSE;
5831 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5832 STRLEN tmplen = len;
5833 /* See the note in hv.c:hv_fetch() --jhi */
5834 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5838 PERL_HASH(hash, src, len);
5840 sv_upgrade(sv, SVt_PVIV);
5841 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5853 #if defined(PERL_IMPLICIT_CONTEXT)
5855 Perl_newSVpvf_nocontext(const char* pat, ...)
5860 va_start(args, pat);
5861 sv = vnewSVpvf(pat, &args);
5868 =for apidoc newSVpvf
5870 Creates a new SV an initialize it with the string formatted like
5877 Perl_newSVpvf(pTHX_ const char* pat, ...)
5881 va_start(args, pat);
5882 sv = vnewSVpvf(pat, &args);
5888 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5892 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5899 Creates a new SV and copies a floating point value into it.
5900 The reference count for the SV is set to 1.
5906 Perl_newSVnv(pTHX_ NV n)
5918 Creates a new SV and copies an integer into it. The reference count for the
5925 Perl_newSViv(pTHX_ IV i)
5937 Creates a new SV and copies an unsigned integer into it.
5938 The reference count for the SV is set to 1.
5944 Perl_newSVuv(pTHX_ UV u)
5954 =for apidoc newRV_noinc
5956 Creates an RV wrapper for an SV. The reference count for the original
5957 SV is B<not> incremented.
5963 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5968 sv_upgrade(sv, SVt_RV);
5975 /* newRV_inc is #defined to newRV in sv.h */
5977 Perl_newRV(pTHX_ SV *tmpRef)
5979 return newRV_noinc(SvREFCNT_inc(tmpRef));
5985 Creates a new SV which is an exact duplicate of the original SV.
5990 /* make an exact duplicate of old */
5993 Perl_newSVsv(pTHX_ register SV *old)
5999 if (SvTYPE(old) == SVTYPEMASK) {
6000 if (ckWARN_d(WARN_INTERNAL))
6001 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6016 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6024 char todo[PERL_UCHAR_MAX+1];
6029 if (!*s) { /* reset ?? searches */
6030 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6031 pm->op_pmdynflags &= ~PMdf_USED;
6036 /* reset variables */
6038 if (!HvARRAY(stash))
6041 Zero(todo, 256, char);
6043 i = (unsigned char)*s;
6047 max = (unsigned char)*s++;
6048 for ( ; i <= max; i++) {
6051 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6052 for (entry = HvARRAY(stash)[i];
6054 entry = HeNEXT(entry))
6056 if (!todo[(U8)*HeKEY(entry)])
6058 gv = (GV*)HeVAL(entry);
6060 if (SvTHINKFIRST(sv)) {
6061 if (!SvREADONLY(sv) && SvROK(sv))
6066 if (SvTYPE(sv) >= SVt_PV) {
6068 if (SvPVX(sv) != Nullch)
6075 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6077 #ifdef USE_ENVIRON_ARRAY
6079 environ[0] = Nullch;
6088 Perl_sv_2io(pTHX_ SV *sv)
6094 switch (SvTYPE(sv)) {
6102 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6106 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6108 return sv_2io(SvRV(sv));
6109 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6115 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6122 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6129 return *gvp = Nullgv, Nullcv;
6130 switch (SvTYPE(sv)) {
6149 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6150 tryAMAGICunDEREF(to_cv);
6153 if (SvTYPE(sv) == SVt_PVCV) {
6162 Perl_croak(aTHX_ "Not a subroutine reference");
6167 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6173 if (lref && !GvCVu(gv)) {
6176 tmpsv = NEWSV(704,0);
6177 gv_efullname3(tmpsv, gv, Nullch);
6178 /* XXX this is probably not what they think they're getting.
6179 * It has the same effect as "sub name;", i.e. just a forward
6181 newSUB(start_subparse(FALSE, 0),
6182 newSVOP(OP_CONST, 0, tmpsv),
6187 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6196 Returns true if the SV has a true value by Perl's rules.
6202 Perl_sv_true(pTHX_ register SV *sv)
6208 if ((tXpv = (XPV*)SvANY(sv)) &&
6209 (tXpv->xpv_cur > 1 ||
6210 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6217 return SvIVX(sv) != 0;
6220 return SvNVX(sv) != 0.0;
6222 return sv_2bool(sv);
6228 Perl_sv_iv(pTHX_ register SV *sv)
6232 return (IV)SvUVX(sv);
6239 Perl_sv_uv(pTHX_ register SV *sv)
6244 return (UV)SvIVX(sv);
6250 Perl_sv_nv(pTHX_ register SV *sv)
6258 Perl_sv_pv(pTHX_ SV *sv)
6265 return sv_2pv(sv, &n_a);
6269 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6275 return sv_2pv(sv, lp);
6279 =for apidoc sv_pvn_force
6281 Get a sensible string out of the SV somehow.
6287 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6289 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6293 =for apidoc sv_pvn_force_flags
6295 Get a sensible string out of the SV somehow.
6296 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6297 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6298 implemented in terms of this function.
6304 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6308 if (SvTHINKFIRST(sv) && !SvROK(sv))
6309 sv_force_normal(sv);
6315 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6316 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6317 PL_op_name[PL_op->op_type]);
6320 s = sv_2pv_flags(sv, lp, flags);
6321 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6326 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6327 SvGROW(sv, len + 1);
6328 Move(s,SvPVX(sv),len,char);
6333 SvPOK_on(sv); /* validate pointer */
6335 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6336 PTR2UV(sv),SvPVX(sv)));
6343 Perl_sv_pvbyte(pTHX_ SV *sv)
6345 sv_utf8_downgrade(sv,0);
6350 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6352 sv_utf8_downgrade(sv,0);
6353 return sv_pvn(sv,lp);
6357 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6359 sv_utf8_downgrade(sv,0);
6360 return sv_pvn_force(sv,lp);
6364 Perl_sv_pvutf8(pTHX_ SV *sv)
6366 sv_utf8_upgrade(sv);
6371 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6373 sv_utf8_upgrade(sv);
6374 return sv_pvn(sv,lp);
6378 =for apidoc sv_pvutf8n_force
6380 Get a sensible UTF8-encoded string out of the SV somehow. See
6387 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6389 sv_utf8_upgrade(sv);
6390 return sv_pvn_force(sv,lp);
6394 =for apidoc sv_reftype
6396 Returns a string describing what the SV is a reference to.
6402 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6404 if (ob && SvOBJECT(sv))
6405 return HvNAME(SvSTASH(sv));
6407 switch (SvTYPE(sv)) {
6421 case SVt_PVLV: return "LVALUE";
6422 case SVt_PVAV: return "ARRAY";
6423 case SVt_PVHV: return "HASH";
6424 case SVt_PVCV: return "CODE";
6425 case SVt_PVGV: return "GLOB";
6426 case SVt_PVFM: return "FORMAT";
6427 case SVt_PVIO: return "IO";
6428 default: return "UNKNOWN";
6434 =for apidoc sv_isobject
6436 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6437 object. If the SV is not an RV, or if the object is not blessed, then this
6444 Perl_sv_isobject(pTHX_ SV *sv)
6461 Returns a boolean indicating whether the SV is blessed into the specified
6462 class. This does not check for subtypes; use C<sv_derived_from> to verify
6463 an inheritance relationship.
6469 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6481 return strEQ(HvNAME(SvSTASH(sv)), name);
6487 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6488 it will be upgraded to one. If C<classname> is non-null then the new SV will
6489 be blessed in the specified package. The new SV is returned and its
6490 reference count is 1.
6496 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6502 SV_CHECK_THINKFIRST(rv);
6505 if (SvTYPE(rv) >= SVt_PVMG) {
6506 U32 refcnt = SvREFCNT(rv);
6510 SvREFCNT(rv) = refcnt;
6513 if (SvTYPE(rv) < SVt_RV)
6514 sv_upgrade(rv, SVt_RV);
6515 else if (SvTYPE(rv) > SVt_RV) {
6516 (void)SvOOK_off(rv);
6517 if (SvPVX(rv) && SvLEN(rv))
6518 Safefree(SvPVX(rv));
6528 HV* stash = gv_stashpv(classname, TRUE);
6529 (void)sv_bless(rv, stash);
6535 =for apidoc sv_setref_pv
6537 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6538 argument will be upgraded to an RV. That RV will be modified to point to
6539 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6540 into the SV. The C<classname> argument indicates the package for the
6541 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6542 will be returned and will have a reference count of 1.
6544 Do not use with other Perl types such as HV, AV, SV, CV, because those
6545 objects will become corrupted by the pointer copy process.
6547 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6553 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6556 sv_setsv(rv, &PL_sv_undef);
6560 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6565 =for apidoc sv_setref_iv
6567 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6568 argument will be upgraded to an RV. That RV will be modified to point to
6569 the new SV. The C<classname> argument indicates the package for the
6570 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6571 will be returned and will have a reference count of 1.
6577 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6579 sv_setiv(newSVrv(rv,classname), iv);
6584 =for apidoc sv_setref_uv
6586 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6587 argument will be upgraded to an RV. That RV will be modified to point to
6588 the new SV. The C<classname> argument indicates the package for the
6589 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6590 will be returned and will have a reference count of 1.
6596 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6598 sv_setuv(newSVrv(rv,classname), uv);
6603 =for apidoc sv_setref_nv
6605 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6606 argument will be upgraded to an RV. That RV will be modified to point to
6607 the new SV. The C<classname> argument indicates the package for the
6608 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6609 will be returned and will have a reference count of 1.
6615 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6617 sv_setnv(newSVrv(rv,classname), nv);
6622 =for apidoc sv_setref_pvn
6624 Copies a string into a new SV, optionally blessing the SV. The length of the
6625 string must be specified with C<n>. The C<rv> argument will be upgraded to
6626 an RV. That RV will be modified to point to the new SV. The C<classname>
6627 argument indicates the package for the blessing. Set C<classname> to
6628 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6629 a reference count of 1.
6631 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6637 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6639 sv_setpvn(newSVrv(rv,classname), pv, n);
6644 =for apidoc sv_bless
6646 Blesses an SV into a specified package. The SV must be an RV. The package
6647 must be designated by its stash (see C<gv_stashpv()>). The reference count
6648 of the SV is unaffected.
6654 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6658 Perl_croak(aTHX_ "Can't bless non-reference value");
6660 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6661 if (SvREADONLY(tmpRef))
6662 Perl_croak(aTHX_ PL_no_modify);
6663 if (SvOBJECT(tmpRef)) {
6664 if (SvTYPE(tmpRef) != SVt_PVIO)
6666 SvREFCNT_dec(SvSTASH(tmpRef));
6669 SvOBJECT_on(tmpRef);
6670 if (SvTYPE(tmpRef) != SVt_PVIO)
6672 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6673 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6684 S_sv_unglob(pTHX_ SV *sv)
6688 assert(SvTYPE(sv) == SVt_PVGV);
6693 SvREFCNT_dec(GvSTASH(sv));
6694 GvSTASH(sv) = Nullhv;
6696 sv_unmagic(sv, PERL_MAGIC_glob);
6697 Safefree(GvNAME(sv));
6700 /* need to keep SvANY(sv) in the right arena */
6701 xpvmg = new_XPVMG();
6702 StructCopy(SvANY(sv), xpvmg, XPVMG);
6703 del_XPVGV(SvANY(sv));
6706 SvFLAGS(sv) &= ~SVTYPEMASK;
6707 SvFLAGS(sv) |= SVt_PVMG;
6711 =for apidoc sv_unref_flags
6713 Unsets the RV status of the SV, and decrements the reference count of
6714 whatever was being referenced by the RV. This can almost be thought of
6715 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6716 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6717 (otherwise the decrementing is conditional on the reference count being
6718 different from one or the reference being a readonly SV).
6725 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6729 if (SvWEAKREF(sv)) {
6737 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6739 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6740 sv_2mortal(rv); /* Schedule for freeing later */
6744 =for apidoc sv_unref
6746 Unsets the RV status of the SV, and decrements the reference count of
6747 whatever was being referenced by the RV. This can almost be thought of
6748 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6749 being zero. See C<SvROK_off>.
6755 Perl_sv_unref(pTHX_ SV *sv)
6757 sv_unref_flags(sv, 0);
6761 Perl_sv_taint(pTHX_ SV *sv)
6763 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6767 Perl_sv_untaint(pTHX_ SV *sv)
6769 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6770 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6777 Perl_sv_tainted(pTHX_ SV *sv)
6779 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6780 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6781 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6788 =for apidoc sv_setpviv
6790 Copies an integer into the given SV, also updating its string value.
6791 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6797 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6799 char buf[TYPE_CHARS(UV)];
6801 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6803 sv_setpvn(sv, ptr, ebuf - ptr);
6808 =for apidoc sv_setpviv_mg
6810 Like C<sv_setpviv>, but also handles 'set' magic.
6816 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6818 char buf[TYPE_CHARS(UV)];
6820 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6822 sv_setpvn(sv, ptr, ebuf - ptr);
6826 #if defined(PERL_IMPLICIT_CONTEXT)
6828 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6832 va_start(args, pat);
6833 sv_vsetpvf(sv, pat, &args);
6839 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6843 va_start(args, pat);
6844 sv_vsetpvf_mg(sv, pat, &args);
6850 =for apidoc sv_setpvf
6852 Processes its arguments like C<sprintf> and sets an SV to the formatted
6853 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6859 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6862 va_start(args, pat);
6863 sv_vsetpvf(sv, pat, &args);
6868 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6870 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6874 =for apidoc sv_setpvf_mg
6876 Like C<sv_setpvf>, but also handles 'set' magic.
6882 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6885 va_start(args, pat);
6886 sv_vsetpvf_mg(sv, pat, &args);
6891 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6893 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6897 #if defined(PERL_IMPLICIT_CONTEXT)
6899 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6903 va_start(args, pat);
6904 sv_vcatpvf(sv, pat, &args);
6909 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6913 va_start(args, pat);
6914 sv_vcatpvf_mg(sv, pat, &args);
6920 =for apidoc sv_catpvf
6922 Processes its arguments like C<sprintf> and appends the formatted
6923 output to an SV. If the appended data contains "wide" characters
6924 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6925 and characters >255 formatted with %c), the original SV might get
6926 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6927 C<SvSETMAGIC()> must typically be called after calling this function
6928 to handle 'set' magic.
6933 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6936 va_start(args, pat);
6937 sv_vcatpvf(sv, pat, &args);
6942 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6944 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6948 =for apidoc sv_catpvf_mg
6950 Like C<sv_catpvf>, but also handles 'set' magic.
6956 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6959 va_start(args, pat);
6960 sv_vcatpvf_mg(sv, pat, &args);
6965 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6967 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6972 =for apidoc sv_vsetpvfn
6974 Works like C<vcatpvfn> but copies the text into the SV instead of
6981 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6983 sv_setpvn(sv, "", 0);
6984 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6988 S_expect_number(pTHX_ char** pattern)
6991 switch (**pattern) {
6992 case '1': case '2': case '3':
6993 case '4': case '5': case '6':
6994 case '7': case '8': case '9':
6995 while (isDIGIT(**pattern))
6996 var = var * 10 + (*(*pattern)++ - '0');
7000 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7003 =for apidoc sv_vcatpvfn
7005 Processes its arguments like C<vsprintf> and appends the formatted output
7006 to an SV. Uses an array of SVs if the C style variable argument list is
7007 missing (NULL). When running with taint checks enabled, indicates via
7008 C<maybe_tainted> if results are untrustworthy (often due to the use of
7015 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7022 static char nullstr[] = "(null)";
7025 /* no matter what, this is a string now */
7026 (void)SvPV_force(sv, origlen);
7028 /* special-case "", "%s", and "%_" */
7031 if (patlen == 2 && pat[0] == '%') {
7035 char *s = va_arg(*args, char*);
7036 sv_catpv(sv, s ? s : nullstr);
7038 else if (svix < svmax) {
7039 sv_catsv(sv, *svargs);
7040 if (DO_UTF8(*svargs))
7046 argsv = va_arg(*args, SV*);
7047 sv_catsv(sv, argsv);
7052 /* See comment on '_' below */
7057 patend = (char*)pat + patlen;
7058 for (p = (char*)pat; p < patend; p = q) {
7061 bool vectorize = FALSE;
7062 bool vectorarg = FALSE;
7063 bool vec_utf = FALSE;
7069 bool has_precis = FALSE;
7071 bool is_utf = FALSE;
7074 U8 utf8buf[UTF8_MAXLEN+1];
7075 STRLEN esignlen = 0;
7077 char *eptr = Nullch;
7079 /* Times 4: a decimal digit takes more than 3 binary digits.
7080 * NV_DIG: mantissa takes than many decimal digits.
7081 * Plus 32: Playing safe. */
7082 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7083 /* large enough for "%#.#f" --chip */
7084 /* what about long double NVs? --jhi */
7087 U8 *vecstr = Null(U8*);
7099 STRLEN dotstrlen = 1;
7100 I32 efix = 0; /* explicit format parameter index */
7101 I32 ewix = 0; /* explicit width index */
7102 I32 epix = 0; /* explicit precision index */
7103 I32 evix = 0; /* explicit vector index */
7104 bool asterisk = FALSE;
7106 /* echo everything up to the next format specification */
7107 for (q = p; q < patend && *q != '%'; ++q) ;
7109 sv_catpvn(sv, p, q - p);
7116 We allow format specification elements in this order:
7117 \d+\$ explicit format parameter index
7119 \*?(\d+\$)?v vector with optional (optionally specified) arg
7120 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7121 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7123 [%bcdefginopsux_DFOUX] format (mandatory)
7125 if (EXPECT_NUMBER(q, width)) {
7166 if (EXPECT_NUMBER(q, ewix))
7175 if ((vectorarg = asterisk)) {
7185 EXPECT_NUMBER(q, width);
7190 vecsv = va_arg(*args, SV*);
7192 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7193 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7194 dotstr = SvPVx(vecsv, dotstrlen);
7199 vecsv = va_arg(*args, SV*);
7200 vecstr = (U8*)SvPVx(vecsv,veclen);
7201 vec_utf = DO_UTF8(vecsv);
7203 else if (efix ? efix <= svmax : svix < svmax) {
7204 vecsv = svargs[efix ? efix-1 : svix++];
7205 vecstr = (U8*)SvPVx(vecsv,veclen);
7206 vec_utf = DO_UTF8(vecsv);
7216 i = va_arg(*args, int);
7218 i = (ewix ? ewix <= svmax : svix < svmax) ?
7219 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7221 width = (i < 0) ? -i : i;
7231 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7234 i = va_arg(*args, int);
7236 i = (ewix ? ewix <= svmax : svix < svmax)
7237 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7238 precis = (i < 0) ? 0 : i;
7243 precis = precis * 10 + (*q++ - '0');
7251 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7262 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7263 if (*(q + 1) == 'l') { /* lld, llf */
7286 argsv = (efix ? efix <= svmax : svix < svmax) ?
7287 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7294 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7296 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7298 eptr = (char*)utf8buf;
7299 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7311 eptr = va_arg(*args, char*);
7313 #ifdef MACOS_TRADITIONAL
7314 /* On MacOS, %#s format is used for Pascal strings */
7319 elen = strlen(eptr);
7322 elen = sizeof nullstr - 1;
7326 eptr = SvPVx(argsv, elen);
7327 if (DO_UTF8(argsv)) {
7328 if (has_precis && precis < elen) {
7330 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7333 if (width) { /* fudge width (can't fudge elen) */
7334 width += elen - sv_len_utf8(argsv);
7343 * The "%_" hack might have to be changed someday,
7344 * if ISO or ANSI decide to use '_' for something.
7345 * So we keep it hidden from users' code.
7349 argsv = va_arg(*args, SV*);
7350 eptr = SvPVx(argsv, elen);
7356 if (has_precis && elen > precis)
7365 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7383 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7393 case 'h': iv = (short)va_arg(*args, int); break;
7394 default: iv = va_arg(*args, int); break;
7395 case 'l': iv = va_arg(*args, long); break;
7396 case 'V': iv = va_arg(*args, IV); break;
7398 case 'q': iv = va_arg(*args, Quad_t); break;
7405 case 'h': iv = (short)iv; break;
7407 case 'l': iv = (long)iv; break;
7410 case 'q': iv = (Quad_t)iv; break;
7417 esignbuf[esignlen++] = plus;
7421 esignbuf[esignlen++] = '-';
7463 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7473 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7474 default: uv = va_arg(*args, unsigned); break;
7475 case 'l': uv = va_arg(*args, unsigned long); break;
7476 case 'V': uv = va_arg(*args, UV); break;
7478 case 'q': uv = va_arg(*args, Quad_t); break;
7485 case 'h': uv = (unsigned short)uv; break;
7487 case 'l': uv = (unsigned long)uv; break;
7490 case 'q': uv = (Quad_t)uv; break;
7496 eptr = ebuf + sizeof ebuf;
7502 p = (char*)((c == 'X')
7503 ? "0123456789ABCDEF" : "0123456789abcdef");
7509 esignbuf[esignlen++] = '0';
7510 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7516 *--eptr = '0' + dig;
7518 if (alt && *eptr != '0')
7524 *--eptr = '0' + dig;
7527 esignbuf[esignlen++] = '0';
7528 esignbuf[esignlen++] = 'b';
7531 default: /* it had better be ten or less */
7532 #if defined(PERL_Y2KWARN)
7533 if (ckWARN(WARN_Y2K)) {
7535 char *s = SvPV(sv,n);
7536 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7537 && (n == 2 || !isDIGIT(s[n-3])))
7539 Perl_warner(aTHX_ WARN_Y2K,
7540 "Possible Y2K bug: %%%c %s",
7541 c, "format string following '19'");
7547 *--eptr = '0' + dig;
7548 } while (uv /= base);
7551 elen = (ebuf + sizeof ebuf) - eptr;
7554 zeros = precis - elen;
7555 else if (precis == 0 && elen == 1 && *eptr == '0')
7560 /* FLOATING POINT */
7563 c = 'f'; /* maybe %F isn't supported here */
7569 /* This is evil, but floating point is even more evil */
7572 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7575 if (c != 'e' && c != 'E') {
7577 (void)Perl_frexp(nv, &i);
7578 if (i == PERL_INT_MIN)
7579 Perl_die(aTHX_ "panic: frexp");
7581 need = BIT_DIGITS(i);
7583 need += has_precis ? precis : 6; /* known default */
7587 need += 20; /* fudge factor */
7588 if (PL_efloatsize < need) {
7589 Safefree(PL_efloatbuf);
7590 PL_efloatsize = need + 20; /* more fudge */
7591 New(906, PL_efloatbuf, PL_efloatsize, char);
7592 PL_efloatbuf[0] = '\0';
7595 eptr = ebuf + sizeof ebuf;
7598 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7600 /* Copy the one or more characters in a long double
7601 * format before the 'base' ([efgEFG]) character to
7602 * the format string. */
7603 static char const prifldbl[] = PERL_PRIfldbl;
7604 char const *p = prifldbl + sizeof(prifldbl) - 3;
7605 while (p >= prifldbl) { *--eptr = *p--; }
7610 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7615 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7627 /* No taint. Otherwise we are in the strange situation
7628 * where printf() taints but print($float) doesn't.
7630 (void)sprintf(PL_efloatbuf, eptr, nv);
7632 eptr = PL_efloatbuf;
7633 elen = strlen(PL_efloatbuf);
7640 i = SvCUR(sv) - origlen;
7643 case 'h': *(va_arg(*args, short*)) = i; break;
7644 default: *(va_arg(*args, int*)) = i; break;
7645 case 'l': *(va_arg(*args, long*)) = i; break;
7646 case 'V': *(va_arg(*args, IV*)) = i; break;
7648 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7653 sv_setuv_mg(argsv, (UV)i);
7654 continue; /* not "break" */
7661 if (!args && ckWARN(WARN_PRINTF) &&
7662 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7663 SV *msg = sv_newmortal();
7664 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7665 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7668 Perl_sv_catpvf(aTHX_ msg,
7669 "\"%%%c\"", c & 0xFF);
7671 Perl_sv_catpvf(aTHX_ msg,
7672 "\"%%\\%03"UVof"\"",
7675 sv_catpv(msg, "end of string");
7676 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7679 /* output mangled stuff ... */
7685 /* ... right here, because formatting flags should not apply */
7686 SvGROW(sv, SvCUR(sv) + elen + 1);
7688 Copy(eptr, p, elen, char);
7691 SvCUR(sv) = p - SvPVX(sv);
7692 continue; /* not "break" */
7695 have = esignlen + zeros + elen;
7696 need = (have > width ? have : width);
7699 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7701 if (esignlen && fill == '0') {
7702 for (i = 0; i < esignlen; i++)
7706 memset(p, fill, gap);
7709 if (esignlen && fill != '0') {
7710 for (i = 0; i < esignlen; i++)
7714 for (i = zeros; i; i--)
7718 Copy(eptr, p, elen, char);
7722 memset(p, ' ', gap);
7727 Copy(dotstr, p, dotstrlen, char);
7731 vectorize = FALSE; /* done iterating over vecstr */
7736 SvCUR(sv) = p - SvPVX(sv);
7744 #if defined(USE_ITHREADS)
7746 #if defined(USE_THREADS)
7747 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7750 #ifndef GpREFCNT_inc
7751 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7755 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7756 #define av_dup(s) (AV*)sv_dup((SV*)s)
7757 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7758 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7759 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7760 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7761 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7762 #define io_dup(s) (IO*)sv_dup((SV*)s)
7763 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7764 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7765 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7766 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7767 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7770 Perl_re_dup(pTHX_ REGEXP *r)
7772 /* XXX fix when pmop->op_pmregexp becomes shared */
7773 return ReREFCNT_inc(r);
7777 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7781 return (PerlIO*)NULL;
7783 /* look for it in the table first */
7784 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7788 /* create anew and remember what it is */
7789 ret = PerlIO_fdupopen(aTHX_ fp);
7790 ptr_table_store(PL_ptr_table, fp, ret);
7795 Perl_dirp_dup(pTHX_ DIR *dp)
7804 Perl_gp_dup(pTHX_ GP *gp)
7809 /* look for it in the table first */
7810 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7814 /* create anew and remember what it is */
7815 Newz(0, ret, 1, GP);
7816 ptr_table_store(PL_ptr_table, gp, ret);
7819 ret->gp_refcnt = 0; /* must be before any other dups! */
7820 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7821 ret->gp_io = io_dup_inc(gp->gp_io);
7822 ret->gp_form = cv_dup_inc(gp->gp_form);
7823 ret->gp_av = av_dup_inc(gp->gp_av);
7824 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7825 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7826 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7827 ret->gp_cvgen = gp->gp_cvgen;
7828 ret->gp_flags = gp->gp_flags;
7829 ret->gp_line = gp->gp_line;
7830 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7835 Perl_mg_dup(pTHX_ MAGIC *mg)
7837 MAGIC *mgprev = (MAGIC*)NULL;
7840 return (MAGIC*)NULL;
7841 /* look for it in the table first */
7842 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7846 for (; mg; mg = mg->mg_moremagic) {
7848 Newz(0, nmg, 1, MAGIC);
7850 mgprev->mg_moremagic = nmg;
7853 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7854 nmg->mg_private = mg->mg_private;
7855 nmg->mg_type = mg->mg_type;
7856 nmg->mg_flags = mg->mg_flags;
7857 if (mg->mg_type == PERL_MAGIC_qr) {
7858 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7861 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7862 ? sv_dup_inc(mg->mg_obj)
7863 : sv_dup(mg->mg_obj);
7865 nmg->mg_len = mg->mg_len;
7866 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7867 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7868 if (mg->mg_len >= 0) {
7869 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7870 if (mg->mg_type == PERL_MAGIC_overload_table &&
7871 AMT_AMAGIC((AMT*)mg->mg_ptr))
7873 AMT *amtp = (AMT*)mg->mg_ptr;
7874 AMT *namtp = (AMT*)nmg->mg_ptr;
7876 for (i = 1; i < NofAMmeth; i++) {
7877 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7881 else if (mg->mg_len == HEf_SVKEY)
7882 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7890 Perl_ptr_table_new(pTHX)
7893 Newz(0, tbl, 1, PTR_TBL_t);
7896 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7901 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7903 PTR_TBL_ENT_t *tblent;
7904 UV hash = PTR2UV(sv);
7906 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7907 for (; tblent; tblent = tblent->next) {
7908 if (tblent->oldval == sv)
7909 return tblent->newval;
7915 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7917 PTR_TBL_ENT_t *tblent, **otblent;
7918 /* XXX this may be pessimal on platforms where pointers aren't good
7919 * hash values e.g. if they grow faster in the most significant
7921 UV hash = PTR2UV(oldv);
7925 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7926 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7927 if (tblent->oldval == oldv) {
7928 tblent->newval = newv;
7933 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7934 tblent->oldval = oldv;
7935 tblent->newval = newv;
7936 tblent->next = *otblent;
7939 if (i && tbl->tbl_items > tbl->tbl_max)
7940 ptr_table_split(tbl);
7944 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7946 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7947 UV oldsize = tbl->tbl_max + 1;
7948 UV newsize = oldsize * 2;
7951 Renew(ary, newsize, PTR_TBL_ENT_t*);
7952 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7953 tbl->tbl_max = --newsize;
7955 for (i=0; i < oldsize; i++, ary++) {
7956 PTR_TBL_ENT_t **curentp, **entp, *ent;
7959 curentp = ary + oldsize;
7960 for (entp = ary, ent = *ary; ent; ent = *entp) {
7961 if ((newsize & PTR2UV(ent->oldval)) != i) {
7963 ent->next = *curentp;
7974 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7976 register PTR_TBL_ENT_t **array;
7977 register PTR_TBL_ENT_t *entry;
7978 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7982 if (!tbl || !tbl->tbl_items) {
7986 array = tbl->tbl_ary;
7993 entry = entry->next;
7997 if (++riter > max) {
8000 entry = array[riter];
8008 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8013 ptr_table_clear(tbl);
8014 Safefree(tbl->tbl_ary);
8023 S_gv_share(pTHX_ SV *sstr)
8026 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8028 if (GvIO(gv) || GvFORM(gv)) {
8029 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8031 else if (!GvCV(gv)) {
8035 /* CvPADLISTs cannot be shared */
8036 if (!CvXSUB(GvCV(gv))) {
8041 if (!GvSHARED(gv)) {
8043 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8044 HvNAME(GvSTASH(gv)), GvNAME(gv));
8050 * write attempts will die with
8051 * "Modification of a read-only value attempted"
8057 SvREADONLY_on(GvSV(gv));
8064 SvREADONLY_on(GvAV(gv));
8071 SvREADONLY_on(GvAV(gv));
8074 return sstr; /* he_dup() will SvREFCNT_inc() */
8078 Perl_sv_dup(pTHX_ SV *sstr)
8082 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8084 /* look for it in the table first */
8085 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8089 /* create anew and remember what it is */
8091 ptr_table_store(PL_ptr_table, sstr, dstr);
8094 SvFLAGS(dstr) = SvFLAGS(sstr);
8095 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8096 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8099 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8100 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8101 PL_watch_pvx, SvPVX(sstr));
8104 switch (SvTYPE(sstr)) {
8109 SvANY(dstr) = new_XIV();
8110 SvIVX(dstr) = SvIVX(sstr);
8113 SvANY(dstr) = new_XNV();
8114 SvNVX(dstr) = SvNVX(sstr);
8117 SvANY(dstr) = new_XRV();
8118 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8119 ? sv_dup(SvRV(sstr))
8120 : sv_dup_inc(SvRV(sstr));
8123 SvANY(dstr) = new_XPV();
8124 SvCUR(dstr) = SvCUR(sstr);
8125 SvLEN(dstr) = SvLEN(sstr);
8127 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8128 ? sv_dup(SvRV(sstr))
8129 : sv_dup_inc(SvRV(sstr));
8130 else if (SvPVX(sstr) && SvLEN(sstr))
8131 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8133 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8136 SvANY(dstr) = new_XPVIV();
8137 SvCUR(dstr) = SvCUR(sstr);
8138 SvLEN(dstr) = SvLEN(sstr);
8139 SvIVX(dstr) = SvIVX(sstr);
8141 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8142 ? sv_dup(SvRV(sstr))
8143 : sv_dup_inc(SvRV(sstr));
8144 else if (SvPVX(sstr) && SvLEN(sstr))
8145 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8147 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8150 SvANY(dstr) = new_XPVNV();
8151 SvCUR(dstr) = SvCUR(sstr);
8152 SvLEN(dstr) = SvLEN(sstr);
8153 SvIVX(dstr) = SvIVX(sstr);
8154 SvNVX(dstr) = SvNVX(sstr);
8156 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8157 ? sv_dup(SvRV(sstr))
8158 : sv_dup_inc(SvRV(sstr));
8159 else if (SvPVX(sstr) && SvLEN(sstr))
8160 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8162 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8165 SvANY(dstr) = new_XPVMG();
8166 SvCUR(dstr) = SvCUR(sstr);
8167 SvLEN(dstr) = SvLEN(sstr);
8168 SvIVX(dstr) = SvIVX(sstr);
8169 SvNVX(dstr) = SvNVX(sstr);
8170 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8171 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8173 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8174 ? sv_dup(SvRV(sstr))
8175 : sv_dup_inc(SvRV(sstr));
8176 else if (SvPVX(sstr) && SvLEN(sstr))
8177 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8179 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8182 SvANY(dstr) = new_XPVBM();
8183 SvCUR(dstr) = SvCUR(sstr);
8184 SvLEN(dstr) = SvLEN(sstr);
8185 SvIVX(dstr) = SvIVX(sstr);
8186 SvNVX(dstr) = SvNVX(sstr);
8187 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8188 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8190 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8191 ? sv_dup(SvRV(sstr))
8192 : sv_dup_inc(SvRV(sstr));
8193 else if (SvPVX(sstr) && SvLEN(sstr))
8194 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8196 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8197 BmRARE(dstr) = BmRARE(sstr);
8198 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8199 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8202 SvANY(dstr) = new_XPVLV();
8203 SvCUR(dstr) = SvCUR(sstr);
8204 SvLEN(dstr) = SvLEN(sstr);
8205 SvIVX(dstr) = SvIVX(sstr);
8206 SvNVX(dstr) = SvNVX(sstr);
8207 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8208 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8210 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8211 ? sv_dup(SvRV(sstr))
8212 : sv_dup_inc(SvRV(sstr));
8213 else if (SvPVX(sstr) && SvLEN(sstr))
8214 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8216 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8217 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8218 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8219 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8220 LvTYPE(dstr) = LvTYPE(sstr);
8223 if (GvSHARED((GV*)sstr)) {
8225 if ((share = gv_share(sstr))) {
8229 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8230 HvNAME(GvSTASH(share)), GvNAME(share));
8235 SvANY(dstr) = new_XPVGV();
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));
8243 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8244 ? sv_dup(SvRV(sstr))
8245 : sv_dup_inc(SvRV(sstr));
8246 else if (SvPVX(sstr) && SvLEN(sstr))
8247 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8249 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8250 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8251 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8252 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8253 GvFLAGS(dstr) = GvFLAGS(sstr);
8254 GvGP(dstr) = gp_dup(GvGP(sstr));
8255 (void)GpREFCNT_inc(GvGP(dstr));
8258 SvANY(dstr) = new_XPVIO();
8259 SvCUR(dstr) = SvCUR(sstr);
8260 SvLEN(dstr) = SvLEN(sstr);
8261 SvIVX(dstr) = SvIVX(sstr);
8262 SvNVX(dstr) = SvNVX(sstr);
8263 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8264 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8266 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8267 ? sv_dup(SvRV(sstr))
8268 : sv_dup_inc(SvRV(sstr));
8269 else if (SvPVX(sstr) && SvLEN(sstr))
8270 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8272 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8273 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8274 if (IoOFP(sstr) == IoIFP(sstr))
8275 IoOFP(dstr) = IoIFP(dstr);
8277 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8278 /* PL_rsfp_filters entries have fake IoDIRP() */
8279 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8280 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8282 IoDIRP(dstr) = IoDIRP(sstr);
8283 IoLINES(dstr) = IoLINES(sstr);
8284 IoPAGE(dstr) = IoPAGE(sstr);
8285 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8286 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8287 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8288 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8289 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8290 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8291 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8292 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8293 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8294 IoTYPE(dstr) = IoTYPE(sstr);
8295 IoFLAGS(dstr) = IoFLAGS(sstr);
8298 SvANY(dstr) = new_XPVAV();
8299 SvCUR(dstr) = SvCUR(sstr);
8300 SvLEN(dstr) = SvLEN(sstr);
8301 SvIVX(dstr) = SvIVX(sstr);
8302 SvNVX(dstr) = SvNVX(sstr);
8303 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8304 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8305 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8306 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8307 if (AvARRAY((AV*)sstr)) {
8308 SV **dst_ary, **src_ary;
8309 SSize_t items = AvFILLp((AV*)sstr) + 1;
8311 src_ary = AvARRAY((AV*)sstr);
8312 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8313 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8314 SvPVX(dstr) = (char*)dst_ary;
8315 AvALLOC((AV*)dstr) = dst_ary;
8316 if (AvREAL((AV*)sstr)) {
8318 *dst_ary++ = sv_dup_inc(*src_ary++);
8322 *dst_ary++ = sv_dup(*src_ary++);
8324 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8325 while (items-- > 0) {
8326 *dst_ary++ = &PL_sv_undef;
8330 SvPVX(dstr) = Nullch;
8331 AvALLOC((AV*)dstr) = (SV**)NULL;
8335 SvANY(dstr) = new_XPVHV();
8336 SvCUR(dstr) = SvCUR(sstr);
8337 SvLEN(dstr) = SvLEN(sstr);
8338 SvIVX(dstr) = SvIVX(sstr);
8339 SvNVX(dstr) = SvNVX(sstr);
8340 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8341 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8342 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8343 if (HvARRAY((HV*)sstr)) {
8345 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8346 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8347 Newz(0, dxhv->xhv_array,
8348 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8349 while (i <= sxhv->xhv_max) {
8350 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8351 !!HvSHAREKEYS(sstr));
8354 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8357 SvPVX(dstr) = Nullch;
8358 HvEITER((HV*)dstr) = (HE*)NULL;
8360 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8361 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8362 if(HvNAME((HV*)dstr))
8363 av_push(PL_clone_callbacks,dstr);
8366 SvANY(dstr) = new_XPVFM();
8367 FmLINES(dstr) = FmLINES(sstr);
8371 SvANY(dstr) = new_XPVCV();
8373 SvCUR(dstr) = SvCUR(sstr);
8374 SvLEN(dstr) = SvLEN(sstr);
8375 SvIVX(dstr) = SvIVX(sstr);
8376 SvNVX(dstr) = SvNVX(sstr);
8377 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8378 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8379 if (SvPVX(sstr) && SvLEN(sstr))
8380 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8382 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8383 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8384 CvSTART(dstr) = CvSTART(sstr);
8385 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8386 CvXSUB(dstr) = CvXSUB(sstr);
8387 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8388 CvGV(dstr) = gv_dup(CvGV(sstr));
8389 CvDEPTH(dstr) = CvDEPTH(sstr);
8390 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8391 /* XXX padlists are real, but pretend to be not */
8392 AvREAL_on(CvPADLIST(sstr));
8393 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8394 AvREAL_off(CvPADLIST(sstr));
8395 AvREAL_off(CvPADLIST(dstr));
8398 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8399 if (!CvANON(sstr) || CvCLONED(sstr))
8400 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8402 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8403 CvFLAGS(dstr) = CvFLAGS(sstr);
8406 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8410 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8417 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8422 return (PERL_CONTEXT*)NULL;
8424 /* look for it in the table first */
8425 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8429 /* create anew and remember what it is */
8430 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8431 ptr_table_store(PL_ptr_table, cxs, ncxs);
8434 PERL_CONTEXT *cx = &cxs[ix];
8435 PERL_CONTEXT *ncx = &ncxs[ix];
8436 ncx->cx_type = cx->cx_type;
8437 if (CxTYPE(cx) == CXt_SUBST) {
8438 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8441 ncx->blk_oldsp = cx->blk_oldsp;
8442 ncx->blk_oldcop = cx->blk_oldcop;
8443 ncx->blk_oldretsp = cx->blk_oldretsp;
8444 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8445 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8446 ncx->blk_oldpm = cx->blk_oldpm;
8447 ncx->blk_gimme = cx->blk_gimme;
8448 switch (CxTYPE(cx)) {
8450 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8451 ? cv_dup_inc(cx->blk_sub.cv)
8452 : cv_dup(cx->blk_sub.cv));
8453 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8454 ? av_dup_inc(cx->blk_sub.argarray)
8456 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8457 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8458 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8459 ncx->blk_sub.lval = cx->blk_sub.lval;
8462 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8463 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8464 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8465 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8466 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8469 ncx->blk_loop.label = cx->blk_loop.label;
8470 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8471 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8472 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8473 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8474 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8475 ? cx->blk_loop.iterdata
8476 : gv_dup((GV*)cx->blk_loop.iterdata));
8477 ncx->blk_loop.oldcurpad
8478 = (SV**)ptr_table_fetch(PL_ptr_table,
8479 cx->blk_loop.oldcurpad);
8480 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8481 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8482 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8483 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8484 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8487 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8488 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8489 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8490 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8503 Perl_si_dup(pTHX_ PERL_SI *si)
8508 return (PERL_SI*)NULL;
8510 /* look for it in the table first */
8511 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8515 /* create anew and remember what it is */
8516 Newz(56, nsi, 1, PERL_SI);
8517 ptr_table_store(PL_ptr_table, si, nsi);
8519 nsi->si_stack = av_dup_inc(si->si_stack);
8520 nsi->si_cxix = si->si_cxix;
8521 nsi->si_cxmax = si->si_cxmax;
8522 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8523 nsi->si_type = si->si_type;
8524 nsi->si_prev = si_dup(si->si_prev);
8525 nsi->si_next = si_dup(si->si_next);
8526 nsi->si_markoff = si->si_markoff;
8531 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8532 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8533 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8534 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8535 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8536 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8537 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8538 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8539 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8540 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8541 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8542 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8545 #define pv_dup_inc(p) SAVEPV(p)
8546 #define pv_dup(p) SAVEPV(p)
8547 #define svp_dup_inc(p,pp) any_dup(p,pp)
8550 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8557 /* look for it in the table first */
8558 ret = ptr_table_fetch(PL_ptr_table, v);
8562 /* see if it is part of the interpreter structure */
8563 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8564 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8572 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8574 ANY *ss = proto_perl->Tsavestack;
8575 I32 ix = proto_perl->Tsavestack_ix;
8576 I32 max = proto_perl->Tsavestack_max;
8589 void (*dptr) (void*);
8590 void (*dxptr) (pTHXo_ void*);
8593 Newz(54, nss, max, ANY);
8599 case SAVEt_ITEM: /* normal string */
8600 sv = (SV*)POPPTR(ss,ix);
8601 TOPPTR(nss,ix) = sv_dup_inc(sv);
8602 sv = (SV*)POPPTR(ss,ix);
8603 TOPPTR(nss,ix) = sv_dup_inc(sv);
8605 case SAVEt_SV: /* scalar reference */
8606 sv = (SV*)POPPTR(ss,ix);
8607 TOPPTR(nss,ix) = sv_dup_inc(sv);
8608 gv = (GV*)POPPTR(ss,ix);
8609 TOPPTR(nss,ix) = gv_dup_inc(gv);
8611 case SAVEt_GENERIC_PVREF: /* generic char* */
8612 c = (char*)POPPTR(ss,ix);
8613 TOPPTR(nss,ix) = pv_dup(c);
8614 ptr = POPPTR(ss,ix);
8615 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8617 case SAVEt_GENERIC_SVREF: /* generic sv */
8618 case SAVEt_SVREF: /* scalar reference */
8619 sv = (SV*)POPPTR(ss,ix);
8620 TOPPTR(nss,ix) = sv_dup_inc(sv);
8621 ptr = POPPTR(ss,ix);
8622 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8624 case SAVEt_AV: /* array reference */
8625 av = (AV*)POPPTR(ss,ix);
8626 TOPPTR(nss,ix) = av_dup_inc(av);
8627 gv = (GV*)POPPTR(ss,ix);
8628 TOPPTR(nss,ix) = gv_dup(gv);
8630 case SAVEt_HV: /* hash reference */
8631 hv = (HV*)POPPTR(ss,ix);
8632 TOPPTR(nss,ix) = hv_dup_inc(hv);
8633 gv = (GV*)POPPTR(ss,ix);
8634 TOPPTR(nss,ix) = gv_dup(gv);
8636 case SAVEt_INT: /* int reference */
8637 ptr = POPPTR(ss,ix);
8638 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8639 intval = (int)POPINT(ss,ix);
8640 TOPINT(nss,ix) = intval;
8642 case SAVEt_LONG: /* long reference */
8643 ptr = POPPTR(ss,ix);
8644 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8645 longval = (long)POPLONG(ss,ix);
8646 TOPLONG(nss,ix) = longval;
8648 case SAVEt_I32: /* I32 reference */
8649 case SAVEt_I16: /* I16 reference */
8650 case SAVEt_I8: /* I8 reference */
8651 ptr = POPPTR(ss,ix);
8652 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8656 case SAVEt_IV: /* IV reference */
8657 ptr = POPPTR(ss,ix);
8658 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8662 case SAVEt_SPTR: /* SV* reference */
8663 ptr = POPPTR(ss,ix);
8664 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8665 sv = (SV*)POPPTR(ss,ix);
8666 TOPPTR(nss,ix) = sv_dup(sv);
8668 case SAVEt_VPTR: /* random* reference */
8669 ptr = POPPTR(ss,ix);
8670 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8671 ptr = POPPTR(ss,ix);
8672 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8674 case SAVEt_PPTR: /* char* reference */
8675 ptr = POPPTR(ss,ix);
8676 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8677 c = (char*)POPPTR(ss,ix);
8678 TOPPTR(nss,ix) = pv_dup(c);
8680 case SAVEt_HPTR: /* HV* reference */
8681 ptr = POPPTR(ss,ix);
8682 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8683 hv = (HV*)POPPTR(ss,ix);
8684 TOPPTR(nss,ix) = hv_dup(hv);
8686 case SAVEt_APTR: /* AV* reference */
8687 ptr = POPPTR(ss,ix);
8688 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8689 av = (AV*)POPPTR(ss,ix);
8690 TOPPTR(nss,ix) = av_dup(av);
8693 gv = (GV*)POPPTR(ss,ix);
8694 TOPPTR(nss,ix) = gv_dup(gv);
8696 case SAVEt_GP: /* scalar reference */
8697 gp = (GP*)POPPTR(ss,ix);
8698 TOPPTR(nss,ix) = gp = gp_dup(gp);
8699 (void)GpREFCNT_inc(gp);
8700 gv = (GV*)POPPTR(ss,ix);
8701 TOPPTR(nss,ix) = gv_dup_inc(c);
8702 c = (char*)POPPTR(ss,ix);
8703 TOPPTR(nss,ix) = pv_dup(c);
8710 case SAVEt_MORTALIZESV:
8711 sv = (SV*)POPPTR(ss,ix);
8712 TOPPTR(nss,ix) = sv_dup_inc(sv);
8715 ptr = POPPTR(ss,ix);
8716 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8717 /* these are assumed to be refcounted properly */
8718 switch (((OP*)ptr)->op_type) {
8725 TOPPTR(nss,ix) = ptr;
8730 TOPPTR(nss,ix) = Nullop;
8735 TOPPTR(nss,ix) = Nullop;
8738 c = (char*)POPPTR(ss,ix);
8739 TOPPTR(nss,ix) = pv_dup_inc(c);
8742 longval = POPLONG(ss,ix);
8743 TOPLONG(nss,ix) = longval;
8746 hv = (HV*)POPPTR(ss,ix);
8747 TOPPTR(nss,ix) = hv_dup_inc(hv);
8748 c = (char*)POPPTR(ss,ix);
8749 TOPPTR(nss,ix) = pv_dup_inc(c);
8753 case SAVEt_DESTRUCTOR:
8754 ptr = POPPTR(ss,ix);
8755 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8756 dptr = POPDPTR(ss,ix);
8757 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8759 case SAVEt_DESTRUCTOR_X:
8760 ptr = POPPTR(ss,ix);
8761 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8762 dxptr = POPDXPTR(ss,ix);
8763 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8765 case SAVEt_REGCONTEXT:
8771 case SAVEt_STACK_POS: /* Position on Perl stack */
8775 case SAVEt_AELEM: /* array element */
8776 sv = (SV*)POPPTR(ss,ix);
8777 TOPPTR(nss,ix) = sv_dup_inc(sv);
8780 av = (AV*)POPPTR(ss,ix);
8781 TOPPTR(nss,ix) = av_dup_inc(av);
8783 case SAVEt_HELEM: /* hash element */
8784 sv = (SV*)POPPTR(ss,ix);
8785 TOPPTR(nss,ix) = sv_dup_inc(sv);
8786 sv = (SV*)POPPTR(ss,ix);
8787 TOPPTR(nss,ix) = sv_dup_inc(sv);
8788 hv = (HV*)POPPTR(ss,ix);
8789 TOPPTR(nss,ix) = hv_dup_inc(hv);
8792 ptr = POPPTR(ss,ix);
8793 TOPPTR(nss,ix) = ptr;
8800 av = (AV*)POPPTR(ss,ix);
8801 TOPPTR(nss,ix) = av_dup(av);
8804 longval = (long)POPLONG(ss,ix);
8805 TOPLONG(nss,ix) = longval;
8806 ptr = POPPTR(ss,ix);
8807 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8808 sv = (SV*)POPPTR(ss,ix);
8809 TOPPTR(nss,ix) = sv_dup(sv);
8812 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8824 perl_clone(PerlInterpreter *proto_perl, UV flags)
8827 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8830 #ifdef PERL_IMPLICIT_SYS
8831 return perl_clone_using(proto_perl, flags,
8833 proto_perl->IMemShared,
8834 proto_perl->IMemParse,
8844 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8845 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8846 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8847 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8848 struct IPerlDir* ipD, struct IPerlSock* ipS,
8849 struct IPerlProc* ipP)
8851 /* XXX many of the string copies here can be optimized if they're
8852 * constants; they need to be allocated as common memory and just
8853 * their pointers copied. */
8857 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8859 PERL_SET_THX(pPerl);
8860 # else /* !PERL_OBJECT */
8861 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8862 PERL_SET_THX(my_perl);
8865 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8871 # else /* !DEBUGGING */
8872 Zero(my_perl, 1, PerlInterpreter);
8873 # endif /* DEBUGGING */
8877 PL_MemShared = ipMS;
8885 # endif /* PERL_OBJECT */
8886 #else /* !PERL_IMPLICIT_SYS */
8888 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8889 PERL_SET_THX(my_perl);
8892 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8898 # else /* !DEBUGGING */
8899 Zero(my_perl, 1, PerlInterpreter);
8900 # endif /* DEBUGGING */
8901 #endif /* PERL_IMPLICIT_SYS */
8904 PL_xiv_arenaroot = NULL;
8906 PL_xnv_arenaroot = NULL;
8908 PL_xrv_arenaroot = NULL;
8910 PL_xpv_arenaroot = NULL;
8912 PL_xpviv_arenaroot = NULL;
8913 PL_xpviv_root = NULL;
8914 PL_xpvnv_arenaroot = NULL;
8915 PL_xpvnv_root = NULL;
8916 PL_xpvcv_arenaroot = NULL;
8917 PL_xpvcv_root = NULL;
8918 PL_xpvav_arenaroot = NULL;
8919 PL_xpvav_root = NULL;
8920 PL_xpvhv_arenaroot = NULL;
8921 PL_xpvhv_root = NULL;
8922 PL_xpvmg_arenaroot = NULL;
8923 PL_xpvmg_root = NULL;
8924 PL_xpvlv_arenaroot = NULL;
8925 PL_xpvlv_root = NULL;
8926 PL_xpvbm_arenaroot = NULL;
8927 PL_xpvbm_root = NULL;
8928 PL_he_arenaroot = NULL;
8930 PL_nice_chunk = NULL;
8931 PL_nice_chunk_size = 0;
8934 PL_sv_root = Nullsv;
8935 PL_sv_arenaroot = Nullsv;
8937 PL_debug = proto_perl->Idebug;
8939 /* create SV map for pointer relocation */
8940 PL_ptr_table = ptr_table_new();
8942 /* initialize these special pointers as early as possible */
8943 SvANY(&PL_sv_undef) = NULL;
8944 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8945 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8946 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8949 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8951 SvANY(&PL_sv_no) = new_XPVNV();
8953 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8954 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8955 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8956 SvCUR(&PL_sv_no) = 0;
8957 SvLEN(&PL_sv_no) = 1;
8958 SvNVX(&PL_sv_no) = 0;
8959 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8962 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8964 SvANY(&PL_sv_yes) = new_XPVNV();
8966 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8967 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8968 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8969 SvCUR(&PL_sv_yes) = 1;
8970 SvLEN(&PL_sv_yes) = 2;
8971 SvNVX(&PL_sv_yes) = 1;
8972 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8974 /* create shared string table */
8975 PL_strtab = newHV();
8976 HvSHAREKEYS_off(PL_strtab);
8977 hv_ksplit(PL_strtab, 512);
8978 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8980 PL_compiling = proto_perl->Icompiling;
8981 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8982 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8983 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8984 if (!specialWARN(PL_compiling.cop_warnings))
8985 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8986 if (!specialCopIO(PL_compiling.cop_io))
8987 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8988 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8990 /* pseudo environmental stuff */
8991 PL_origargc = proto_perl->Iorigargc;
8993 New(0, PL_origargv, i+1, char*);
8994 PL_origargv[i] = '\0';
8996 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8998 PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */
8999 PL_envgv = gv_dup(proto_perl->Ienvgv);
9000 PL_incgv = gv_dup(proto_perl->Iincgv);
9001 PL_hintgv = gv_dup(proto_perl->Ihintgv);
9002 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9003 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
9004 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
9007 PL_minus_c = proto_perl->Iminus_c;
9008 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
9009 PL_localpatches = proto_perl->Ilocalpatches;
9010 PL_splitstr = proto_perl->Isplitstr;
9011 PL_preprocess = proto_perl->Ipreprocess;
9012 PL_minus_n = proto_perl->Iminus_n;
9013 PL_minus_p = proto_perl->Iminus_p;
9014 PL_minus_l = proto_perl->Iminus_l;
9015 PL_minus_a = proto_perl->Iminus_a;
9016 PL_minus_F = proto_perl->Iminus_F;
9017 PL_doswitches = proto_perl->Idoswitches;
9018 PL_dowarn = proto_perl->Idowarn;
9019 PL_doextract = proto_perl->Idoextract;
9020 PL_sawampersand = proto_perl->Isawampersand;
9021 PL_unsafe = proto_perl->Iunsafe;
9022 PL_inplace = SAVEPV(proto_perl->Iinplace);
9023 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
9024 PL_perldb = proto_perl->Iperldb;
9025 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9027 /* magical thingies */
9028 /* XXX time(&PL_basetime) when asked for? */
9029 PL_basetime = proto_perl->Ibasetime;
9030 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9032 PL_maxsysfd = proto_perl->Imaxsysfd;
9033 PL_multiline = proto_perl->Imultiline;
9034 PL_statusvalue = proto_perl->Istatusvalue;
9036 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9039 /* shortcuts to various I/O objects */
9040 PL_stdingv = gv_dup(proto_perl->Istdingv);
9041 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9042 PL_defgv = gv_dup(proto_perl->Idefgv);
9043 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9044 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
9045 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
9047 /* shortcuts to regexp stuff */
9048 PL_replgv = gv_dup(proto_perl->Ireplgv);
9050 /* shortcuts to misc objects */
9051 PL_errgv = gv_dup(proto_perl->Ierrgv);
9053 /* shortcuts to debugging objects */
9054 PL_DBgv = gv_dup(proto_perl->IDBgv);
9055 PL_DBline = gv_dup(proto_perl->IDBline);
9056 PL_DBsub = gv_dup(proto_perl->IDBsub);
9057 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9058 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9059 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9060 PL_lineary = av_dup(proto_perl->Ilineary);
9061 PL_dbargs = av_dup(proto_perl->Idbargs);
9064 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9065 PL_curstash = hv_dup(proto_perl->Tcurstash);
9066 PL_debstash = hv_dup(proto_perl->Idebstash);
9067 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9068 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9070 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9071 PL_endav = av_dup_inc(proto_perl->Iendav);
9072 PL_checkav = av_dup_inc(proto_perl->Icheckav);
9073 PL_initav = av_dup_inc(proto_perl->Iinitav);
9075 PL_sub_generation = proto_perl->Isub_generation;
9077 /* funky return mechanisms */
9078 PL_forkprocess = proto_perl->Iforkprocess;
9080 /* subprocess state */
9081 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9083 /* internal state */
9084 PL_tainting = proto_perl->Itainting;
9085 PL_maxo = proto_perl->Imaxo;
9086 if (proto_perl->Iop_mask)
9087 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9089 PL_op_mask = Nullch;
9091 /* current interpreter roots */
9092 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9093 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9094 PL_main_start = proto_perl->Imain_start;
9095 PL_eval_root = proto_perl->Ieval_root;
9096 PL_eval_start = proto_perl->Ieval_start;
9098 /* runtime control stuff */
9099 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9100 PL_copline = proto_perl->Icopline;
9102 PL_filemode = proto_perl->Ifilemode;
9103 PL_lastfd = proto_perl->Ilastfd;
9104 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9107 PL_gensym = proto_perl->Igensym;
9108 PL_preambled = proto_perl->Ipreambled;
9109 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9110 PL_laststatval = proto_perl->Ilaststatval;
9111 PL_laststype = proto_perl->Ilaststype;
9112 PL_mess_sv = Nullsv;
9114 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
9115 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9117 /* interpreter atexit processing */
9118 PL_exitlistlen = proto_perl->Iexitlistlen;
9119 if (PL_exitlistlen) {
9120 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9121 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9124 PL_exitlist = (PerlExitListEntry*)NULL;
9125 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9127 PL_profiledata = NULL;
9128 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9129 /* PL_rsfp_filters entries have fake IoDIRP() */
9130 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9132 PL_compcv = cv_dup(proto_perl->Icompcv);
9133 PL_comppad = av_dup(proto_perl->Icomppad);
9134 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9135 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9136 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9137 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9138 proto_perl->Tcurpad);
9140 #ifdef HAVE_INTERP_INTERN
9141 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9144 /* more statics moved here */
9145 PL_generation = proto_perl->Igeneration;
9146 PL_DBcv = cv_dup(proto_perl->IDBcv);
9148 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9149 PL_in_clean_all = proto_perl->Iin_clean_all;
9151 PL_uid = proto_perl->Iuid;
9152 PL_euid = proto_perl->Ieuid;
9153 PL_gid = proto_perl->Igid;
9154 PL_egid = proto_perl->Iegid;
9155 PL_nomemok = proto_perl->Inomemok;
9156 PL_an = proto_perl->Ian;
9157 PL_cop_seqmax = proto_perl->Icop_seqmax;
9158 PL_op_seqmax = proto_perl->Iop_seqmax;
9159 PL_evalseq = proto_perl->Ievalseq;
9160 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9161 PL_origalen = proto_perl->Iorigalen;
9162 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9163 PL_osname = SAVEPV(proto_perl->Iosname);
9164 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9165 PL_sighandlerp = proto_perl->Isighandlerp;
9168 PL_runops = proto_perl->Irunops;
9170 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9173 PL_cshlen = proto_perl->Icshlen;
9174 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9177 PL_lex_state = proto_perl->Ilex_state;
9178 PL_lex_defer = proto_perl->Ilex_defer;
9179 PL_lex_expect = proto_perl->Ilex_expect;
9180 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9181 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9182 PL_lex_starts = proto_perl->Ilex_starts;
9183 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9184 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9185 PL_lex_op = proto_perl->Ilex_op;
9186 PL_lex_inpat = proto_perl->Ilex_inpat;
9187 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9188 PL_lex_brackets = proto_perl->Ilex_brackets;
9189 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9190 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9191 PL_lex_casemods = proto_perl->Ilex_casemods;
9192 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9193 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9195 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9196 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9197 PL_nexttoke = proto_perl->Inexttoke;
9199 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9200 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9201 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9202 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9203 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9204 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9205 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9206 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9207 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9208 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9209 PL_pending_ident = proto_perl->Ipending_ident;
9210 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9212 PL_expect = proto_perl->Iexpect;
9214 PL_multi_start = proto_perl->Imulti_start;
9215 PL_multi_end = proto_perl->Imulti_end;
9216 PL_multi_open = proto_perl->Imulti_open;
9217 PL_multi_close = proto_perl->Imulti_close;
9219 PL_error_count = proto_perl->Ierror_count;
9220 PL_subline = proto_perl->Isubline;
9221 PL_subname = sv_dup_inc(proto_perl->Isubname);
9223 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9224 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9225 PL_padix = proto_perl->Ipadix;
9226 PL_padix_floor = proto_perl->Ipadix_floor;
9227 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9229 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9230 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9231 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9232 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9233 PL_last_lop_op = proto_perl->Ilast_lop_op;
9234 PL_in_my = proto_perl->Iin_my;
9235 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9237 PL_cryptseen = proto_perl->Icryptseen;
9240 PL_hints = proto_perl->Ihints;
9242 PL_amagic_generation = proto_perl->Iamagic_generation;
9244 #ifdef USE_LOCALE_COLLATE
9245 PL_collation_ix = proto_perl->Icollation_ix;
9246 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9247 PL_collation_standard = proto_perl->Icollation_standard;
9248 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9249 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9250 #endif /* USE_LOCALE_COLLATE */
9252 #ifdef USE_LOCALE_NUMERIC
9253 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9254 PL_numeric_standard = proto_perl->Inumeric_standard;
9255 PL_numeric_local = proto_perl->Inumeric_local;
9256 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9257 #endif /* !USE_LOCALE_NUMERIC */
9259 /* utf8 character classes */
9260 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9261 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9262 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9263 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9264 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9265 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9266 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9267 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9268 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9269 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9270 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9271 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9272 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9273 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9274 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9275 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9276 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9279 PL_last_swash_hv = Nullhv; /* reinits on demand */
9280 PL_last_swash_klen = 0;
9281 PL_last_swash_key[0]= '\0';
9282 PL_last_swash_tmps = (U8*)NULL;
9283 PL_last_swash_slen = 0;
9285 /* perly.c globals */
9286 PL_yydebug = proto_perl->Iyydebug;
9287 PL_yynerrs = proto_perl->Iyynerrs;
9288 PL_yyerrflag = proto_perl->Iyyerrflag;
9289 PL_yychar = proto_perl->Iyychar;
9290 PL_yyval = proto_perl->Iyyval;
9291 PL_yylval = proto_perl->Iyylval;
9293 PL_glob_index = proto_perl->Iglob_index;
9294 PL_srand_called = proto_perl->Isrand_called;
9295 PL_uudmap['M'] = 0; /* reinits on demand */
9296 PL_bitcount = Nullch; /* reinits on demand */
9298 if (proto_perl->Ipsig_pend) {
9299 Newz(0, PL_psig_pend, SIG_SIZE, int);
9302 PL_psig_pend = (int*)NULL;
9305 if (proto_perl->Ipsig_ptr) {
9306 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9307 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9308 for (i = 1; i < SIG_SIZE; i++) {
9309 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9310 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9314 PL_psig_ptr = (SV**)NULL;
9315 PL_psig_name = (SV**)NULL;
9318 /* thrdvar.h stuff */
9320 if (flags & CLONEf_COPY_STACKS) {
9321 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9322 PL_tmps_ix = proto_perl->Ttmps_ix;
9323 PL_tmps_max = proto_perl->Ttmps_max;
9324 PL_tmps_floor = proto_perl->Ttmps_floor;
9325 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9327 while (i <= PL_tmps_ix) {
9328 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9332 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9333 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9334 Newz(54, PL_markstack, i, I32);
9335 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9336 - proto_perl->Tmarkstack);
9337 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9338 - proto_perl->Tmarkstack);
9339 Copy(proto_perl->Tmarkstack, PL_markstack,
9340 PL_markstack_ptr - PL_markstack + 1, I32);
9342 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9343 * NOTE: unlike the others! */
9344 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9345 PL_scopestack_max = proto_perl->Tscopestack_max;
9346 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9347 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9349 /* next push_return() sets PL_retstack[PL_retstack_ix]
9350 * NOTE: unlike the others! */
9351 PL_retstack_ix = proto_perl->Tretstack_ix;
9352 PL_retstack_max = proto_perl->Tretstack_max;
9353 Newz(54, PL_retstack, PL_retstack_max, OP*);
9354 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9356 /* NOTE: si_dup() looks at PL_markstack */
9357 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9359 /* PL_curstack = PL_curstackinfo->si_stack; */
9360 PL_curstack = av_dup(proto_perl->Tcurstack);
9361 PL_mainstack = av_dup(proto_perl->Tmainstack);
9363 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9364 PL_stack_base = AvARRAY(PL_curstack);
9365 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9366 - proto_perl->Tstack_base);
9367 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9369 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9370 * NOTE: unlike the others! */
9371 PL_savestack_ix = proto_perl->Tsavestack_ix;
9372 PL_savestack_max = proto_perl->Tsavestack_max;
9373 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9374 PL_savestack = ss_dup(proto_perl);
9378 ENTER; /* perl_destruct() wants to LEAVE; */
9381 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9382 PL_top_env = &PL_start_env;
9384 PL_op = proto_perl->Top;
9387 PL_Xpv = (XPV*)NULL;
9388 PL_na = proto_perl->Tna;
9390 PL_statbuf = proto_perl->Tstatbuf;
9391 PL_statcache = proto_perl->Tstatcache;
9392 PL_statgv = gv_dup(proto_perl->Tstatgv);
9393 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9395 PL_timesbuf = proto_perl->Ttimesbuf;
9398 PL_tainted = proto_perl->Ttainted;
9399 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9400 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9401 PL_rs = sv_dup_inc(proto_perl->Trs);
9402 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9403 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9404 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9405 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9406 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9407 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9408 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9410 PL_restartop = proto_perl->Trestartop;
9411 PL_in_eval = proto_perl->Tin_eval;
9412 PL_delaymagic = proto_perl->Tdelaymagic;
9413 PL_dirty = proto_perl->Tdirty;
9414 PL_localizing = proto_perl->Tlocalizing;
9416 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9417 PL_protect = proto_perl->Tprotect;
9419 PL_errors = sv_dup_inc(proto_perl->Terrors);
9420 PL_av_fetch_sv = Nullsv;
9421 PL_hv_fetch_sv = Nullsv;
9422 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9423 PL_modcount = proto_perl->Tmodcount;
9424 PL_lastgotoprobe = Nullop;
9425 PL_dumpindent = proto_perl->Tdumpindent;
9427 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9428 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9429 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9430 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9431 PL_sortcxix = proto_perl->Tsortcxix;
9432 PL_efloatbuf = Nullch; /* reinits on demand */
9433 PL_efloatsize = 0; /* reinits on demand */
9437 PL_screamfirst = NULL;
9438 PL_screamnext = NULL;
9439 PL_maxscream = -1; /* reinits on demand */
9440 PL_lastscream = Nullsv;
9442 PL_watchaddr = NULL;
9443 PL_watchok = Nullch;
9445 PL_regdummy = proto_perl->Tregdummy;
9446 PL_regcomp_parse = Nullch;
9447 PL_regxend = Nullch;
9448 PL_regcode = (regnode*)NULL;
9451 PL_regprecomp = Nullch;
9456 PL_seen_zerolen = 0;
9458 PL_regcomp_rx = (regexp*)NULL;
9460 PL_colorset = 0; /* reinits PL_colors[] */
9461 /*PL_colors[6] = {0,0,0,0,0,0};*/
9462 PL_reg_whilem_seen = 0;
9463 PL_reginput = Nullch;
9466 PL_regstartp = (I32*)NULL;
9467 PL_regendp = (I32*)NULL;
9468 PL_reglastparen = (U32*)NULL;
9469 PL_regtill = Nullch;
9470 PL_reg_start_tmp = (char**)NULL;
9471 PL_reg_start_tmpl = 0;
9472 PL_regdata = (struct reg_data*)NULL;
9475 PL_reg_eval_set = 0;
9477 PL_regprogram = (regnode*)NULL;
9479 PL_regcc = (CURCUR*)NULL;
9480 PL_reg_call_cc = (struct re_cc_state*)NULL;
9481 PL_reg_re = (regexp*)NULL;
9482 PL_reg_ganch = Nullch;
9484 PL_reg_magic = (MAGIC*)NULL;
9486 PL_reg_oldcurpm = (PMOP*)NULL;
9487 PL_reg_curpm = (PMOP*)NULL;
9488 PL_reg_oldsaved = Nullch;
9489 PL_reg_oldsavedlen = 0;
9491 PL_reg_leftiter = 0;
9492 PL_reg_poscache = Nullch;
9493 PL_reg_poscache_size= 0;
9495 /* RE engine - function pointers */
9496 PL_regcompp = proto_perl->Tregcompp;
9497 PL_regexecp = proto_perl->Tregexecp;
9498 PL_regint_start = proto_perl->Tregint_start;
9499 PL_regint_string = proto_perl->Tregint_string;
9500 PL_regfree = proto_perl->Tregfree;
9502 PL_reginterp_cnt = 0;
9503 PL_reg_starttry = 0;
9505 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9506 ptr_table_free(PL_ptr_table);
9507 PL_ptr_table = NULL;
9510 while(av_len(PL_clone_callbacks) != -1) {
9511 HV* stash = (HV*) av_shift(PL_clone_callbacks);
9512 CV* cloner = (CV*) gv_fetchmethod_autoload(stash,"CLONE",0);
9515 cloner = GvCV(cloner);
9519 XPUSHs(newSVpv(HvNAME(stash),0));
9521 call_sv((SV*)cloner, G_DISCARD);
9529 return (PerlInterpreter*)pPerl;
9535 #else /* !USE_ITHREADS */
9541 #endif /* USE_ITHREADS */
9544 do_report_used(pTHXo_ SV *sv)
9546 if (SvTYPE(sv) != SVTYPEMASK) {
9547 PerlIO_printf(Perl_debug_log, "****\n");
9553 do_clean_objs(pTHXo_ SV *sv)
9557 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9558 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9559 if (SvWEAKREF(sv)) {
9570 /* XXX Might want to check arrays, etc. */
9573 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9575 do_clean_named_objs(pTHXo_ SV *sv)
9577 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9578 if ( SvOBJECT(GvSV(sv)) ||
9579 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9580 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9581 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9582 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9584 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9592 do_clean_all(pTHXo_ SV *sv)
9594 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9595 SvFLAGS(sv) |= SVf_BREAK;