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);
1490 =for apidoc looks_like_number
1492 Test if an the content of an SV looks like a number (or is a
1493 number). C<Inf> and C<Infinity> are treated as numbers (so will not
1494 issue a non-numeric warning), even if your atof() doesn't grok them.
1500 Perl_looks_like_number(pTHX_ SV *sv)
1502 register char *sbegin;
1509 else if (SvPOKp(sv))
1510 sbegin = SvPV(sv, len);
1512 return 1; /* Historic. Wrong? */
1513 return grok_number(sbegin, len, NULL);
1516 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1517 until proven guilty, assume that things are not that bad... */
1519 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1520 an IV (an assumption perl has been based on to date) it becomes necessary
1521 to remove the assumption that the NV always carries enough precision to
1522 recreate the IV whenever needed, and that the NV is the canonical form.
1523 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1524 precision as an side effect of conversion (which would lead to insanity
1525 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1526 1) to distinguish between IV/UV/NV slots that have cached a valid
1527 conversion where precision was lost and IV/UV/NV slots that have a
1528 valid conversion which has lost no precision
1529 2) to ensure that if a numeric conversion to one form is request that
1530 would lose precision, the precise conversion (or differently
1531 imprecise conversion) is also performed and cached, to prevent
1532 requests for different numeric formats on the same SV causing
1533 lossy conversion chains. (lossless conversion chains are perfectly
1538 SvIOKp is true if the IV slot contains a valid value
1539 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1540 SvNOKp is true if the NV slot contains a valid value
1541 SvNOK is true only if the NV value is accurate
1544 while converting from PV to NV check to see if converting that NV to an
1545 IV(or UV) would lose accuracy over a direct conversion from PV to
1546 IV(or UV). If it would, cache both conversions, return NV, but mark
1547 SV as IOK NOKp (ie not NOK).
1549 while converting from PV to IV check to see if converting that IV to an
1550 NV would lose accuracy over a direct conversion from PV to NV. If it
1551 would, cache both conversions, flag similarly.
1553 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1554 correctly because if IV & NV were set NV *always* overruled.
1555 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1556 changes - now IV and NV together means that the two are interchangeable
1557 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1559 The benefit of this is operations such as pp_add know that if SvIOK is
1560 true for both left and right operands, then integer addition can be
1561 used instead of floating point. (for cases where the result won't
1562 overflow) Before, floating point was always used, which could lead to
1563 loss of precision compared with integer addition.
1565 * making IV and NV equal status should make maths accurate on 64 bit
1567 * may speed up maths somewhat if pp_add and friends start to use
1568 integers when possible instead of fp. (hopefully the overhead in
1569 looking for SvIOK and checking for overflow will not outweigh the
1570 fp to integer speedup)
1571 * will slow down integer operations (callers of SvIV) on "inaccurate"
1572 values, as the change from SvIOK to SvIOKp will cause a call into
1573 sv_2iv each time rather than a macro access direct to the IV slot
1574 * should speed up number->string conversion on integers as IV is
1575 favoured when IV and NV equally accurate
1577 ####################################################################
1578 You had better be using SvIOK_notUV if you want an IV for arithmetic
1579 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1580 SvUOK is true iff UV.
1581 ####################################################################
1583 Your mileage will vary depending your CPUs relative fp to integer
1587 #ifndef NV_PRESERVES_UV
1588 #define IS_NUMBER_UNDERFLOW_IV 1
1589 #define IS_NUMBER_UNDERFLOW_UV 2
1590 #define IS_NUMBER_IV_AND_UV 2
1591 #define IS_NUMBER_OVERFLOW_IV 4
1592 #define IS_NUMBER_OVERFLOW_UV 5
1594 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1596 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1598 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));
1599 if (SvNVX(sv) < (NV)IV_MIN) {
1600 (void)SvIOKp_on(sv);
1603 return IS_NUMBER_UNDERFLOW_IV;
1605 if (SvNVX(sv) > (NV)UV_MAX) {
1606 (void)SvIOKp_on(sv);
1610 return IS_NUMBER_OVERFLOW_UV;
1612 (void)SvIOKp_on(sv);
1614 /* Can't use strtol etc to convert this string. (See truth table in
1616 if (SvNVX(sv) <= (UV)IV_MAX) {
1617 SvIVX(sv) = I_V(SvNVX(sv));
1618 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1619 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1621 /* Integer is imprecise. NOK, IOKp */
1623 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1626 SvUVX(sv) = U_V(SvNVX(sv));
1627 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1628 if (SvUVX(sv) == UV_MAX) {
1629 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1630 possibly be preserved by NV. Hence, it must be overflow.
1632 return IS_NUMBER_OVERFLOW_UV;
1634 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1636 /* Integer is imprecise. NOK, IOKp */
1638 return IS_NUMBER_OVERFLOW_IV;
1640 #endif /* NV_PRESERVES_UV*/
1643 Perl_sv_2iv(pTHX_ register SV *sv)
1647 if (SvGMAGICAL(sv)) {
1652 return I_V(SvNVX(sv));
1654 if (SvPOKp(sv) && SvLEN(sv))
1657 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1658 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1664 if (SvTHINKFIRST(sv)) {
1667 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1668 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1669 return SvIV(tmpstr);
1670 return PTR2IV(SvRV(sv));
1672 if (SvREADONLY(sv) && SvFAKE(sv)) {
1673 sv_force_normal(sv);
1675 if (SvREADONLY(sv) && !SvOK(sv)) {
1676 if (ckWARN(WARN_UNINITIALIZED))
1683 return (IV)(SvUVX(sv));
1690 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1691 * without also getting a cached IV/UV from it at the same time
1692 * (ie PV->NV conversion should detect loss of accuracy and cache
1693 * IV or UV at same time to avoid this. NWC */
1695 if (SvTYPE(sv) == SVt_NV)
1696 sv_upgrade(sv, SVt_PVNV);
1698 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1699 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1700 certainly cast into the IV range at IV_MAX, whereas the correct
1701 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1703 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1704 SvIVX(sv) = I_V(SvNVX(sv));
1705 if (SvNVX(sv) == (NV) SvIVX(sv)
1706 #ifndef NV_PRESERVES_UV
1707 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1708 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1709 /* Don't flag it as "accurately an integer" if the number
1710 came from a (by definition imprecise) NV operation, and
1711 we're outside the range of NV integer precision */
1714 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1715 DEBUG_c(PerlIO_printf(Perl_debug_log,
1716 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1722 /* IV not precise. No need to convert from PV, as NV
1723 conversion would already have cached IV if it detected
1724 that PV->IV would be better than PV->NV->IV
1725 flags already correct - don't set public IOK. */
1726 DEBUG_c(PerlIO_printf(Perl_debug_log,
1727 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1732 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1733 but the cast (NV)IV_MIN rounds to a the value less (more
1734 negative) than IV_MIN which happens to be equal to SvNVX ??
1735 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1736 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1737 (NV)UVX == NVX are both true, but the values differ. :-(
1738 Hopefully for 2s complement IV_MIN is something like
1739 0x8000000000000000 which will be exact. NWC */
1742 SvUVX(sv) = U_V(SvNVX(sv));
1744 (SvNVX(sv) == (NV) SvUVX(sv))
1745 #ifndef NV_PRESERVES_UV
1746 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1747 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1748 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1749 /* Don't flag it as "accurately an integer" if the number
1750 came from a (by definition imprecise) NV operation, and
1751 we're outside the range of NV integer precision */
1757 DEBUG_c(PerlIO_printf(Perl_debug_log,
1758 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1762 return (IV)SvUVX(sv);
1765 else if (SvPOKp(sv) && SvLEN(sv)) {
1767 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
1768 /* We want to avoid a possible problem when we cache an IV which
1769 may be later translated to an NV, and the resulting NV is not
1770 the same as the direct translation of the initial string
1771 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1772 be careful to ensure that the value with the .456 is around if the
1773 NV value is requested in the future).
1775 This means that if we cache such an IV, we need to cache the
1776 NV as well. Moreover, we trade speed for space, and do not
1777 cache the NV if we are sure it's not needed.
1780 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1781 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1782 == IS_NUMBER_IN_UV) {
1783 /* It's defintately an integer, only upgrade to PVIV */
1784 if (SvTYPE(sv) < SVt_PVIV)
1785 sv_upgrade(sv, SVt_PVIV);
1787 } else if (SvTYPE(sv) < SVt_PVNV)
1788 sv_upgrade(sv, SVt_PVNV);
1790 /* If NV preserves UV then we only use the UV value if we know that
1791 we aren't going to call atof() below. If NVs don't preserve UVs
1792 then the value returned may have more precision than atof() will
1793 return, even though value isn't perfectly accurate. */
1794 if ((numtype & (IS_NUMBER_IN_UV
1795 #ifdef NV_PRESERVES_UV
1798 )) == IS_NUMBER_IN_UV) {
1799 /* This won't turn off the public IOK flag if it was set above */
1800 (void)SvIOKp_on(sv);
1802 if (!(numtype & IS_NUMBER_NEG)) {
1804 if (value <= (UV)IV_MAX) {
1805 SvIVX(sv) = (IV)value;
1811 /* 2s complement assumption */
1812 if (value <= (UV)IV_MIN) {
1813 SvIVX(sv) = -(IV)value;
1815 /* Too negative for an IV. This is a double upgrade, but
1816 I'm assuming it will be be rare. */
1817 if (SvTYPE(sv) < SVt_PVNV)
1818 sv_upgrade(sv, SVt_PVNV);
1822 SvNVX(sv) = -(NV)value;
1827 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1828 will be in the previous block to set the IV slot, and the next
1829 block to set the NV slot. So no else here. */
1831 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1832 != IS_NUMBER_IN_UV) {
1833 /* It wasn't an (integer that doesn't overflow the UV). */
1834 SvNVX(sv) = Atof(SvPVX(sv));
1836 if (! numtype && ckWARN(WARN_NUMERIC))
1839 #if defined(USE_LONG_DOUBLE)
1840 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1841 PTR2UV(sv), SvNVX(sv)));
1843 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1844 PTR2UV(sv), SvNVX(sv)));
1848 #ifdef NV_PRESERVES_UV
1849 (void)SvIOKp_on(sv);
1851 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1852 SvIVX(sv) = I_V(SvNVX(sv));
1853 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1856 /* Integer is imprecise. NOK, IOKp */
1858 /* UV will not work better than IV */
1860 if (SvNVX(sv) > (NV)UV_MAX) {
1862 /* Integer is inaccurate. NOK, IOKp, is UV */
1866 SvUVX(sv) = U_V(SvNVX(sv));
1867 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1868 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1872 /* Integer is imprecise. NOK, IOKp, is UV */
1878 #else /* NV_PRESERVES_UV */
1879 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1880 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1881 /* The IV slot will have been set from value returned by
1882 grok_number above. The NV slot has just been set using
1885 assert (SvIOKp(sv));
1887 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1888 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1889 /* Small enough to preserve all bits. */
1890 (void)SvIOKp_on(sv);
1892 SvIVX(sv) = I_V(SvNVX(sv));
1893 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1895 /* Assumption: first non-preserved integer is < IV_MAX,
1896 this NV is in the preserved range, therefore: */
1897 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1899 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);
1903 0 0 already failed to read UV.
1904 0 1 already failed to read UV.
1905 1 0 you won't get here in this case. IV/UV
1906 slot set, public IOK, Atof() unneeded.
1907 1 1 already read UV.
1908 so there's no point in sv_2iuv_non_preserve() attempting
1909 to use atol, strtol, strtoul etc. */
1910 if (sv_2iuv_non_preserve (sv, numtype)
1911 >= IS_NUMBER_OVERFLOW_IV)
1915 #endif /* NV_PRESERVES_UV */
1918 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1920 if (SvTYPE(sv) < SVt_IV)
1921 /* Typically the caller expects that sv_any is not NULL now. */
1922 sv_upgrade(sv, SVt_IV);
1925 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1926 PTR2UV(sv),SvIVX(sv)));
1927 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1931 Perl_sv_2uv(pTHX_ register SV *sv)
1935 if (SvGMAGICAL(sv)) {
1940 return U_V(SvNVX(sv));
1941 if (SvPOKp(sv) && SvLEN(sv))
1944 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1945 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1951 if (SvTHINKFIRST(sv)) {
1954 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1955 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1956 return SvUV(tmpstr);
1957 return PTR2UV(SvRV(sv));
1959 if (SvREADONLY(sv) && SvFAKE(sv)) {
1960 sv_force_normal(sv);
1962 if (SvREADONLY(sv) && !SvOK(sv)) {
1963 if (ckWARN(WARN_UNINITIALIZED))
1973 return (UV)SvIVX(sv);
1977 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1978 * without also getting a cached IV/UV from it at the same time
1979 * (ie PV->NV conversion should detect loss of accuracy and cache
1980 * IV or UV at same time to avoid this. */
1981 /* IV-over-UV optimisation - choose to cache IV if possible */
1983 if (SvTYPE(sv) == SVt_NV)
1984 sv_upgrade(sv, SVt_PVNV);
1986 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1987 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1988 SvIVX(sv) = I_V(SvNVX(sv));
1989 if (SvNVX(sv) == (NV) SvIVX(sv)
1990 #ifndef NV_PRESERVES_UV
1991 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1992 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1993 /* Don't flag it as "accurately an integer" if the number
1994 came from a (by definition imprecise) NV operation, and
1995 we're outside the range of NV integer precision */
1998 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1999 DEBUG_c(PerlIO_printf(Perl_debug_log,
2000 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2006 /* IV not precise. No need to convert from PV, as NV
2007 conversion would already have cached IV if it detected
2008 that PV->IV would be better than PV->NV->IV
2009 flags already correct - don't set public IOK. */
2010 DEBUG_c(PerlIO_printf(Perl_debug_log,
2011 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2016 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2017 but the cast (NV)IV_MIN rounds to a the value less (more
2018 negative) than IV_MIN which happens to be equal to SvNVX ??
2019 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2020 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2021 (NV)UVX == NVX are both true, but the values differ. :-(
2022 Hopefully for 2s complement IV_MIN is something like
2023 0x8000000000000000 which will be exact. NWC */
2026 SvUVX(sv) = U_V(SvNVX(sv));
2028 (SvNVX(sv) == (NV) SvUVX(sv))
2029 #ifndef NV_PRESERVES_UV
2030 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2031 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2032 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2033 /* Don't flag it as "accurately an integer" if the number
2034 came from a (by definition imprecise) NV operation, and
2035 we're outside the range of NV integer precision */
2040 DEBUG_c(PerlIO_printf(Perl_debug_log,
2041 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2047 else if (SvPOKp(sv) && SvLEN(sv)) {
2049 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2051 /* We want to avoid a possible problem when we cache a UV which
2052 may be later translated to an NV, and the resulting NV is not
2053 the translation of the initial data.
2055 This means that if we cache such a UV, we need to cache the
2056 NV as well. Moreover, we trade speed for space, and do not
2057 cache the NV if not needed.
2060 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2061 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2062 == IS_NUMBER_IN_UV) {
2063 /* It's defintately an integer, only upgrade to PVIV */
2064 if (SvTYPE(sv) < SVt_PVIV)
2065 sv_upgrade(sv, SVt_PVIV);
2067 } else if (SvTYPE(sv) < SVt_PVNV)
2068 sv_upgrade(sv, SVt_PVNV);
2070 /* If NV preserves UV then we only use the UV value if we know that
2071 we aren't going to call atof() below. If NVs don't preserve UVs
2072 then the value returned may have more precision than atof() will
2073 return, even though it isn't accurate. */
2074 if ((numtype & (IS_NUMBER_IN_UV
2075 #ifdef NV_PRESERVES_UV
2078 )) == IS_NUMBER_IN_UV) {
2079 /* This won't turn off the public IOK flag if it was set above */
2080 (void)SvIOKp_on(sv);
2082 if (!(numtype & IS_NUMBER_NEG)) {
2084 if (value <= (UV)IV_MAX) {
2085 SvIVX(sv) = (IV)value;
2087 /* it didn't overflow, and it was positive. */
2092 /* 2s complement assumption */
2093 if (value <= (UV)IV_MIN) {
2094 SvIVX(sv) = -(IV)value;
2096 /* Too negative for an IV. This is a double upgrade, but
2097 I'm assuming it will be be rare. */
2098 if (SvTYPE(sv) < SVt_PVNV)
2099 sv_upgrade(sv, SVt_PVNV);
2103 SvNVX(sv) = -(NV)value;
2109 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2110 != IS_NUMBER_IN_UV) {
2111 /* It wasn't an integer, or it overflowed the UV. */
2112 SvNVX(sv) = Atof(SvPVX(sv));
2114 if (! numtype && ckWARN(WARN_NUMERIC))
2117 #if defined(USE_LONG_DOUBLE)
2118 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2119 PTR2UV(sv), SvNVX(sv)));
2121 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2122 PTR2UV(sv), SvNVX(sv)));
2125 #ifdef NV_PRESERVES_UV
2126 (void)SvIOKp_on(sv);
2128 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2129 SvIVX(sv) = I_V(SvNVX(sv));
2130 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2133 /* Integer is imprecise. NOK, IOKp */
2135 /* UV will not work better than IV */
2137 if (SvNVX(sv) > (NV)UV_MAX) {
2139 /* Integer is inaccurate. NOK, IOKp, is UV */
2143 SvUVX(sv) = U_V(SvNVX(sv));
2144 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2145 NV preservse UV so can do correct comparison. */
2146 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2150 /* Integer is imprecise. NOK, IOKp, is UV */
2155 #else /* NV_PRESERVES_UV */
2156 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2157 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2158 /* The UV slot will have been set from value returned by
2159 grok_number above. The NV slot has just been set using
2162 assert (SvIOKp(sv));
2164 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2165 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2166 /* Small enough to preserve all bits. */
2167 (void)SvIOKp_on(sv);
2169 SvIVX(sv) = I_V(SvNVX(sv));
2170 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2172 /* Assumption: first non-preserved integer is < IV_MAX,
2173 this NV is in the preserved range, therefore: */
2174 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2176 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);
2179 sv_2iuv_non_preserve (sv, numtype);
2181 #endif /* NV_PRESERVES_UV */
2185 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2186 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2189 if (SvTYPE(sv) < SVt_IV)
2190 /* Typically the caller expects that sv_any is not NULL now. */
2191 sv_upgrade(sv, SVt_IV);
2195 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2196 PTR2UV(sv),SvUVX(sv)));
2197 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2201 Perl_sv_2nv(pTHX_ register SV *sv)
2205 if (SvGMAGICAL(sv)) {
2209 if (SvPOKp(sv) && SvLEN(sv)) {
2210 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2211 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2213 return Atof(SvPVX(sv));
2217 return (NV)SvUVX(sv);
2219 return (NV)SvIVX(sv);
2222 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2223 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2229 if (SvTHINKFIRST(sv)) {
2232 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2233 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2234 return SvNV(tmpstr);
2235 return PTR2NV(SvRV(sv));
2237 if (SvREADONLY(sv) && SvFAKE(sv)) {
2238 sv_force_normal(sv);
2240 if (SvREADONLY(sv) && !SvOK(sv)) {
2241 if (ckWARN(WARN_UNINITIALIZED))
2246 if (SvTYPE(sv) < SVt_NV) {
2247 if (SvTYPE(sv) == SVt_IV)
2248 sv_upgrade(sv, SVt_PVNV);
2250 sv_upgrade(sv, SVt_NV);
2251 #ifdef USE_LONG_DOUBLE
2253 STORE_NUMERIC_LOCAL_SET_STANDARD();
2254 PerlIO_printf(Perl_debug_log,
2255 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2256 PTR2UV(sv), SvNVX(sv));
2257 RESTORE_NUMERIC_LOCAL();
2261 STORE_NUMERIC_LOCAL_SET_STANDARD();
2262 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2263 PTR2UV(sv), SvNVX(sv));
2264 RESTORE_NUMERIC_LOCAL();
2268 else if (SvTYPE(sv) < SVt_PVNV)
2269 sv_upgrade(sv, SVt_PVNV);
2270 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2273 else if (SvIOKp(sv)) {
2274 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2275 #ifdef NV_PRESERVES_UV
2278 /* Only set the public NV OK flag if this NV preserves the IV */
2279 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2280 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2281 : (SvIVX(sv) == I_V(SvNVX(sv))))
2287 else if (SvPOKp(sv) && SvLEN(sv)) {
2289 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2290 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2292 #ifdef NV_PRESERVES_UV
2293 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2294 == IS_NUMBER_IN_UV) {
2295 /* It's defintately an integer */
2296 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2298 SvNVX(sv) = Atof(SvPVX(sv));
2301 SvNVX(sv) = Atof(SvPVX(sv));
2302 /* Only set the public NV OK flag if this NV preserves the value in
2303 the PV at least as well as an IV/UV would.
2304 Not sure how to do this 100% reliably. */
2305 /* if that shift count is out of range then Configure's test is
2306 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2308 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2309 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2310 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2311 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2312 /* Can't use strtol etc to convert this string, so don't try.
2313 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2316 /* value has been set. It may not be precise. */
2317 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2318 /* 2s complement assumption for (UV)IV_MIN */
2319 SvNOK_on(sv); /* Integer is too negative. */
2324 if (numtype & IS_NUMBER_NEG) {
2325 SvIVX(sv) = -(IV)value;
2326 } else if (value <= (UV)IV_MAX) {
2327 SvIVX(sv) = (IV)value;
2333 if (numtype & IS_NUMBER_NOT_INT) {
2334 /* I believe that even if the original PV had decimals,
2335 they are lost beyond the limit of the FP precision.
2336 However, neither is canonical, so both only get p
2337 flags. NWC, 2000/11/25 */
2338 /* Both already have p flags, so do nothing */
2341 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2342 if (SvIVX(sv) == I_V(nv)) {
2347 /* It had no "." so it must be integer. */
2350 /* between IV_MAX and NV(UV_MAX).
2351 Could be slightly > UV_MAX */
2353 if (numtype & IS_NUMBER_NOT_INT) {
2354 /* UV and NV both imprecise. */
2356 UV nv_as_uv = U_V(nv);
2358 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2369 #endif /* NV_PRESERVES_UV */
2372 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2374 if (SvTYPE(sv) < SVt_NV)
2375 /* Typically the caller expects that sv_any is not NULL now. */
2376 /* XXX Ilya implies that this is a bug in callers that assume this
2377 and ideally should be fixed. */
2378 sv_upgrade(sv, SVt_NV);
2381 #if defined(USE_LONG_DOUBLE)
2383 STORE_NUMERIC_LOCAL_SET_STANDARD();
2384 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2385 PTR2UV(sv), SvNVX(sv));
2386 RESTORE_NUMERIC_LOCAL();
2390 STORE_NUMERIC_LOCAL_SET_STANDARD();
2391 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2392 PTR2UV(sv), SvNVX(sv));
2393 RESTORE_NUMERIC_LOCAL();
2399 /* Caller must validate PVX */
2401 S_asIV(pTHX_ SV *sv)
2404 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2406 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2407 == IS_NUMBER_IN_UV) {
2408 /* It's defintately an integer */
2409 if (numtype & IS_NUMBER_NEG) {
2410 if (value < (UV)IV_MIN)
2413 if (value < (UV)IV_MAX)
2418 if (ckWARN(WARN_NUMERIC))
2421 return I_V(Atof(SvPVX(sv)));
2425 S_asUV(pTHX_ SV *sv)
2428 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2430 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2431 == IS_NUMBER_IN_UV) {
2432 /* It's defintately an integer */
2433 if (!(numtype & IS_NUMBER_NEG))
2437 if (ckWARN(WARN_NUMERIC))
2440 return U_V(Atof(SvPVX(sv)));
2444 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2447 return sv_2pv(sv, &n_a);
2450 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2452 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2454 char *ptr = buf + TYPE_CHARS(UV);
2468 *--ptr = '0' + (uv % 10);
2477 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2479 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2483 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2488 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2489 char *tmpbuf = tbuf;
2495 if (SvGMAGICAL(sv)) {
2496 if (flags & SV_GMAGIC)
2504 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2506 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2511 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2516 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2517 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2524 if (SvTHINKFIRST(sv)) {
2527 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2528 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2529 return SvPV(tmpstr,*lp);
2536 switch (SvTYPE(sv)) {
2538 if ( ((SvFLAGS(sv) &
2539 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2540 == (SVs_OBJECT|SVs_RMG))
2541 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2542 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2543 regexp *re = (regexp *)mg->mg_obj;
2546 char *fptr = "msix";
2551 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2553 while((ch = *fptr++)) {
2555 reflags[left++] = ch;
2558 reflags[right--] = ch;
2563 reflags[left] = '-';
2567 mg->mg_len = re->prelen + 4 + left;
2568 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2569 Copy("(?", mg->mg_ptr, 2, char);
2570 Copy(reflags, mg->mg_ptr+2, left, char);
2571 Copy(":", mg->mg_ptr+left+2, 1, char);
2572 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2573 mg->mg_ptr[mg->mg_len - 1] = ')';
2574 mg->mg_ptr[mg->mg_len] = 0;
2576 PL_reginterp_cnt += re->program[0].next_off;
2588 case SVt_PVBM: if (SvROK(sv))
2591 s = "SCALAR"; break;
2592 case SVt_PVLV: s = "LVALUE"; break;
2593 case SVt_PVAV: s = "ARRAY"; break;
2594 case SVt_PVHV: s = "HASH"; break;
2595 case SVt_PVCV: s = "CODE"; break;
2596 case SVt_PVGV: s = "GLOB"; break;
2597 case SVt_PVFM: s = "FORMAT"; break;
2598 case SVt_PVIO: s = "IO"; break;
2599 default: s = "UNKNOWN"; break;
2603 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2606 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2612 if (SvREADONLY(sv) && !SvOK(sv)) {
2613 if (ckWARN(WARN_UNINITIALIZED))
2619 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2620 /* I'm assuming that if both IV and NV are equally valid then
2621 converting the IV is going to be more efficient */
2622 U32 isIOK = SvIOK(sv);
2623 U32 isUIOK = SvIsUV(sv);
2624 char buf[TYPE_CHARS(UV)];
2627 if (SvTYPE(sv) < SVt_PVIV)
2628 sv_upgrade(sv, SVt_PVIV);
2630 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2632 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2633 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2634 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2635 SvCUR_set(sv, ebuf - ptr);
2645 else if (SvNOKp(sv)) {
2646 if (SvTYPE(sv) < SVt_PVNV)
2647 sv_upgrade(sv, SVt_PVNV);
2648 /* The +20 is pure guesswork. Configure test needed. --jhi */
2649 SvGROW(sv, NV_DIG + 20);
2651 olderrno = errno; /* some Xenix systems wipe out errno here */
2653 if (SvNVX(sv) == 0.0)
2654 (void)strcpy(s,"0");
2658 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2661 #ifdef FIXNEGATIVEZERO
2662 if (*s == '-' && s[1] == '0' && !s[2])
2672 if (ckWARN(WARN_UNINITIALIZED)
2673 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2676 if (SvTYPE(sv) < SVt_PV)
2677 /* Typically the caller expects that sv_any is not NULL now. */
2678 sv_upgrade(sv, SVt_PV);
2681 *lp = s - SvPVX(sv);
2684 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2685 PTR2UV(sv),SvPVX(sv)));
2689 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2690 /* Sneaky stuff here */
2694 tsv = newSVpv(tmpbuf, 0);
2710 len = strlen(tmpbuf);
2712 #ifdef FIXNEGATIVEZERO
2713 if (len == 2 && t[0] == '-' && t[1] == '0') {
2718 (void)SvUPGRADE(sv, SVt_PV);
2720 s = SvGROW(sv, len + 1);
2729 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2732 return sv_2pvbyte(sv, &n_a);
2736 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2738 sv_utf8_downgrade(sv,0);
2739 return SvPV(sv,*lp);
2743 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2746 return sv_2pvutf8(sv, &n_a);
2750 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2752 sv_utf8_upgrade(sv);
2753 return SvPV(sv,*lp);
2756 /* This function is only called on magical items */
2758 Perl_sv_2bool(pTHX_ register SV *sv)
2767 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2768 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2769 return SvTRUE(tmpsv);
2770 return SvRV(sv) != 0;
2773 register XPV* Xpvtmp;
2774 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2775 (*Xpvtmp->xpv_pv > '0' ||
2776 Xpvtmp->xpv_cur > 1 ||
2777 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2784 return SvIVX(sv) != 0;
2787 return SvNVX(sv) != 0.0;
2795 =for apidoc sv_utf8_upgrade
2797 Convert the PV of an SV to its UTF8-encoded form.
2798 Forces the SV to string form it it is not already.
2799 Always sets the SvUTF8 flag to avoid future validity checks even
2800 if all the bytes have hibit clear.
2806 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2808 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
2812 =for apidoc sv_utf8_upgrade_flags
2814 Convert the PV of an SV to its UTF8-encoded form.
2815 Forces the SV to string form it it is not already.
2816 Always sets the SvUTF8 flag to avoid future validity checks even
2817 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2818 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2819 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2825 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2835 (void) sv_2pv_flags(sv,&len, flags);
2843 if (SvREADONLY(sv) && SvFAKE(sv)) {
2844 sv_force_normal(sv);
2847 /* This function could be much more efficient if we had a FLAG in SVs
2848 * to signal if there are any hibit chars in the PV.
2849 * Given that there isn't make loop fast as possible
2851 s = (U8 *) SvPVX(sv);
2852 e = (U8 *) SvEND(sv);
2856 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2862 len = SvCUR(sv) + 1; /* Plus the \0 */
2863 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2864 SvCUR(sv) = len - 1;
2866 Safefree(s); /* No longer using what was there before. */
2867 SvLEN(sv) = len; /* No longer know the real size. */
2869 /* Mark as UTF-8 even if no hibit - saves scanning loop */
2875 =for apidoc sv_utf8_downgrade
2877 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2878 This may not be possible if the PV contains non-byte encoding characters;
2879 if this is the case, either returns false or, if C<fail_ok> is not
2886 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2888 if (SvPOK(sv) && SvUTF8(sv)) {
2893 if (SvREADONLY(sv) && SvFAKE(sv))
2894 sv_force_normal(sv);
2895 s = (U8 *) SvPV(sv, len);
2896 if (!utf8_to_bytes(s, &len)) {
2899 #ifdef USE_BYTES_DOWNGRADES
2900 else if (IN_BYTES) {
2902 U8 *e = (U8 *) SvEND(sv);
2905 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
2906 if (first && ch > 255) {
2908 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
2909 PL_op_desc[PL_op->op_type]);
2911 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
2918 len = (d - (U8 *) SvPVX(sv));
2923 Perl_croak(aTHX_ "Wide character in %s",
2924 PL_op_desc[PL_op->op_type]);
2926 Perl_croak(aTHX_ "Wide character");
2937 =for apidoc sv_utf8_encode
2939 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2940 flag so that it looks like octets again. Used as a building block
2941 for encode_utf8 in Encode.xs
2947 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2949 (void) sv_utf8_upgrade(sv);
2954 =for apidoc sv_utf8_decode
2956 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
2957 turn of SvUTF8 if needed so that we see characters. Used as a building block
2958 for decode_utf8 in Encode.xs
2966 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2972 /* The octets may have got themselves encoded - get them back as bytes */
2973 if (!sv_utf8_downgrade(sv, TRUE))
2976 /* it is actually just a matter of turning the utf8 flag on, but
2977 * we want to make sure everything inside is valid utf8 first.
2979 c = (U8 *) SvPVX(sv);
2980 if (!is_utf8_string(c, SvCUR(sv)+1))
2982 e = (U8 *) SvEND(sv);
2985 if (!UTF8_IS_INVARIANT(ch)) {
2995 /* Note: sv_setsv() should not be called with a source string that needs
2996 * to be reused, since it may destroy the source string if it is marked
3001 =for apidoc sv_setsv
3003 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3004 The source SV may be destroyed if it is mortal. Does not handle 'set'
3005 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3011 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3012 for binary compatibility only
3015 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3017 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3021 =for apidoc sv_setsv_flags
3023 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3024 The source SV may be destroyed if it is mortal. Does not handle 'set'
3025 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3026 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3027 in terms of this function.
3033 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3035 register U32 sflags;
3041 SV_CHECK_THINKFIRST(dstr);
3043 sstr = &PL_sv_undef;
3044 stype = SvTYPE(sstr);
3045 dtype = SvTYPE(dstr);
3049 /* There's a lot of redundancy below but we're going for speed here */
3054 if (dtype != SVt_PVGV) {
3055 (void)SvOK_off(dstr);
3063 sv_upgrade(dstr, SVt_IV);
3066 sv_upgrade(dstr, SVt_PVNV);
3070 sv_upgrade(dstr, SVt_PVIV);
3073 (void)SvIOK_only(dstr);
3074 SvIVX(dstr) = SvIVX(sstr);
3077 if (SvTAINTED(sstr))
3088 sv_upgrade(dstr, SVt_NV);
3093 sv_upgrade(dstr, SVt_PVNV);
3096 SvNVX(dstr) = SvNVX(sstr);
3097 (void)SvNOK_only(dstr);
3098 if (SvTAINTED(sstr))
3106 sv_upgrade(dstr, SVt_RV);
3107 else if (dtype == SVt_PVGV &&
3108 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3111 if (GvIMPORTED(dstr) != GVf_IMPORTED
3112 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3114 GvIMPORTED_on(dstr);
3125 sv_upgrade(dstr, SVt_PV);
3128 if (dtype < SVt_PVIV)
3129 sv_upgrade(dstr, SVt_PVIV);
3132 if (dtype < SVt_PVNV)
3133 sv_upgrade(dstr, SVt_PVNV);
3140 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3141 PL_op_name[PL_op->op_type]);
3143 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3147 if (dtype <= SVt_PVGV) {
3149 if (dtype != SVt_PVGV) {
3150 char *name = GvNAME(sstr);
3151 STRLEN len = GvNAMELEN(sstr);
3152 sv_upgrade(dstr, SVt_PVGV);
3153 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3154 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3155 GvNAME(dstr) = savepvn(name, len);
3156 GvNAMELEN(dstr) = len;
3157 SvFAKE_on(dstr); /* can coerce to non-glob */
3159 /* ahem, death to those who redefine active sort subs */
3160 else if (PL_curstackinfo->si_type == PERLSI_SORT
3161 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3162 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3165 #ifdef GV_SHARED_CHECK
3166 if (GvSHARED((GV*)dstr)) {
3167 Perl_croak(aTHX_ PL_no_modify);
3171 (void)SvOK_off(dstr);
3172 GvINTRO_off(dstr); /* one-shot flag */
3174 GvGP(dstr) = gp_ref(GvGP(sstr));
3175 if (SvTAINTED(sstr))
3177 if (GvIMPORTED(dstr) != GVf_IMPORTED
3178 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3180 GvIMPORTED_on(dstr);
3188 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3190 if (SvTYPE(sstr) != stype) {
3191 stype = SvTYPE(sstr);
3192 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3196 if (stype == SVt_PVLV)
3197 (void)SvUPGRADE(dstr, SVt_PVNV);
3199 (void)SvUPGRADE(dstr, stype);
3202 sflags = SvFLAGS(sstr);
3204 if (sflags & SVf_ROK) {
3205 if (dtype >= SVt_PV) {
3206 if (dtype == SVt_PVGV) {
3207 SV *sref = SvREFCNT_inc(SvRV(sstr));
3209 int intro = GvINTRO(dstr);
3211 #ifdef GV_SHARED_CHECK
3212 if (GvSHARED((GV*)dstr)) {
3213 Perl_croak(aTHX_ PL_no_modify);
3218 GvINTRO_off(dstr); /* one-shot flag */
3219 GvLINE(dstr) = CopLINE(PL_curcop);
3220 GvEGV(dstr) = (GV*)dstr;
3223 switch (SvTYPE(sref)) {
3226 SAVESPTR(GvAV(dstr));
3228 dref = (SV*)GvAV(dstr);
3229 GvAV(dstr) = (AV*)sref;
3230 if (!GvIMPORTED_AV(dstr)
3231 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3233 GvIMPORTED_AV_on(dstr);
3238 SAVESPTR(GvHV(dstr));
3240 dref = (SV*)GvHV(dstr);
3241 GvHV(dstr) = (HV*)sref;
3242 if (!GvIMPORTED_HV(dstr)
3243 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3245 GvIMPORTED_HV_on(dstr);
3250 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3251 SvREFCNT_dec(GvCV(dstr));
3252 GvCV(dstr) = Nullcv;
3253 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3254 PL_sub_generation++;
3256 SAVESPTR(GvCV(dstr));
3259 dref = (SV*)GvCV(dstr);
3260 if (GvCV(dstr) != (CV*)sref) {
3261 CV* cv = GvCV(dstr);
3263 if (!GvCVGEN((GV*)dstr) &&
3264 (CvROOT(cv) || CvXSUB(cv)))
3266 /* ahem, death to those who redefine
3267 * active sort subs */
3268 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3269 PL_sortcop == CvSTART(cv))
3271 "Can't redefine active sort subroutine %s",
3272 GvENAME((GV*)dstr));
3273 /* Redefining a sub - warning is mandatory if
3274 it was a const and its value changed. */
3275 if (ckWARN(WARN_REDEFINE)
3277 && (!CvCONST((CV*)sref)
3278 || sv_cmp(cv_const_sv(cv),
3279 cv_const_sv((CV*)sref)))))
3281 Perl_warner(aTHX_ WARN_REDEFINE,
3283 ? "Constant subroutine %s redefined"
3284 : "Subroutine %s redefined",
3285 GvENAME((GV*)dstr));
3288 cv_ckproto(cv, (GV*)dstr,
3289 SvPOK(sref) ? SvPVX(sref) : Nullch);
3291 GvCV(dstr) = (CV*)sref;
3292 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3293 GvASSUMECV_on(dstr);
3294 PL_sub_generation++;
3296 if (!GvIMPORTED_CV(dstr)
3297 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3299 GvIMPORTED_CV_on(dstr);
3304 SAVESPTR(GvIOp(dstr));
3306 dref = (SV*)GvIOp(dstr);
3307 GvIOp(dstr) = (IO*)sref;
3311 SAVESPTR(GvFORM(dstr));
3313 dref = (SV*)GvFORM(dstr);
3314 GvFORM(dstr) = (CV*)sref;
3318 SAVESPTR(GvSV(dstr));
3320 dref = (SV*)GvSV(dstr);
3322 if (!GvIMPORTED_SV(dstr)
3323 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3325 GvIMPORTED_SV_on(dstr);
3333 if (SvTAINTED(sstr))
3338 (void)SvOOK_off(dstr); /* backoff */
3340 Safefree(SvPVX(dstr));
3341 SvLEN(dstr)=SvCUR(dstr)=0;
3344 (void)SvOK_off(dstr);
3345 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3347 if (sflags & SVp_NOK) {
3349 /* Only set the public OK flag if the source has public OK. */
3350 if (sflags & SVf_NOK)
3351 SvFLAGS(dstr) |= SVf_NOK;
3352 SvNVX(dstr) = SvNVX(sstr);
3354 if (sflags & SVp_IOK) {
3355 (void)SvIOKp_on(dstr);
3356 if (sflags & SVf_IOK)
3357 SvFLAGS(dstr) |= SVf_IOK;
3358 if (sflags & SVf_IVisUV)
3360 SvIVX(dstr) = SvIVX(sstr);
3362 if (SvAMAGIC(sstr)) {
3366 else if (sflags & SVp_POK) {
3369 * Check to see if we can just swipe the string. If so, it's a
3370 * possible small lose on short strings, but a big win on long ones.
3371 * It might even be a win on short strings if SvPVX(dstr)
3372 * has to be allocated and SvPVX(sstr) has to be freed.
3375 if (SvTEMP(sstr) && /* slated for free anyway? */
3376 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3377 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3378 SvLEN(sstr) && /* and really is a string */
3379 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3381 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3383 SvFLAGS(dstr) &= ~SVf_OOK;
3384 Safefree(SvPVX(dstr) - SvIVX(dstr));
3386 else if (SvLEN(dstr))
3387 Safefree(SvPVX(dstr));
3389 (void)SvPOK_only(dstr);
3390 SvPV_set(dstr, SvPVX(sstr));
3391 SvLEN_set(dstr, SvLEN(sstr));
3392 SvCUR_set(dstr, SvCUR(sstr));
3395 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3396 SvPV_set(sstr, Nullch);
3401 else { /* have to copy actual string */
3402 STRLEN len = SvCUR(sstr);
3404 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3405 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3406 SvCUR_set(dstr, len);
3407 *SvEND(dstr) = '\0';
3408 (void)SvPOK_only(dstr);
3410 if (sflags & SVf_UTF8)
3413 if (sflags & SVp_NOK) {
3415 if (sflags & SVf_NOK)
3416 SvFLAGS(dstr) |= SVf_NOK;
3417 SvNVX(dstr) = SvNVX(sstr);
3419 if (sflags & SVp_IOK) {
3420 (void)SvIOKp_on(dstr);
3421 if (sflags & SVf_IOK)
3422 SvFLAGS(dstr) |= SVf_IOK;
3423 if (sflags & SVf_IVisUV)
3425 SvIVX(dstr) = SvIVX(sstr);
3428 else if (sflags & SVp_IOK) {
3429 if (sflags & SVf_IOK)
3430 (void)SvIOK_only(dstr);
3432 (void)SvOK_off(dstr);
3433 (void)SvIOKp_on(dstr);
3435 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3436 if (sflags & SVf_IVisUV)
3438 SvIVX(dstr) = SvIVX(sstr);
3439 if (sflags & SVp_NOK) {
3440 if (sflags & SVf_NOK)
3441 (void)SvNOK_on(dstr);
3443 (void)SvNOKp_on(dstr);
3444 SvNVX(dstr) = SvNVX(sstr);
3447 else if (sflags & SVp_NOK) {
3448 if (sflags & SVf_NOK)
3449 (void)SvNOK_only(dstr);
3451 (void)SvOK_off(dstr);
3454 SvNVX(dstr) = SvNVX(sstr);
3457 if (dtype == SVt_PVGV) {
3458 if (ckWARN(WARN_MISC))
3459 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3462 (void)SvOK_off(dstr);
3464 if (SvTAINTED(sstr))
3469 =for apidoc sv_setsv_mg
3471 Like C<sv_setsv>, but also handles 'set' magic.
3477 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3479 sv_setsv(dstr,sstr);
3484 =for apidoc sv_setpvn
3486 Copies a string into an SV. The C<len> parameter indicates the number of
3487 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3493 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3495 register char *dptr;
3497 SV_CHECK_THINKFIRST(sv);
3503 /* len is STRLEN which is unsigned, need to copy to signed */
3506 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3508 (void)SvUPGRADE(sv, SVt_PV);
3510 SvGROW(sv, len + 1);
3512 Move(ptr,dptr,len,char);
3515 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3520 =for apidoc sv_setpvn_mg
3522 Like C<sv_setpvn>, but also handles 'set' magic.
3528 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3530 sv_setpvn(sv,ptr,len);
3535 =for apidoc sv_setpv
3537 Copies a string into an SV. The string must be null-terminated. Does not
3538 handle 'set' magic. See C<sv_setpv_mg>.
3544 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3546 register STRLEN len;
3548 SV_CHECK_THINKFIRST(sv);
3554 (void)SvUPGRADE(sv, SVt_PV);
3556 SvGROW(sv, len + 1);
3557 Move(ptr,SvPVX(sv),len+1,char);
3559 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3564 =for apidoc sv_setpv_mg
3566 Like C<sv_setpv>, but also handles 'set' magic.
3572 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3579 =for apidoc sv_usepvn
3581 Tells an SV to use C<ptr> to find its string value. Normally the string is
3582 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3583 The C<ptr> should point to memory that was allocated by C<malloc>. The
3584 string length, C<len>, must be supplied. This function will realloc the
3585 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3586 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3587 See C<sv_usepvn_mg>.
3593 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3595 SV_CHECK_THINKFIRST(sv);
3596 (void)SvUPGRADE(sv, SVt_PV);
3601 (void)SvOOK_off(sv);
3602 if (SvPVX(sv) && SvLEN(sv))
3603 Safefree(SvPVX(sv));
3604 Renew(ptr, len+1, char);
3607 SvLEN_set(sv, len+1);
3609 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3614 =for apidoc sv_usepvn_mg
3616 Like C<sv_usepvn>, but also handles 'set' magic.
3622 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3624 sv_usepvn(sv,ptr,len);
3629 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3631 if (SvREADONLY(sv)) {
3633 char *pvx = SvPVX(sv);
3634 STRLEN len = SvCUR(sv);
3635 U32 hash = SvUVX(sv);
3636 SvGROW(sv, len + 1);
3637 Move(pvx,SvPVX(sv),len,char);
3641 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3643 else if (PL_curcop != &PL_compiling)
3644 Perl_croak(aTHX_ PL_no_modify);
3647 sv_unref_flags(sv, flags);
3648 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3653 Perl_sv_force_normal(pTHX_ register SV *sv)
3655 sv_force_normal_flags(sv, 0);
3661 Efficient removal of characters from the beginning of the string buffer.
3662 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3663 the string buffer. The C<ptr> becomes the first character of the adjusted
3670 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3674 register STRLEN delta;
3676 if (!ptr || !SvPOKp(sv))
3678 SV_CHECK_THINKFIRST(sv);
3679 if (SvTYPE(sv) < SVt_PVIV)
3680 sv_upgrade(sv,SVt_PVIV);
3683 if (!SvLEN(sv)) { /* make copy of shared string */
3684 char *pvx = SvPVX(sv);
3685 STRLEN len = SvCUR(sv);
3686 SvGROW(sv, len + 1);
3687 Move(pvx,SvPVX(sv),len,char);
3691 SvFLAGS(sv) |= SVf_OOK;
3693 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3694 delta = ptr - SvPVX(sv);
3702 =for apidoc sv_catpvn
3704 Concatenates the string onto the end of the string which is in the SV. The
3705 C<len> indicates number of bytes to copy. If the SV has the UTF8
3706 status set, then the bytes appended should be valid UTF8.
3707 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3712 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3713 for binary compatibility only
3716 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3718 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3722 =for apidoc sv_catpvn_flags
3724 Concatenates the string onto the end of the string which is in the SV. The
3725 C<len> indicates number of bytes to copy. If the SV has the UTF8
3726 status set, then the bytes appended should be valid UTF8.
3727 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3728 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3729 in terms of this function.
3735 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3740 dstr = SvPV_force_flags(dsv, dlen, flags);
3741 SvGROW(dsv, dlen + slen + 1);
3744 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3747 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3752 =for apidoc sv_catpvn_mg
3754 Like C<sv_catpvn>, but also handles 'set' magic.
3760 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3762 sv_catpvn(sv,ptr,len);
3767 =for apidoc sv_catsv
3769 Concatenates the string from SV C<ssv> onto the end of the string in
3770 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3771 not 'set' magic. See C<sv_catsv_mg>.
3775 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3776 for binary compatibility only
3779 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3781 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3785 =for apidoc sv_catsv_flags
3787 Concatenates the string from SV C<ssv> onto the end of the string in
3788 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3789 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3790 and C<sv_catsv_nomg> are implemented in terms of this function.
3795 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3801 if ((spv = SvPV(ssv, slen))) {
3802 bool sutf8 = DO_UTF8(ssv);
3805 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3807 dutf8 = DO_UTF8(dsv);
3809 if (dutf8 != sutf8) {
3811 /* Not modifying source SV, so taking a temporary copy. */
3812 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3814 sv_utf8_upgrade(csv);
3815 spv = SvPV(csv, slen);
3818 sv_utf8_upgrade_nomg(dsv);
3820 sv_catpvn_nomg(dsv, spv, slen);
3825 =for apidoc sv_catsv_mg
3827 Like C<sv_catsv>, but also handles 'set' magic.
3833 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3840 =for apidoc sv_catpv
3842 Concatenates the string onto the end of the string which is in the SV.
3843 If the SV has the UTF8 status set, then the bytes appended should be
3844 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3849 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3851 register STRLEN len;
3857 junk = SvPV_force(sv, tlen);
3859 SvGROW(sv, tlen + len + 1);
3862 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3864 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3869 =for apidoc sv_catpv_mg
3871 Like C<sv_catpv>, but also handles 'set' magic.
3877 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3884 Perl_newSV(pTHX_ STRLEN len)
3890 sv_upgrade(sv, SVt_PV);
3891 SvGROW(sv, len + 1);
3896 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3899 =for apidoc sv_magic
3901 Adds magic to an SV.
3907 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3911 if (SvREADONLY(sv)) {
3912 if (PL_curcop != &PL_compiling
3913 /* XXX this used to be !strchr("gBf", how), which seems to
3914 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
3915 * too. I find this suprising, but have hadded PERL_MAGIC_sv
3916 * to the list of things to check - DAPM 19-May-01 */
3917 && how != PERL_MAGIC_regex_global
3918 && how != PERL_MAGIC_bm
3919 && how != PERL_MAGIC_fm
3920 && how != PERL_MAGIC_sv
3923 Perl_croak(aTHX_ PL_no_modify);
3926 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
3927 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3928 if (how == PERL_MAGIC_taint)
3934 (void)SvUPGRADE(sv, SVt_PVMG);
3936 Newz(702,mg, 1, MAGIC);
3937 mg->mg_moremagic = SvMAGIC(sv);
3940 /* Some magic sontains a reference loop, where the sv and object refer to
3941 each other. To prevent a avoid a reference loop that would prevent such
3942 objects being freed, we look for such loops and if we find one we avoid
3943 incrementing the object refcount. */
3944 if (!obj || obj == sv ||
3945 how == PERL_MAGIC_arylen ||
3946 how == PERL_MAGIC_qr ||
3947 (SvTYPE(obj) == SVt_PVGV &&
3948 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
3949 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
3950 GvFORM(obj) == (CV*)sv)))
3955 mg->mg_obj = SvREFCNT_inc(obj);
3956 mg->mg_flags |= MGf_REFCOUNTED;
3959 mg->mg_len = namlen;
3962 mg->mg_ptr = savepvn(name, namlen);
3963 else if (namlen == HEf_SVKEY)
3964 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3969 mg->mg_virtual = &PL_vtbl_sv;
3971 case PERL_MAGIC_overload:
3972 mg->mg_virtual = &PL_vtbl_amagic;
3974 case PERL_MAGIC_overload_elem:
3975 mg->mg_virtual = &PL_vtbl_amagicelem;
3977 case PERL_MAGIC_overload_table:
3978 mg->mg_virtual = &PL_vtbl_ovrld;
3981 mg->mg_virtual = &PL_vtbl_bm;
3983 case PERL_MAGIC_regdata:
3984 mg->mg_virtual = &PL_vtbl_regdata;
3986 case PERL_MAGIC_regdatum:
3987 mg->mg_virtual = &PL_vtbl_regdatum;
3989 case PERL_MAGIC_env:
3990 mg->mg_virtual = &PL_vtbl_env;
3993 mg->mg_virtual = &PL_vtbl_fm;
3995 case PERL_MAGIC_envelem:
3996 mg->mg_virtual = &PL_vtbl_envelem;
3998 case PERL_MAGIC_regex_global:
3999 mg->mg_virtual = &PL_vtbl_mglob;
4001 case PERL_MAGIC_isa:
4002 mg->mg_virtual = &PL_vtbl_isa;
4004 case PERL_MAGIC_isaelem:
4005 mg->mg_virtual = &PL_vtbl_isaelem;
4007 case PERL_MAGIC_nkeys:
4008 mg->mg_virtual = &PL_vtbl_nkeys;
4010 case PERL_MAGIC_dbfile:
4014 case PERL_MAGIC_dbline:
4015 mg->mg_virtual = &PL_vtbl_dbline;
4018 case PERL_MAGIC_mutex:
4019 mg->mg_virtual = &PL_vtbl_mutex;
4021 #endif /* USE_THREADS */
4022 #ifdef USE_LOCALE_COLLATE
4023 case PERL_MAGIC_collxfrm:
4024 mg->mg_virtual = &PL_vtbl_collxfrm;
4026 #endif /* USE_LOCALE_COLLATE */
4027 case PERL_MAGIC_tied:
4028 mg->mg_virtual = &PL_vtbl_pack;
4030 case PERL_MAGIC_tiedelem:
4031 case PERL_MAGIC_tiedscalar:
4032 mg->mg_virtual = &PL_vtbl_packelem;
4035 mg->mg_virtual = &PL_vtbl_regexp;
4037 case PERL_MAGIC_sig:
4038 mg->mg_virtual = &PL_vtbl_sig;
4040 case PERL_MAGIC_sigelem:
4041 mg->mg_virtual = &PL_vtbl_sigelem;
4043 case PERL_MAGIC_taint:
4044 mg->mg_virtual = &PL_vtbl_taint;
4047 case PERL_MAGIC_uvar:
4048 mg->mg_virtual = &PL_vtbl_uvar;
4050 case PERL_MAGIC_vec:
4051 mg->mg_virtual = &PL_vtbl_vec;
4053 case PERL_MAGIC_substr:
4054 mg->mg_virtual = &PL_vtbl_substr;
4056 case PERL_MAGIC_defelem:
4057 mg->mg_virtual = &PL_vtbl_defelem;
4059 case PERL_MAGIC_glob:
4060 mg->mg_virtual = &PL_vtbl_glob;
4062 case PERL_MAGIC_arylen:
4063 mg->mg_virtual = &PL_vtbl_arylen;
4065 case PERL_MAGIC_pos:
4066 mg->mg_virtual = &PL_vtbl_pos;
4068 case PERL_MAGIC_backref:
4069 mg->mg_virtual = &PL_vtbl_backref;
4071 case PERL_MAGIC_ext:
4072 /* Reserved for use by extensions not perl internals. */
4073 /* Useful for attaching extension internal data to perl vars. */
4074 /* Note that multiple extensions may clash if magical scalars */
4075 /* etc holding private data from one are passed to another. */
4079 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4083 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4087 =for apidoc sv_unmagic
4089 Removes magic from an SV.
4095 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4099 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4102 for (mg = *mgp; mg; mg = *mgp) {
4103 if (mg->mg_type == type) {
4104 MGVTBL* vtbl = mg->mg_virtual;
4105 *mgp = mg->mg_moremagic;
4106 if (vtbl && vtbl->svt_free)
4107 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4108 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4109 if (mg->mg_len >= 0)
4110 Safefree(mg->mg_ptr);
4111 else if (mg->mg_len == HEf_SVKEY)
4112 SvREFCNT_dec((SV*)mg->mg_ptr);
4114 if (mg->mg_flags & MGf_REFCOUNTED)
4115 SvREFCNT_dec(mg->mg_obj);
4119 mgp = &mg->mg_moremagic;
4123 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4130 =for apidoc sv_rvweaken
4138 Perl_sv_rvweaken(pTHX_ SV *sv)
4141 if (!SvOK(sv)) /* let undefs pass */
4144 Perl_croak(aTHX_ "Can't weaken a nonreference");
4145 else if (SvWEAKREF(sv)) {
4146 if (ckWARN(WARN_MISC))
4147 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4151 sv_add_backref(tsv, sv);
4158 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4162 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4163 av = (AV*)mg->mg_obj;
4166 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4167 SvREFCNT_dec(av); /* for sv_magic */
4173 S_sv_del_backref(pTHX_ SV *sv)
4180 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4181 Perl_croak(aTHX_ "panic: del_backref");
4182 av = (AV *)mg->mg_obj;
4187 svp[i] = &PL_sv_undef; /* XXX */
4194 =for apidoc sv_insert
4196 Inserts a string at the specified offset/length within the SV. Similar to
4197 the Perl substr() function.
4203 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4207 register char *midend;
4208 register char *bigend;
4214 Perl_croak(aTHX_ "Can't modify non-existent substring");
4215 SvPV_force(bigstr, curlen);
4216 (void)SvPOK_only_UTF8(bigstr);
4217 if (offset + len > curlen) {
4218 SvGROW(bigstr, offset+len+1);
4219 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4220 SvCUR_set(bigstr, offset+len);
4224 i = littlelen - len;
4225 if (i > 0) { /* string might grow */
4226 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4227 mid = big + offset + len;
4228 midend = bigend = big + SvCUR(bigstr);
4231 while (midend > mid) /* shove everything down */
4232 *--bigend = *--midend;
4233 Move(little,big+offset,littlelen,char);
4239 Move(little,SvPVX(bigstr)+offset,len,char);
4244 big = SvPVX(bigstr);
4247 bigend = big + SvCUR(bigstr);
4249 if (midend > bigend)
4250 Perl_croak(aTHX_ "panic: sv_insert");
4252 if (mid - big > bigend - midend) { /* faster to shorten from end */
4254 Move(little, mid, littlelen,char);
4257 i = bigend - midend;
4259 Move(midend, mid, i,char);
4263 SvCUR_set(bigstr, mid - big);
4266 else if ((i = mid - big)) { /* faster from front */
4267 midend -= littlelen;
4269 sv_chop(bigstr,midend-i);
4274 Move(little, mid, littlelen,char);
4276 else if (littlelen) {
4277 midend -= littlelen;
4278 sv_chop(bigstr,midend);
4279 Move(little,midend,littlelen,char);
4282 sv_chop(bigstr,midend);
4288 =for apidoc sv_replace
4290 Make the first argument a copy of the second, then delete the original.
4296 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4298 U32 refcnt = SvREFCNT(sv);
4299 SV_CHECK_THINKFIRST(sv);
4300 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4301 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4302 if (SvMAGICAL(sv)) {
4306 sv_upgrade(nsv, SVt_PVMG);
4307 SvMAGIC(nsv) = SvMAGIC(sv);
4308 SvFLAGS(nsv) |= SvMAGICAL(sv);
4314 assert(!SvREFCNT(sv));
4315 StructCopy(nsv,sv,SV);
4316 SvREFCNT(sv) = refcnt;
4317 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4322 =for apidoc sv_clear
4324 Clear an SV, making it empty. Does not free the memory used by the SV
4331 Perl_sv_clear(pTHX_ register SV *sv)
4335 assert(SvREFCNT(sv) == 0);
4338 if (PL_defstash) { /* Still have a symbol table? */
4343 Zero(&tmpref, 1, SV);
4344 sv_upgrade(&tmpref, SVt_RV);
4346 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4347 SvREFCNT(&tmpref) = 1;
4350 stash = SvSTASH(sv);
4351 destructor = StashHANDLER(stash,DESTROY);
4354 PUSHSTACKi(PERLSI_DESTROY);
4355 SvRV(&tmpref) = SvREFCNT_inc(sv);
4360 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4366 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4368 del_XRV(SvANY(&tmpref));
4371 if (PL_in_clean_objs)
4372 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4374 /* DESTROY gave object new lease on life */
4380 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4381 SvOBJECT_off(sv); /* Curse the object. */
4382 if (SvTYPE(sv) != SVt_PVIO)
4383 --PL_sv_objcount; /* XXX Might want something more general */
4386 if (SvTYPE(sv) >= SVt_PVMG) {
4389 if (SvFLAGS(sv) & SVpad_TYPED)
4390 SvREFCNT_dec(SvSTASH(sv));
4393 switch (SvTYPE(sv)) {
4396 IoIFP(sv) != PerlIO_stdin() &&
4397 IoIFP(sv) != PerlIO_stdout() &&
4398 IoIFP(sv) != PerlIO_stderr())
4400 io_close((IO*)sv, FALSE);
4402 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4403 PerlDir_close(IoDIRP(sv));
4404 IoDIRP(sv) = (DIR*)NULL;
4405 Safefree(IoTOP_NAME(sv));
4406 Safefree(IoFMT_NAME(sv));
4407 Safefree(IoBOTTOM_NAME(sv));
4422 SvREFCNT_dec(LvTARG(sv));
4426 Safefree(GvNAME(sv));
4427 /* cannot decrease stash refcount yet, as we might recursively delete
4428 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4429 of stash until current sv is completely gone.
4430 -- JohnPC, 27 Mar 1998 */
4431 stash = GvSTASH(sv);
4437 (void)SvOOK_off(sv);
4445 SvREFCNT_dec(SvRV(sv));
4447 else if (SvPVX(sv) && SvLEN(sv))
4448 Safefree(SvPVX(sv));
4449 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4450 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4462 switch (SvTYPE(sv)) {
4478 del_XPVIV(SvANY(sv));
4481 del_XPVNV(SvANY(sv));
4484 del_XPVMG(SvANY(sv));
4487 del_XPVLV(SvANY(sv));
4490 del_XPVAV(SvANY(sv));
4493 del_XPVHV(SvANY(sv));
4496 del_XPVCV(SvANY(sv));
4499 del_XPVGV(SvANY(sv));
4500 /* code duplication for increased performance. */
4501 SvFLAGS(sv) &= SVf_BREAK;
4502 SvFLAGS(sv) |= SVTYPEMASK;
4503 /* decrease refcount of the stash that owns this GV, if any */
4505 SvREFCNT_dec(stash);
4506 return; /* not break, SvFLAGS reset already happened */
4508 del_XPVBM(SvANY(sv));
4511 del_XPVFM(SvANY(sv));
4514 del_XPVIO(SvANY(sv));
4517 SvFLAGS(sv) &= SVf_BREAK;
4518 SvFLAGS(sv) |= SVTYPEMASK;
4522 Perl_sv_newref(pTHX_ SV *sv)
4525 ATOMIC_INC(SvREFCNT(sv));
4532 Free the memory used by an SV.
4538 Perl_sv_free(pTHX_ SV *sv)
4540 int refcount_is_zero;
4544 if (SvREFCNT(sv) == 0) {
4545 if (SvFLAGS(sv) & SVf_BREAK)
4547 if (PL_in_clean_all) /* All is fair */
4549 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4550 /* make sure SvREFCNT(sv)==0 happens very seldom */
4551 SvREFCNT(sv) = (~(U32)0)/2;
4554 if (ckWARN_d(WARN_INTERNAL))
4555 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4558 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4559 if (!refcount_is_zero)
4563 if (ckWARN_d(WARN_DEBUGGING))
4564 Perl_warner(aTHX_ WARN_DEBUGGING,
4565 "Attempt to free temp prematurely: SV 0x%"UVxf,
4570 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4571 /* make sure SvREFCNT(sv)==0 happens very seldom */
4572 SvREFCNT(sv) = (~(U32)0)/2;
4583 Returns the length of the string in the SV. See also C<SvCUR>.
4589 Perl_sv_len(pTHX_ register SV *sv)
4598 len = mg_length(sv);
4600 junk = SvPV(sv, len);
4605 =for apidoc sv_len_utf8
4607 Returns the number of characters in the string in an SV, counting wide
4608 UTF8 bytes as a single character.
4614 Perl_sv_len_utf8(pTHX_ register SV *sv)
4620 return mg_length(sv);
4624 U8 *s = (U8*)SvPV(sv, len);
4626 return Perl_utf8_length(aTHX_ s, s + len);
4631 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4636 I32 uoffset = *offsetp;
4642 start = s = (U8*)SvPV(sv, len);
4644 while (s < send && uoffset--)
4648 *offsetp = s - start;
4652 while (s < send && ulen--)
4662 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4671 s = (U8*)SvPV(sv, len);
4673 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4674 send = s + *offsetp;
4678 /* Call utf8n_to_uvchr() to validate the sequence */
4679 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4694 Returns a boolean indicating whether the strings in the two SVs are
4701 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4715 pv1 = SvPV(sv1, cur1);
4722 pv2 = SvPV(sv2, cur2);
4724 /* do not utf8ize the comparands as a side-effect */
4725 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4726 bool is_utf8 = TRUE;
4727 /* UTF-8ness differs */
4728 if (PL_hints & HINT_UTF8_DISTINCT)
4732 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4733 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4738 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4739 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4744 /* Downgrade not possible - cannot be eq */
4750 eq = memEQ(pv1, pv2, cur1);
4761 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4762 string in C<sv1> is less than, equal to, or greater than the string in
4769 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4774 bool pv1tmp = FALSE;
4775 bool pv2tmp = FALSE;
4782 pv1 = SvPV(sv1, cur1);
4789 pv2 = SvPV(sv2, cur2);
4791 /* do not utf8ize the comparands as a side-effect */
4792 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4793 if (PL_hints & HINT_UTF8_DISTINCT)
4794 return SvUTF8(sv1) ? 1 : -1;
4797 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4801 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4807 cmp = cur2 ? -1 : 0;
4811 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4814 cmp = retval < 0 ? -1 : 1;
4815 } else if (cur1 == cur2) {
4818 cmp = cur1 < cur2 ? -1 : 1;
4831 =for apidoc sv_cmp_locale
4833 Compares the strings in two SVs in a locale-aware manner. See
4840 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4842 #ifdef USE_LOCALE_COLLATE
4848 if (PL_collation_standard)
4852 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4854 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4856 if (!pv1 || !len1) {
4867 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4870 return retval < 0 ? -1 : 1;
4873 * When the result of collation is equality, that doesn't mean
4874 * that there are no differences -- some locales exclude some
4875 * characters from consideration. So to avoid false equalities,
4876 * we use the raw string as a tiebreaker.
4882 #endif /* USE_LOCALE_COLLATE */
4884 return sv_cmp(sv1, sv2);
4887 #ifdef USE_LOCALE_COLLATE
4889 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
4890 * scalar data of the variable transformed to such a format that
4891 * a normal memory comparison can be used to compare the data
4892 * according to the locale settings.
4895 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4899 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
4900 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4905 Safefree(mg->mg_ptr);
4907 if ((xf = mem_collxfrm(s, len, &xlen))) {
4908 if (SvREADONLY(sv)) {
4911 return xf + sizeof(PL_collation_ix);
4914 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
4915 mg = mg_find(sv, PERL_MAGIC_collxfrm);
4928 if (mg && mg->mg_ptr) {
4930 return mg->mg_ptr + sizeof(PL_collation_ix);
4938 #endif /* USE_LOCALE_COLLATE */
4943 Get a line from the filehandle and store it into the SV, optionally
4944 appending to the currently-stored string.
4950 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4954 register STDCHAR rslast;
4955 register STDCHAR *bp;
4959 SV_CHECK_THINKFIRST(sv);
4960 (void)SvUPGRADE(sv, SVt_PV);
4964 if (RsSNARF(PL_rs)) {
4968 else if (RsRECORD(PL_rs)) {
4969 I32 recsize, bytesread;
4972 /* Grab the size of the record we're getting */
4973 recsize = SvIV(SvRV(PL_rs));
4974 (void)SvPOK_only(sv); /* Validate pointer */
4975 buffer = SvGROW(sv, recsize + 1);
4978 /* VMS wants read instead of fread, because fread doesn't respect */
4979 /* RMS record boundaries. This is not necessarily a good thing to be */
4980 /* doing, but we've got no other real choice */
4981 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4983 bytesread = PerlIO_read(fp, buffer, recsize);
4985 SvCUR_set(sv, bytesread);
4986 buffer[bytesread] = '\0';
4987 if (PerlIO_isutf8(fp))
4991 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4993 else if (RsPARA(PL_rs)) {
4998 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4999 if (PerlIO_isutf8(fp)) {
5000 rsptr = SvPVutf8(PL_rs, rslen);
5003 if (SvUTF8(PL_rs)) {
5004 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5005 Perl_croak(aTHX_ "Wide character in $/");
5008 rsptr = SvPV(PL_rs, rslen);
5012 rslast = rslen ? rsptr[rslen - 1] : '\0';
5014 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5015 do { /* to make sure file boundaries work right */
5018 i = PerlIO_getc(fp);
5022 PerlIO_ungetc(fp,i);
5028 /* See if we know enough about I/O mechanism to cheat it ! */
5030 /* This used to be #ifdef test - it is made run-time test for ease
5031 of abstracting out stdio interface. One call should be cheap
5032 enough here - and may even be a macro allowing compile
5036 if (PerlIO_fast_gets(fp)) {
5039 * We're going to steal some values from the stdio struct
5040 * and put EVERYTHING in the innermost loop into registers.
5042 register STDCHAR *ptr;
5046 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5047 /* An ungetc()d char is handled separately from the regular
5048 * buffer, so we getc() it back out and stuff it in the buffer.
5050 i = PerlIO_getc(fp);
5051 if (i == EOF) return 0;
5052 *(--((*fp)->_ptr)) = (unsigned char) i;
5056 /* Here is some breathtakingly efficient cheating */
5058 cnt = PerlIO_get_cnt(fp); /* get count into register */
5059 (void)SvPOK_only(sv); /* validate pointer */
5060 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5061 if (cnt > 80 && SvLEN(sv) > append) {
5062 shortbuffered = cnt - SvLEN(sv) + append + 1;
5063 cnt -= shortbuffered;
5067 /* remember that cnt can be negative */
5068 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5073 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5074 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5075 DEBUG_P(PerlIO_printf(Perl_debug_log,
5076 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5077 DEBUG_P(PerlIO_printf(Perl_debug_log,
5078 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5079 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5080 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5085 while (cnt > 0) { /* this | eat */
5087 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5088 goto thats_all_folks; /* screams | sed :-) */
5092 Copy(ptr, bp, cnt, char); /* this | eat */
5093 bp += cnt; /* screams | dust */
5094 ptr += cnt; /* louder | sed :-) */
5099 if (shortbuffered) { /* oh well, must extend */
5100 cnt = shortbuffered;
5102 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5104 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5105 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5109 DEBUG_P(PerlIO_printf(Perl_debug_log,
5110 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5111 PTR2UV(ptr),(long)cnt));
5112 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5113 DEBUG_P(PerlIO_printf(Perl_debug_log,
5114 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5115 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5116 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5117 /* This used to call 'filbuf' in stdio form, but as that behaves like
5118 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5119 another abstraction. */
5120 i = PerlIO_getc(fp); /* get more characters */
5121 DEBUG_P(PerlIO_printf(Perl_debug_log,
5122 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5123 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5124 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5125 cnt = PerlIO_get_cnt(fp);
5126 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5127 DEBUG_P(PerlIO_printf(Perl_debug_log,
5128 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5130 if (i == EOF) /* all done for ever? */
5131 goto thats_really_all_folks;
5133 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5135 SvGROW(sv, bpx + cnt + 2);
5136 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5138 *bp++ = i; /* store character from PerlIO_getc */
5140 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5141 goto thats_all_folks;
5145 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5146 memNE((char*)bp - rslen, rsptr, rslen))
5147 goto screamer; /* go back to the fray */
5148 thats_really_all_folks:
5150 cnt += shortbuffered;
5151 DEBUG_P(PerlIO_printf(Perl_debug_log,
5152 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5153 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5154 DEBUG_P(PerlIO_printf(Perl_debug_log,
5155 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5156 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5157 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5159 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5160 DEBUG_P(PerlIO_printf(Perl_debug_log,
5161 "Screamer: done, len=%ld, string=|%.*s|\n",
5162 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5167 /*The big, slow, and stupid way */
5170 /* Need to work around EPOC SDK features */
5171 /* On WINS: MS VC5 generates calls to _chkstk, */
5172 /* if a `large' stack frame is allocated */
5173 /* gcc on MARM does not generate calls like these */
5179 register STDCHAR *bpe = buf + sizeof(buf);
5181 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5182 ; /* keep reading */
5186 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5187 /* Accomodate broken VAXC compiler, which applies U8 cast to
5188 * both args of ?: operator, causing EOF to change into 255
5190 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5194 sv_catpvn(sv, (char *) buf, cnt);
5196 sv_setpvn(sv, (char *) buf, cnt);
5198 if (i != EOF && /* joy */
5200 SvCUR(sv) < rslen ||
5201 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5205 * If we're reading from a TTY and we get a short read,
5206 * indicating that the user hit his EOF character, we need
5207 * to notice it now, because if we try to read from the TTY
5208 * again, the EOF condition will disappear.
5210 * The comparison of cnt to sizeof(buf) is an optimization
5211 * that prevents unnecessary calls to feof().
5215 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5220 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5221 while (i != EOF) { /* to make sure file boundaries work right */
5222 i = PerlIO_getc(fp);
5224 PerlIO_ungetc(fp,i);
5230 if (PerlIO_isutf8(fp))
5235 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5242 Auto-increment of the value in the SV.
5248 Perl_sv_inc(pTHX_ register SV *sv)
5257 if (SvTHINKFIRST(sv)) {
5258 if (SvREADONLY(sv)) {
5259 if (PL_curcop != &PL_compiling)
5260 Perl_croak(aTHX_ PL_no_modify);
5264 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5266 i = PTR2IV(SvRV(sv));
5271 flags = SvFLAGS(sv);
5272 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5273 /* It's (privately or publicly) a float, but not tested as an
5274 integer, so test it to see. */
5276 flags = SvFLAGS(sv);
5278 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5279 /* It's publicly an integer, or privately an integer-not-float */
5282 if (SvUVX(sv) == UV_MAX)
5283 sv_setnv(sv, (NV)UV_MAX + 1.0);
5285 (void)SvIOK_only_UV(sv);
5288 if (SvIVX(sv) == IV_MAX)
5289 sv_setuv(sv, (UV)IV_MAX + 1);
5291 (void)SvIOK_only(sv);
5297 if (flags & SVp_NOK) {
5298 (void)SvNOK_only(sv);
5303 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5304 if ((flags & SVTYPEMASK) < SVt_PVIV)
5305 sv_upgrade(sv, SVt_IV);
5306 (void)SvIOK_only(sv);
5311 while (isALPHA(*d)) d++;
5312 while (isDIGIT(*d)) d++;
5314 #ifdef PERL_PRESERVE_IVUV
5315 /* Got to punt this an an integer if needs be, but we don't issue
5316 warnings. Probably ought to make the sv_iv_please() that does
5317 the conversion if possible, and silently. */
5318 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5319 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5320 /* Need to try really hard to see if it's an integer.
5321 9.22337203685478e+18 is an integer.
5322 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5323 so $a="9.22337203685478e+18"; $a+0; $a++
5324 needs to be the same as $a="9.22337203685478e+18"; $a++
5331 /* sv_2iv *should* have made this an NV */
5332 if (flags & SVp_NOK) {
5333 (void)SvNOK_only(sv);
5337 /* I don't think we can get here. Maybe I should assert this
5338 And if we do get here I suspect that sv_setnv will croak. NWC
5340 #if defined(USE_LONG_DOUBLE)
5341 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",
5342 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5344 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5345 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5348 #endif /* PERL_PRESERVE_IVUV */
5349 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5353 while (d >= SvPVX(sv)) {
5361 /* MKS: The original code here died if letters weren't consecutive.
5362 * at least it didn't have to worry about non-C locales. The
5363 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5364 * arranged in order (although not consecutively) and that only
5365 * [A-Za-z] are accepted by isALPHA in the C locale.
5367 if (*d != 'z' && *d != 'Z') {
5368 do { ++*d; } while (!isALPHA(*d));
5371 *(d--) -= 'z' - 'a';
5376 *(d--) -= 'z' - 'a' + 1;
5380 /* oh,oh, the number grew */
5381 SvGROW(sv, SvCUR(sv) + 2);
5383 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5394 Auto-decrement of the value in the SV.
5400 Perl_sv_dec(pTHX_ register SV *sv)
5408 if (SvTHINKFIRST(sv)) {
5409 if (SvREADONLY(sv)) {
5410 if (PL_curcop != &PL_compiling)
5411 Perl_croak(aTHX_ PL_no_modify);
5415 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5417 i = PTR2IV(SvRV(sv));
5422 /* Unlike sv_inc we don't have to worry about string-never-numbers
5423 and keeping them magic. But we mustn't warn on punting */
5424 flags = SvFLAGS(sv);
5425 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5426 /* It's publicly an integer, or privately an integer-not-float */
5429 if (SvUVX(sv) == 0) {
5430 (void)SvIOK_only(sv);
5434 (void)SvIOK_only_UV(sv);
5438 if (SvIVX(sv) == IV_MIN)
5439 sv_setnv(sv, (NV)IV_MIN - 1.0);
5441 (void)SvIOK_only(sv);
5447 if (flags & SVp_NOK) {
5449 (void)SvNOK_only(sv);
5452 if (!(flags & SVp_POK)) {
5453 if ((flags & SVTYPEMASK) < SVt_PVNV)
5454 sv_upgrade(sv, SVt_NV);
5456 (void)SvNOK_only(sv);
5459 #ifdef PERL_PRESERVE_IVUV
5461 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5462 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5463 /* Need to try really hard to see if it's an integer.
5464 9.22337203685478e+18 is an integer.
5465 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5466 so $a="9.22337203685478e+18"; $a+0; $a--
5467 needs to be the same as $a="9.22337203685478e+18"; $a--
5474 /* sv_2iv *should* have made this an NV */
5475 if (flags & SVp_NOK) {
5476 (void)SvNOK_only(sv);
5480 /* I don't think we can get here. Maybe I should assert this
5481 And if we do get here I suspect that sv_setnv will croak. NWC
5483 #if defined(USE_LONG_DOUBLE)
5484 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",
5485 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5487 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5488 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5492 #endif /* PERL_PRESERVE_IVUV */
5493 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5497 =for apidoc sv_mortalcopy
5499 Creates a new SV which is a copy of the original SV. The new SV is marked
5505 /* Make a string that will exist for the duration of the expression
5506 * evaluation. Actually, it may have to last longer than that, but
5507 * hopefully we won't free it until it has been assigned to a
5508 * permanent location. */
5511 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5516 sv_setsv(sv,oldstr);
5518 PL_tmps_stack[++PL_tmps_ix] = sv;
5524 =for apidoc sv_newmortal
5526 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5532 Perl_sv_newmortal(pTHX)
5537 SvFLAGS(sv) = SVs_TEMP;
5539 PL_tmps_stack[++PL_tmps_ix] = sv;
5544 =for apidoc sv_2mortal
5546 Marks an SV as mortal. The SV will be destroyed when the current context
5552 /* same thing without the copying */
5555 Perl_sv_2mortal(pTHX_ register SV *sv)
5559 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5562 PL_tmps_stack[++PL_tmps_ix] = sv;
5570 Creates a new SV and copies a string into it. The reference count for the
5571 SV is set to 1. If C<len> is zero, Perl will compute the length using
5572 strlen(). For efficiency, consider using C<newSVpvn> instead.
5578 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5585 sv_setpvn(sv,s,len);
5590 =for apidoc newSVpvn
5592 Creates a new SV and copies a string into it. The reference count for the
5593 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5594 string. You are responsible for ensuring that the source string is at least
5601 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5606 sv_setpvn(sv,s,len);
5611 =for apidoc newSVpvn_share
5613 Creates a new SV and populates it with a string from
5614 the string table. Turns on READONLY and FAKE.
5615 The idea here is that as string table is used for shared hash
5616 keys these strings will have SvPVX == HeKEY and hash lookup
5617 will avoid string compare.
5623 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5626 bool is_utf8 = FALSE;
5631 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5632 STRLEN tmplen = len;
5633 /* See the note in hv.c:hv_fetch() --jhi */
5634 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5638 PERL_HASH(hash, src, len);
5640 sv_upgrade(sv, SVt_PVIV);
5641 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5653 #if defined(PERL_IMPLICIT_CONTEXT)
5655 Perl_newSVpvf_nocontext(const char* pat, ...)
5660 va_start(args, pat);
5661 sv = vnewSVpvf(pat, &args);
5668 =for apidoc newSVpvf
5670 Creates a new SV an initialize it with the string formatted like
5677 Perl_newSVpvf(pTHX_ const char* pat, ...)
5681 va_start(args, pat);
5682 sv = vnewSVpvf(pat, &args);
5688 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5692 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5699 Creates a new SV and copies a floating point value into it.
5700 The reference count for the SV is set to 1.
5706 Perl_newSVnv(pTHX_ NV n)
5718 Creates a new SV and copies an integer into it. The reference count for the
5725 Perl_newSViv(pTHX_ IV i)
5737 Creates a new SV and copies an unsigned integer into it.
5738 The reference count for the SV is set to 1.
5744 Perl_newSVuv(pTHX_ UV u)
5754 =for apidoc newRV_noinc
5756 Creates an RV wrapper for an SV. The reference count for the original
5757 SV is B<not> incremented.
5763 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5768 sv_upgrade(sv, SVt_RV);
5775 /* newRV_inc is #defined to newRV in sv.h */
5777 Perl_newRV(pTHX_ SV *tmpRef)
5779 return newRV_noinc(SvREFCNT_inc(tmpRef));
5785 Creates a new SV which is an exact duplicate of the original SV.
5790 /* make an exact duplicate of old */
5793 Perl_newSVsv(pTHX_ register SV *old)
5799 if (SvTYPE(old) == SVTYPEMASK) {
5800 if (ckWARN_d(WARN_INTERNAL))
5801 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5816 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5824 char todo[PERL_UCHAR_MAX+1];
5829 if (!*s) { /* reset ?? searches */
5830 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5831 pm->op_pmdynflags &= ~PMdf_USED;
5836 /* reset variables */
5838 if (!HvARRAY(stash))
5841 Zero(todo, 256, char);
5843 i = (unsigned char)*s;
5847 max = (unsigned char)*s++;
5848 for ( ; i <= max; i++) {
5851 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5852 for (entry = HvARRAY(stash)[i];
5854 entry = HeNEXT(entry))
5856 if (!todo[(U8)*HeKEY(entry)])
5858 gv = (GV*)HeVAL(entry);
5860 if (SvTHINKFIRST(sv)) {
5861 if (!SvREADONLY(sv) && SvROK(sv))
5866 if (SvTYPE(sv) >= SVt_PV) {
5868 if (SvPVX(sv) != Nullch)
5875 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5877 #ifdef USE_ENVIRON_ARRAY
5879 environ[0] = Nullch;
5888 Perl_sv_2io(pTHX_ SV *sv)
5894 switch (SvTYPE(sv)) {
5902 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5906 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5908 return sv_2io(SvRV(sv));
5909 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5915 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5922 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5929 return *gvp = Nullgv, Nullcv;
5930 switch (SvTYPE(sv)) {
5949 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5950 tryAMAGICunDEREF(to_cv);
5953 if (SvTYPE(sv) == SVt_PVCV) {
5962 Perl_croak(aTHX_ "Not a subroutine reference");
5967 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5973 if (lref && !GvCVu(gv)) {
5976 tmpsv = NEWSV(704,0);
5977 gv_efullname3(tmpsv, gv, Nullch);
5978 /* XXX this is probably not what they think they're getting.
5979 * It has the same effect as "sub name;", i.e. just a forward
5981 newSUB(start_subparse(FALSE, 0),
5982 newSVOP(OP_CONST, 0, tmpsv),
5987 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5996 Returns true if the SV has a true value by Perl's rules.
6002 Perl_sv_true(pTHX_ register SV *sv)
6008 if ((tXpv = (XPV*)SvANY(sv)) &&
6009 (tXpv->xpv_cur > 1 ||
6010 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6017 return SvIVX(sv) != 0;
6020 return SvNVX(sv) != 0.0;
6022 return sv_2bool(sv);
6028 Perl_sv_iv(pTHX_ register SV *sv)
6032 return (IV)SvUVX(sv);
6039 Perl_sv_uv(pTHX_ register SV *sv)
6044 return (UV)SvIVX(sv);
6050 Perl_sv_nv(pTHX_ register SV *sv)
6058 Perl_sv_pv(pTHX_ SV *sv)
6065 return sv_2pv(sv, &n_a);
6069 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6075 return sv_2pv(sv, lp);
6079 =for apidoc sv_pvn_force
6081 Get a sensible string out of the SV somehow.
6087 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6089 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6093 =for apidoc sv_pvn_force_flags
6095 Get a sensible string out of the SV somehow.
6096 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6097 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6098 implemented in terms of this function.
6104 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6108 if (SvTHINKFIRST(sv) && !SvROK(sv))
6109 sv_force_normal(sv);
6115 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6116 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6117 PL_op_name[PL_op->op_type]);
6120 s = sv_2pv_flags(sv, lp, flags);
6121 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6126 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6127 SvGROW(sv, len + 1);
6128 Move(s,SvPVX(sv),len,char);
6133 SvPOK_on(sv); /* validate pointer */
6135 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6136 PTR2UV(sv),SvPVX(sv)));
6143 Perl_sv_pvbyte(pTHX_ SV *sv)
6145 sv_utf8_downgrade(sv,0);
6150 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6152 sv_utf8_downgrade(sv,0);
6153 return sv_pvn(sv,lp);
6157 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6159 sv_utf8_downgrade(sv,0);
6160 return sv_pvn_force(sv,lp);
6164 Perl_sv_pvutf8(pTHX_ SV *sv)
6166 sv_utf8_upgrade(sv);
6171 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6173 sv_utf8_upgrade(sv);
6174 return sv_pvn(sv,lp);
6178 =for apidoc sv_pvutf8n_force
6180 Get a sensible UTF8-encoded string out of the SV somehow. See
6187 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6189 sv_utf8_upgrade(sv);
6190 return sv_pvn_force(sv,lp);
6194 =for apidoc sv_reftype
6196 Returns a string describing what the SV is a reference to.
6202 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6204 if (ob && SvOBJECT(sv))
6205 return HvNAME(SvSTASH(sv));
6207 switch (SvTYPE(sv)) {
6221 case SVt_PVLV: return "LVALUE";
6222 case SVt_PVAV: return "ARRAY";
6223 case SVt_PVHV: return "HASH";
6224 case SVt_PVCV: return "CODE";
6225 case SVt_PVGV: return "GLOB";
6226 case SVt_PVFM: return "FORMAT";
6227 case SVt_PVIO: return "IO";
6228 default: return "UNKNOWN";
6234 =for apidoc sv_isobject
6236 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6237 object. If the SV is not an RV, or if the object is not blessed, then this
6244 Perl_sv_isobject(pTHX_ SV *sv)
6261 Returns a boolean indicating whether the SV is blessed into the specified
6262 class. This does not check for subtypes; use C<sv_derived_from> to verify
6263 an inheritance relationship.
6269 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6281 return strEQ(HvNAME(SvSTASH(sv)), name);
6287 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6288 it will be upgraded to one. If C<classname> is non-null then the new SV will
6289 be blessed in the specified package. The new SV is returned and its
6290 reference count is 1.
6296 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6302 SV_CHECK_THINKFIRST(rv);
6305 if (SvTYPE(rv) >= SVt_PVMG) {
6306 U32 refcnt = SvREFCNT(rv);
6310 SvREFCNT(rv) = refcnt;
6313 if (SvTYPE(rv) < SVt_RV)
6314 sv_upgrade(rv, SVt_RV);
6315 else if (SvTYPE(rv) > SVt_RV) {
6316 (void)SvOOK_off(rv);
6317 if (SvPVX(rv) && SvLEN(rv))
6318 Safefree(SvPVX(rv));
6328 HV* stash = gv_stashpv(classname, TRUE);
6329 (void)sv_bless(rv, stash);
6335 =for apidoc sv_setref_pv
6337 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6338 argument will be upgraded to an RV. That RV will be modified to point to
6339 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6340 into the SV. The C<classname> argument indicates the package for the
6341 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6342 will be returned and will have a reference count of 1.
6344 Do not use with other Perl types such as HV, AV, SV, CV, because those
6345 objects will become corrupted by the pointer copy process.
6347 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6353 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6356 sv_setsv(rv, &PL_sv_undef);
6360 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6365 =for apidoc sv_setref_iv
6367 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6368 argument will be upgraded to an RV. That RV will be modified to point to
6369 the new SV. The C<classname> argument indicates the package for the
6370 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6371 will be returned and will have a reference count of 1.
6377 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6379 sv_setiv(newSVrv(rv,classname), iv);
6384 =for apidoc sv_setref_uv
6386 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6387 argument will be upgraded to an RV. That RV will be modified to point to
6388 the new SV. The C<classname> argument indicates the package for the
6389 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6390 will be returned and will have a reference count of 1.
6396 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6398 sv_setuv(newSVrv(rv,classname), uv);
6403 =for apidoc sv_setref_nv
6405 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6406 argument will be upgraded to an RV. That RV will be modified to point to
6407 the new SV. The C<classname> argument indicates the package for the
6408 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6409 will be returned and will have a reference count of 1.
6415 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6417 sv_setnv(newSVrv(rv,classname), nv);
6422 =for apidoc sv_setref_pvn
6424 Copies a string into a new SV, optionally blessing the SV. The length of the
6425 string must be specified with C<n>. The C<rv> argument will be upgraded to
6426 an RV. That RV will be modified to point to the new SV. The C<classname>
6427 argument indicates the package for the blessing. Set C<classname> to
6428 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6429 a reference count of 1.
6431 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6437 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6439 sv_setpvn(newSVrv(rv,classname), pv, n);
6444 =for apidoc sv_bless
6446 Blesses an SV into a specified package. The SV must be an RV. The package
6447 must be designated by its stash (see C<gv_stashpv()>). The reference count
6448 of the SV is unaffected.
6454 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6458 Perl_croak(aTHX_ "Can't bless non-reference value");
6460 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6461 if (SvREADONLY(tmpRef))
6462 Perl_croak(aTHX_ PL_no_modify);
6463 if (SvOBJECT(tmpRef)) {
6464 if (SvTYPE(tmpRef) != SVt_PVIO)
6466 SvREFCNT_dec(SvSTASH(tmpRef));
6469 SvOBJECT_on(tmpRef);
6470 if (SvTYPE(tmpRef) != SVt_PVIO)
6472 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6473 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6484 S_sv_unglob(pTHX_ SV *sv)
6488 assert(SvTYPE(sv) == SVt_PVGV);
6493 SvREFCNT_dec(GvSTASH(sv));
6494 GvSTASH(sv) = Nullhv;
6496 sv_unmagic(sv, PERL_MAGIC_glob);
6497 Safefree(GvNAME(sv));
6500 /* need to keep SvANY(sv) in the right arena */
6501 xpvmg = new_XPVMG();
6502 StructCopy(SvANY(sv), xpvmg, XPVMG);
6503 del_XPVGV(SvANY(sv));
6506 SvFLAGS(sv) &= ~SVTYPEMASK;
6507 SvFLAGS(sv) |= SVt_PVMG;
6511 =for apidoc sv_unref_flags
6513 Unsets the RV status of the SV, and decrements the reference count of
6514 whatever was being referenced by the RV. This can almost be thought of
6515 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6516 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6517 (otherwise the decrementing is conditional on the reference count being
6518 different from one or the reference being a readonly SV).
6525 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6529 if (SvWEAKREF(sv)) {
6537 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6539 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6540 sv_2mortal(rv); /* Schedule for freeing later */
6544 =for apidoc sv_unref
6546 Unsets the RV status of the SV, and decrements the reference count of
6547 whatever was being referenced by the RV. This can almost be thought of
6548 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6549 being zero. See C<SvROK_off>.
6555 Perl_sv_unref(pTHX_ SV *sv)
6557 sv_unref_flags(sv, 0);
6561 Perl_sv_taint(pTHX_ SV *sv)
6563 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6567 Perl_sv_untaint(pTHX_ SV *sv)
6569 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6570 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6577 Perl_sv_tainted(pTHX_ SV *sv)
6579 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6580 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6581 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6588 =for apidoc sv_setpviv
6590 Copies an integer into the given SV, also updating its string value.
6591 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6597 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6599 char buf[TYPE_CHARS(UV)];
6601 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6603 sv_setpvn(sv, ptr, ebuf - ptr);
6608 =for apidoc sv_setpviv_mg
6610 Like C<sv_setpviv>, but also handles 'set' magic.
6616 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6618 char buf[TYPE_CHARS(UV)];
6620 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6622 sv_setpvn(sv, ptr, ebuf - ptr);
6626 #if defined(PERL_IMPLICIT_CONTEXT)
6628 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6632 va_start(args, pat);
6633 sv_vsetpvf(sv, pat, &args);
6639 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6643 va_start(args, pat);
6644 sv_vsetpvf_mg(sv, pat, &args);
6650 =for apidoc sv_setpvf
6652 Processes its arguments like C<sprintf> and sets an SV to the formatted
6653 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6659 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6662 va_start(args, pat);
6663 sv_vsetpvf(sv, pat, &args);
6668 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6670 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6674 =for apidoc sv_setpvf_mg
6676 Like C<sv_setpvf>, but also handles 'set' magic.
6682 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6685 va_start(args, pat);
6686 sv_vsetpvf_mg(sv, pat, &args);
6691 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6693 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6697 #if defined(PERL_IMPLICIT_CONTEXT)
6699 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6703 va_start(args, pat);
6704 sv_vcatpvf(sv, pat, &args);
6709 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6713 va_start(args, pat);
6714 sv_vcatpvf_mg(sv, pat, &args);
6720 =for apidoc sv_catpvf
6722 Processes its arguments like C<sprintf> and appends the formatted
6723 output to an SV. If the appended data contains "wide" characters
6724 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6725 and characters >255 formatted with %c), the original SV might get
6726 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6727 C<SvSETMAGIC()> must typically be called after calling this function
6728 to handle 'set' magic.
6733 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6736 va_start(args, pat);
6737 sv_vcatpvf(sv, pat, &args);
6742 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6744 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6748 =for apidoc sv_catpvf_mg
6750 Like C<sv_catpvf>, but also handles 'set' magic.
6756 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6759 va_start(args, pat);
6760 sv_vcatpvf_mg(sv, pat, &args);
6765 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6767 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6772 =for apidoc sv_vsetpvfn
6774 Works like C<vcatpvfn> but copies the text into the SV instead of
6781 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6783 sv_setpvn(sv, "", 0);
6784 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6788 S_expect_number(pTHX_ char** pattern)
6791 switch (**pattern) {
6792 case '1': case '2': case '3':
6793 case '4': case '5': case '6':
6794 case '7': case '8': case '9':
6795 while (isDIGIT(**pattern))
6796 var = var * 10 + (*(*pattern)++ - '0');
6800 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6803 =for apidoc sv_vcatpvfn
6805 Processes its arguments like C<vsprintf> and appends the formatted output
6806 to an SV. Uses an array of SVs if the C style variable argument list is
6807 missing (NULL). When running with taint checks enabled, indicates via
6808 C<maybe_tainted> if results are untrustworthy (often due to the use of
6815 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6822 static char nullstr[] = "(null)";
6825 /* no matter what, this is a string now */
6826 (void)SvPV_force(sv, origlen);
6828 /* special-case "", "%s", and "%_" */
6831 if (patlen == 2 && pat[0] == '%') {
6835 char *s = va_arg(*args, char*);
6836 sv_catpv(sv, s ? s : nullstr);
6838 else if (svix < svmax) {
6839 sv_catsv(sv, *svargs);
6840 if (DO_UTF8(*svargs))
6846 argsv = va_arg(*args, SV*);
6847 sv_catsv(sv, argsv);
6852 /* See comment on '_' below */
6857 patend = (char*)pat + patlen;
6858 for (p = (char*)pat; p < patend; p = q) {
6861 bool vectorize = FALSE;
6862 bool vectorarg = FALSE;
6863 bool vec_utf = FALSE;
6869 bool has_precis = FALSE;
6871 bool is_utf = FALSE;
6874 U8 utf8buf[UTF8_MAXLEN+1];
6875 STRLEN esignlen = 0;
6877 char *eptr = Nullch;
6879 /* Times 4: a decimal digit takes more than 3 binary digits.
6880 * NV_DIG: mantissa takes than many decimal digits.
6881 * Plus 32: Playing safe. */
6882 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6883 /* large enough for "%#.#f" --chip */
6884 /* what about long double NVs? --jhi */
6887 U8 *vecstr = Null(U8*);
6899 STRLEN dotstrlen = 1;
6900 I32 efix = 0; /* explicit format parameter index */
6901 I32 ewix = 0; /* explicit width index */
6902 I32 epix = 0; /* explicit precision index */
6903 I32 evix = 0; /* explicit vector index */
6904 bool asterisk = FALSE;
6906 /* echo everything up to the next format specification */
6907 for (q = p; q < patend && *q != '%'; ++q) ;
6909 sv_catpvn(sv, p, q - p);
6916 We allow format specification elements in this order:
6917 \d+\$ explicit format parameter index
6919 \*?(\d+\$)?v vector with optional (optionally specified) arg
6920 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6921 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6923 [%bcdefginopsux_DFOUX] format (mandatory)
6925 if (EXPECT_NUMBER(q, width)) {
6966 if (EXPECT_NUMBER(q, ewix))
6975 if ((vectorarg = asterisk)) {
6985 EXPECT_NUMBER(q, width);
6990 vecsv = va_arg(*args, SV*);
6992 vecsv = (evix ? evix <= svmax : svix < svmax) ?
6993 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
6994 dotstr = SvPVx(vecsv, dotstrlen);
6999 vecsv = va_arg(*args, SV*);
7000 vecstr = (U8*)SvPVx(vecsv,veclen);
7001 vec_utf = DO_UTF8(vecsv);
7003 else if (efix ? efix <= svmax : svix < svmax) {
7004 vecsv = svargs[efix ? efix-1 : svix++];
7005 vecstr = (U8*)SvPVx(vecsv,veclen);
7006 vec_utf = DO_UTF8(vecsv);
7016 i = va_arg(*args, int);
7018 i = (ewix ? ewix <= svmax : svix < svmax) ?
7019 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7021 width = (i < 0) ? -i : i;
7031 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7034 i = va_arg(*args, int);
7036 i = (ewix ? ewix <= svmax : svix < svmax)
7037 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7038 precis = (i < 0) ? 0 : i;
7043 precis = precis * 10 + (*q++ - '0');
7051 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7062 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7063 if (*(q + 1) == 'l') { /* lld, llf */
7086 argsv = (efix ? efix <= svmax : svix < svmax) ?
7087 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7094 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7096 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7098 eptr = (char*)utf8buf;
7099 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7111 eptr = va_arg(*args, char*);
7113 #ifdef MACOS_TRADITIONAL
7114 /* On MacOS, %#s format is used for Pascal strings */
7119 elen = strlen(eptr);
7122 elen = sizeof nullstr - 1;
7126 eptr = SvPVx(argsv, elen);
7127 if (DO_UTF8(argsv)) {
7128 if (has_precis && precis < elen) {
7130 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7133 if (width) { /* fudge width (can't fudge elen) */
7134 width += elen - sv_len_utf8(argsv);
7143 * The "%_" hack might have to be changed someday,
7144 * if ISO or ANSI decide to use '_' for something.
7145 * So we keep it hidden from users' code.
7149 argsv = va_arg(*args, SV*);
7150 eptr = SvPVx(argsv, elen);
7156 if (has_precis && elen > precis)
7165 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7183 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7193 case 'h': iv = (short)va_arg(*args, int); break;
7194 default: iv = va_arg(*args, int); break;
7195 case 'l': iv = va_arg(*args, long); break;
7196 case 'V': iv = va_arg(*args, IV); break;
7198 case 'q': iv = va_arg(*args, Quad_t); break;
7205 case 'h': iv = (short)iv; break;
7207 case 'l': iv = (long)iv; break;
7210 case 'q': iv = (Quad_t)iv; break;
7217 esignbuf[esignlen++] = plus;
7221 esignbuf[esignlen++] = '-';
7263 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7273 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7274 default: uv = va_arg(*args, unsigned); break;
7275 case 'l': uv = va_arg(*args, unsigned long); break;
7276 case 'V': uv = va_arg(*args, UV); break;
7278 case 'q': uv = va_arg(*args, Quad_t); break;
7285 case 'h': uv = (unsigned short)uv; break;
7287 case 'l': uv = (unsigned long)uv; break;
7290 case 'q': uv = (Quad_t)uv; break;
7296 eptr = ebuf + sizeof ebuf;
7302 p = (char*)((c == 'X')
7303 ? "0123456789ABCDEF" : "0123456789abcdef");
7309 esignbuf[esignlen++] = '0';
7310 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7316 *--eptr = '0' + dig;
7318 if (alt && *eptr != '0')
7324 *--eptr = '0' + dig;
7327 esignbuf[esignlen++] = '0';
7328 esignbuf[esignlen++] = 'b';
7331 default: /* it had better be ten or less */
7332 #if defined(PERL_Y2KWARN)
7333 if (ckWARN(WARN_Y2K)) {
7335 char *s = SvPV(sv,n);
7336 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7337 && (n == 2 || !isDIGIT(s[n-3])))
7339 Perl_warner(aTHX_ WARN_Y2K,
7340 "Possible Y2K bug: %%%c %s",
7341 c, "format string following '19'");
7347 *--eptr = '0' + dig;
7348 } while (uv /= base);
7351 elen = (ebuf + sizeof ebuf) - eptr;
7354 zeros = precis - elen;
7355 else if (precis == 0 && elen == 1 && *eptr == '0')
7360 /* FLOATING POINT */
7363 c = 'f'; /* maybe %F isn't supported here */
7369 /* This is evil, but floating point is even more evil */
7372 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7375 if (c != 'e' && c != 'E') {
7377 (void)Perl_frexp(nv, &i);
7378 if (i == PERL_INT_MIN)
7379 Perl_die(aTHX_ "panic: frexp");
7381 need = BIT_DIGITS(i);
7383 need += has_precis ? precis : 6; /* known default */
7387 need += 20; /* fudge factor */
7388 if (PL_efloatsize < need) {
7389 Safefree(PL_efloatbuf);
7390 PL_efloatsize = need + 20; /* more fudge */
7391 New(906, PL_efloatbuf, PL_efloatsize, char);
7392 PL_efloatbuf[0] = '\0';
7395 eptr = ebuf + sizeof ebuf;
7398 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7400 /* Copy the one or more characters in a long double
7401 * format before the 'base' ([efgEFG]) character to
7402 * the format string. */
7403 static char const prifldbl[] = PERL_PRIfldbl;
7404 char const *p = prifldbl + sizeof(prifldbl) - 3;
7405 while (p >= prifldbl) { *--eptr = *p--; }
7410 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7415 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7427 /* No taint. Otherwise we are in the strange situation
7428 * where printf() taints but print($float) doesn't.
7430 (void)sprintf(PL_efloatbuf, eptr, nv);
7432 eptr = PL_efloatbuf;
7433 elen = strlen(PL_efloatbuf);
7440 i = SvCUR(sv) - origlen;
7443 case 'h': *(va_arg(*args, short*)) = i; break;
7444 default: *(va_arg(*args, int*)) = i; break;
7445 case 'l': *(va_arg(*args, long*)) = i; break;
7446 case 'V': *(va_arg(*args, IV*)) = i; break;
7448 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7453 sv_setuv_mg(argsv, (UV)i);
7454 continue; /* not "break" */
7461 if (!args && ckWARN(WARN_PRINTF) &&
7462 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7463 SV *msg = sv_newmortal();
7464 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7465 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7468 Perl_sv_catpvf(aTHX_ msg,
7469 "\"%%%c\"", c & 0xFF);
7471 Perl_sv_catpvf(aTHX_ msg,
7472 "\"%%\\%03"UVof"\"",
7475 sv_catpv(msg, "end of string");
7476 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7479 /* output mangled stuff ... */
7485 /* ... right here, because formatting flags should not apply */
7486 SvGROW(sv, SvCUR(sv) + elen + 1);
7488 Copy(eptr, p, elen, char);
7491 SvCUR(sv) = p - SvPVX(sv);
7492 continue; /* not "break" */
7495 have = esignlen + zeros + elen;
7496 need = (have > width ? have : width);
7499 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7501 if (esignlen && fill == '0') {
7502 for (i = 0; i < esignlen; i++)
7506 memset(p, fill, gap);
7509 if (esignlen && fill != '0') {
7510 for (i = 0; i < esignlen; i++)
7514 for (i = zeros; i; i--)
7518 Copy(eptr, p, elen, char);
7522 memset(p, ' ', gap);
7527 Copy(dotstr, p, dotstrlen, char);
7531 vectorize = FALSE; /* done iterating over vecstr */
7536 SvCUR(sv) = p - SvPVX(sv);
7544 #if defined(USE_ITHREADS)
7546 #if defined(USE_THREADS)
7547 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7550 #ifndef GpREFCNT_inc
7551 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7555 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7556 #define av_dup(s) (AV*)sv_dup((SV*)s)
7557 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7558 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7559 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7560 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7561 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7562 #define io_dup(s) (IO*)sv_dup((SV*)s)
7563 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7564 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7565 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7566 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7567 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7570 Perl_re_dup(pTHX_ REGEXP *r)
7572 /* XXX fix when pmop->op_pmregexp becomes shared */
7573 return ReREFCNT_inc(r);
7577 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7581 return (PerlIO*)NULL;
7583 /* look for it in the table first */
7584 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7588 /* create anew and remember what it is */
7589 ret = PerlIO_fdupopen(aTHX_ fp);
7590 ptr_table_store(PL_ptr_table, fp, ret);
7595 Perl_dirp_dup(pTHX_ DIR *dp)
7604 Perl_gp_dup(pTHX_ GP *gp)
7609 /* look for it in the table first */
7610 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7614 /* create anew and remember what it is */
7615 Newz(0, ret, 1, GP);
7616 ptr_table_store(PL_ptr_table, gp, ret);
7619 ret->gp_refcnt = 0; /* must be before any other dups! */
7620 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7621 ret->gp_io = io_dup_inc(gp->gp_io);
7622 ret->gp_form = cv_dup_inc(gp->gp_form);
7623 ret->gp_av = av_dup_inc(gp->gp_av);
7624 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7625 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7626 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7627 ret->gp_cvgen = gp->gp_cvgen;
7628 ret->gp_flags = gp->gp_flags;
7629 ret->gp_line = gp->gp_line;
7630 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7635 Perl_mg_dup(pTHX_ MAGIC *mg)
7637 MAGIC *mgprev = (MAGIC*)NULL;
7640 return (MAGIC*)NULL;
7641 /* look for it in the table first */
7642 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7646 for (; mg; mg = mg->mg_moremagic) {
7648 Newz(0, nmg, 1, MAGIC);
7650 mgprev->mg_moremagic = nmg;
7653 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7654 nmg->mg_private = mg->mg_private;
7655 nmg->mg_type = mg->mg_type;
7656 nmg->mg_flags = mg->mg_flags;
7657 if (mg->mg_type == PERL_MAGIC_qr) {
7658 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7661 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7662 ? sv_dup_inc(mg->mg_obj)
7663 : sv_dup(mg->mg_obj);
7665 nmg->mg_len = mg->mg_len;
7666 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7667 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7668 if (mg->mg_len >= 0) {
7669 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7670 if (mg->mg_type == PERL_MAGIC_overload_table &&
7671 AMT_AMAGIC((AMT*)mg->mg_ptr))
7673 AMT *amtp = (AMT*)mg->mg_ptr;
7674 AMT *namtp = (AMT*)nmg->mg_ptr;
7676 for (i = 1; i < NofAMmeth; i++) {
7677 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7681 else if (mg->mg_len == HEf_SVKEY)
7682 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7690 Perl_ptr_table_new(pTHX)
7693 Newz(0, tbl, 1, PTR_TBL_t);
7696 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7701 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7703 PTR_TBL_ENT_t *tblent;
7704 UV hash = PTR2UV(sv);
7706 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7707 for (; tblent; tblent = tblent->next) {
7708 if (tblent->oldval == sv)
7709 return tblent->newval;
7715 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7717 PTR_TBL_ENT_t *tblent, **otblent;
7718 /* XXX this may be pessimal on platforms where pointers aren't good
7719 * hash values e.g. if they grow faster in the most significant
7721 UV hash = PTR2UV(oldv);
7725 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7726 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7727 if (tblent->oldval == oldv) {
7728 tblent->newval = newv;
7733 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7734 tblent->oldval = oldv;
7735 tblent->newval = newv;
7736 tblent->next = *otblent;
7739 if (i && tbl->tbl_items > tbl->tbl_max)
7740 ptr_table_split(tbl);
7744 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7746 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7747 UV oldsize = tbl->tbl_max + 1;
7748 UV newsize = oldsize * 2;
7751 Renew(ary, newsize, PTR_TBL_ENT_t*);
7752 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7753 tbl->tbl_max = --newsize;
7755 for (i=0; i < oldsize; i++, ary++) {
7756 PTR_TBL_ENT_t **curentp, **entp, *ent;
7759 curentp = ary + oldsize;
7760 for (entp = ary, ent = *ary; ent; ent = *entp) {
7761 if ((newsize & PTR2UV(ent->oldval)) != i) {
7763 ent->next = *curentp;
7774 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7776 register PTR_TBL_ENT_t **array;
7777 register PTR_TBL_ENT_t *entry;
7778 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7782 if (!tbl || !tbl->tbl_items) {
7786 array = tbl->tbl_ary;
7793 entry = entry->next;
7797 if (++riter > max) {
7800 entry = array[riter];
7808 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7813 ptr_table_clear(tbl);
7814 Safefree(tbl->tbl_ary);
7823 S_gv_share(pTHX_ SV *sstr)
7826 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7828 if (GvIO(gv) || GvFORM(gv)) {
7829 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7831 else if (!GvCV(gv)) {
7835 /* CvPADLISTs cannot be shared */
7836 if (!CvXSUB(GvCV(gv))) {
7841 if (!GvSHARED(gv)) {
7843 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7844 HvNAME(GvSTASH(gv)), GvNAME(gv));
7850 * write attempts will die with
7851 * "Modification of a read-only value attempted"
7857 SvREADONLY_on(GvSV(gv));
7864 SvREADONLY_on(GvAV(gv));
7871 SvREADONLY_on(GvAV(gv));
7874 return sstr; /* he_dup() will SvREFCNT_inc() */
7878 Perl_sv_dup(pTHX_ SV *sstr)
7882 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7884 /* look for it in the table first */
7885 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7889 /* create anew and remember what it is */
7891 ptr_table_store(PL_ptr_table, sstr, dstr);
7894 SvFLAGS(dstr) = SvFLAGS(sstr);
7895 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7896 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7899 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7900 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7901 PL_watch_pvx, SvPVX(sstr));
7904 switch (SvTYPE(sstr)) {
7909 SvANY(dstr) = new_XIV();
7910 SvIVX(dstr) = SvIVX(sstr);
7913 SvANY(dstr) = new_XNV();
7914 SvNVX(dstr) = SvNVX(sstr);
7917 SvANY(dstr) = new_XRV();
7918 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
7919 ? sv_dup(SvRV(sstr))
7920 : sv_dup_inc(SvRV(sstr));
7923 SvANY(dstr) = new_XPV();
7924 SvCUR(dstr) = SvCUR(sstr);
7925 SvLEN(dstr) = SvLEN(sstr);
7927 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7928 ? sv_dup(SvRV(sstr))
7929 : sv_dup_inc(SvRV(sstr));
7930 else if (SvPVX(sstr) && SvLEN(sstr))
7931 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7933 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7936 SvANY(dstr) = new_XPVIV();
7937 SvCUR(dstr) = SvCUR(sstr);
7938 SvLEN(dstr) = SvLEN(sstr);
7939 SvIVX(dstr) = SvIVX(sstr);
7941 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7942 ? sv_dup(SvRV(sstr))
7943 : sv_dup_inc(SvRV(sstr));
7944 else if (SvPVX(sstr) && SvLEN(sstr))
7945 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7947 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7950 SvANY(dstr) = new_XPVNV();
7951 SvCUR(dstr) = SvCUR(sstr);
7952 SvLEN(dstr) = SvLEN(sstr);
7953 SvIVX(dstr) = SvIVX(sstr);
7954 SvNVX(dstr) = SvNVX(sstr);
7956 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7957 ? sv_dup(SvRV(sstr))
7958 : sv_dup_inc(SvRV(sstr));
7959 else if (SvPVX(sstr) && SvLEN(sstr))
7960 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7962 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7965 SvANY(dstr) = new_XPVMG();
7966 SvCUR(dstr) = SvCUR(sstr);
7967 SvLEN(dstr) = SvLEN(sstr);
7968 SvIVX(dstr) = SvIVX(sstr);
7969 SvNVX(dstr) = SvNVX(sstr);
7970 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7971 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7973 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7974 ? sv_dup(SvRV(sstr))
7975 : sv_dup_inc(SvRV(sstr));
7976 else if (SvPVX(sstr) && SvLEN(sstr))
7977 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7979 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7982 SvANY(dstr) = new_XPVBM();
7983 SvCUR(dstr) = SvCUR(sstr);
7984 SvLEN(dstr) = SvLEN(sstr);
7985 SvIVX(dstr) = SvIVX(sstr);
7986 SvNVX(dstr) = SvNVX(sstr);
7987 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7988 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7990 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7991 ? sv_dup(SvRV(sstr))
7992 : sv_dup_inc(SvRV(sstr));
7993 else if (SvPVX(sstr) && SvLEN(sstr))
7994 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7996 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7997 BmRARE(dstr) = BmRARE(sstr);
7998 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7999 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8002 SvANY(dstr) = new_XPVLV();
8003 SvCUR(dstr) = SvCUR(sstr);
8004 SvLEN(dstr) = SvLEN(sstr);
8005 SvIVX(dstr) = SvIVX(sstr);
8006 SvNVX(dstr) = SvNVX(sstr);
8007 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8008 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8010 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8011 ? sv_dup(SvRV(sstr))
8012 : sv_dup_inc(SvRV(sstr));
8013 else if (SvPVX(sstr) && SvLEN(sstr))
8014 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8016 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8017 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8018 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8019 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8020 LvTYPE(dstr) = LvTYPE(sstr);
8023 if (GvSHARED((GV*)sstr)) {
8025 if ((share = gv_share(sstr))) {
8029 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8030 HvNAME(GvSTASH(share)), GvNAME(share));
8035 SvANY(dstr) = new_XPVGV();
8036 SvCUR(dstr) = SvCUR(sstr);
8037 SvLEN(dstr) = SvLEN(sstr);
8038 SvIVX(dstr) = SvIVX(sstr);
8039 SvNVX(dstr) = SvNVX(sstr);
8040 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8041 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8043 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8044 ? sv_dup(SvRV(sstr))
8045 : sv_dup_inc(SvRV(sstr));
8046 else if (SvPVX(sstr) && SvLEN(sstr))
8047 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8049 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8050 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8051 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8052 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8053 GvFLAGS(dstr) = GvFLAGS(sstr);
8054 GvGP(dstr) = gp_dup(GvGP(sstr));
8055 (void)GpREFCNT_inc(GvGP(dstr));
8058 SvANY(dstr) = new_XPVIO();
8059 SvCUR(dstr) = SvCUR(sstr);
8060 SvLEN(dstr) = SvLEN(sstr);
8061 SvIVX(dstr) = SvIVX(sstr);
8062 SvNVX(dstr) = SvNVX(sstr);
8063 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8064 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8066 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8067 ? sv_dup(SvRV(sstr))
8068 : sv_dup_inc(SvRV(sstr));
8069 else if (SvPVX(sstr) && SvLEN(sstr))
8070 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8072 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8073 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8074 if (IoOFP(sstr) == IoIFP(sstr))
8075 IoOFP(dstr) = IoIFP(dstr);
8077 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8078 /* PL_rsfp_filters entries have fake IoDIRP() */
8079 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8080 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8082 IoDIRP(dstr) = IoDIRP(sstr);
8083 IoLINES(dstr) = IoLINES(sstr);
8084 IoPAGE(dstr) = IoPAGE(sstr);
8085 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8086 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8087 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8088 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8089 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8090 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8091 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8092 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8093 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8094 IoTYPE(dstr) = IoTYPE(sstr);
8095 IoFLAGS(dstr) = IoFLAGS(sstr);
8098 SvANY(dstr) = new_XPVAV();
8099 SvCUR(dstr) = SvCUR(sstr);
8100 SvLEN(dstr) = SvLEN(sstr);
8101 SvIVX(dstr) = SvIVX(sstr);
8102 SvNVX(dstr) = SvNVX(sstr);
8103 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8104 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8105 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8106 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8107 if (AvARRAY((AV*)sstr)) {
8108 SV **dst_ary, **src_ary;
8109 SSize_t items = AvFILLp((AV*)sstr) + 1;
8111 src_ary = AvARRAY((AV*)sstr);
8112 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8113 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8114 SvPVX(dstr) = (char*)dst_ary;
8115 AvALLOC((AV*)dstr) = dst_ary;
8116 if (AvREAL((AV*)sstr)) {
8118 *dst_ary++ = sv_dup_inc(*src_ary++);
8122 *dst_ary++ = sv_dup(*src_ary++);
8124 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8125 while (items-- > 0) {
8126 *dst_ary++ = &PL_sv_undef;
8130 SvPVX(dstr) = Nullch;
8131 AvALLOC((AV*)dstr) = (SV**)NULL;
8135 SvANY(dstr) = new_XPVHV();
8136 SvCUR(dstr) = SvCUR(sstr);
8137 SvLEN(dstr) = SvLEN(sstr);
8138 SvIVX(dstr) = SvIVX(sstr);
8139 SvNVX(dstr) = SvNVX(sstr);
8140 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8141 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8142 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8143 if (HvARRAY((HV*)sstr)) {
8145 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8146 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8147 Newz(0, dxhv->xhv_array,
8148 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8149 while (i <= sxhv->xhv_max) {
8150 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8151 !!HvSHAREKEYS(sstr));
8154 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8157 SvPVX(dstr) = Nullch;
8158 HvEITER((HV*)dstr) = (HE*)NULL;
8160 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8161 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8162 /* Record stashes for possible cloning in Perl_clone_using(). */
8163 if(HvNAME((HV*)dstr))
8164 av_push(PL_clone_callbacks, dstr);
8167 SvANY(dstr) = new_XPVFM();
8168 FmLINES(dstr) = FmLINES(sstr);
8172 SvANY(dstr) = new_XPVCV();
8174 SvCUR(dstr) = SvCUR(sstr);
8175 SvLEN(dstr) = SvLEN(sstr);
8176 SvIVX(dstr) = SvIVX(sstr);
8177 SvNVX(dstr) = SvNVX(sstr);
8178 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8179 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8180 if (SvPVX(sstr) && SvLEN(sstr))
8181 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8183 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8184 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8185 CvSTART(dstr) = CvSTART(sstr);
8186 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8187 CvXSUB(dstr) = CvXSUB(sstr);
8188 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8189 CvGV(dstr) = gv_dup(CvGV(sstr));
8190 CvDEPTH(dstr) = CvDEPTH(sstr);
8191 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8192 /* XXX padlists are real, but pretend to be not */
8193 AvREAL_on(CvPADLIST(sstr));
8194 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8195 AvREAL_off(CvPADLIST(sstr));
8196 AvREAL_off(CvPADLIST(dstr));
8199 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8200 if (!CvANON(sstr) || CvCLONED(sstr))
8201 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8203 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8204 CvFLAGS(dstr) = CvFLAGS(sstr);
8207 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8211 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8218 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8223 return (PERL_CONTEXT*)NULL;
8225 /* look for it in the table first */
8226 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8230 /* create anew and remember what it is */
8231 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8232 ptr_table_store(PL_ptr_table, cxs, ncxs);
8235 PERL_CONTEXT *cx = &cxs[ix];
8236 PERL_CONTEXT *ncx = &ncxs[ix];
8237 ncx->cx_type = cx->cx_type;
8238 if (CxTYPE(cx) == CXt_SUBST) {
8239 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8242 ncx->blk_oldsp = cx->blk_oldsp;
8243 ncx->blk_oldcop = cx->blk_oldcop;
8244 ncx->blk_oldretsp = cx->blk_oldretsp;
8245 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8246 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8247 ncx->blk_oldpm = cx->blk_oldpm;
8248 ncx->blk_gimme = cx->blk_gimme;
8249 switch (CxTYPE(cx)) {
8251 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8252 ? cv_dup_inc(cx->blk_sub.cv)
8253 : cv_dup(cx->blk_sub.cv));
8254 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8255 ? av_dup_inc(cx->blk_sub.argarray)
8257 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8258 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8259 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8260 ncx->blk_sub.lval = cx->blk_sub.lval;
8263 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8264 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8265 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8266 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8267 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8270 ncx->blk_loop.label = cx->blk_loop.label;
8271 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8272 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8273 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8274 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8275 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8276 ? cx->blk_loop.iterdata
8277 : gv_dup((GV*)cx->blk_loop.iterdata));
8278 ncx->blk_loop.oldcurpad
8279 = (SV**)ptr_table_fetch(PL_ptr_table,
8280 cx->blk_loop.oldcurpad);
8281 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8282 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8283 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8284 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8285 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8288 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8289 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8290 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8291 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8304 Perl_si_dup(pTHX_ PERL_SI *si)
8309 return (PERL_SI*)NULL;
8311 /* look for it in the table first */
8312 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8316 /* create anew and remember what it is */
8317 Newz(56, nsi, 1, PERL_SI);
8318 ptr_table_store(PL_ptr_table, si, nsi);
8320 nsi->si_stack = av_dup_inc(si->si_stack);
8321 nsi->si_cxix = si->si_cxix;
8322 nsi->si_cxmax = si->si_cxmax;
8323 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8324 nsi->si_type = si->si_type;
8325 nsi->si_prev = si_dup(si->si_prev);
8326 nsi->si_next = si_dup(si->si_next);
8327 nsi->si_markoff = si->si_markoff;
8332 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8333 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8334 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8335 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8336 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8337 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8338 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8339 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8340 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8341 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8342 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8343 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8346 #define pv_dup_inc(p) SAVEPV(p)
8347 #define pv_dup(p) SAVEPV(p)
8348 #define svp_dup_inc(p,pp) any_dup(p,pp)
8351 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8358 /* look for it in the table first */
8359 ret = ptr_table_fetch(PL_ptr_table, v);
8363 /* see if it is part of the interpreter structure */
8364 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8365 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8373 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8375 ANY *ss = proto_perl->Tsavestack;
8376 I32 ix = proto_perl->Tsavestack_ix;
8377 I32 max = proto_perl->Tsavestack_max;
8390 void (*dptr) (void*);
8391 void (*dxptr) (pTHXo_ void*);
8394 Newz(54, nss, max, ANY);
8400 case SAVEt_ITEM: /* normal string */
8401 sv = (SV*)POPPTR(ss,ix);
8402 TOPPTR(nss,ix) = sv_dup_inc(sv);
8403 sv = (SV*)POPPTR(ss,ix);
8404 TOPPTR(nss,ix) = sv_dup_inc(sv);
8406 case SAVEt_SV: /* scalar reference */
8407 sv = (SV*)POPPTR(ss,ix);
8408 TOPPTR(nss,ix) = sv_dup_inc(sv);
8409 gv = (GV*)POPPTR(ss,ix);
8410 TOPPTR(nss,ix) = gv_dup_inc(gv);
8412 case SAVEt_GENERIC_PVREF: /* generic char* */
8413 c = (char*)POPPTR(ss,ix);
8414 TOPPTR(nss,ix) = pv_dup(c);
8415 ptr = POPPTR(ss,ix);
8416 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8418 case SAVEt_GENERIC_SVREF: /* generic sv */
8419 case SAVEt_SVREF: /* scalar reference */
8420 sv = (SV*)POPPTR(ss,ix);
8421 TOPPTR(nss,ix) = sv_dup_inc(sv);
8422 ptr = POPPTR(ss,ix);
8423 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8425 case SAVEt_AV: /* array reference */
8426 av = (AV*)POPPTR(ss,ix);
8427 TOPPTR(nss,ix) = av_dup_inc(av);
8428 gv = (GV*)POPPTR(ss,ix);
8429 TOPPTR(nss,ix) = gv_dup(gv);
8431 case SAVEt_HV: /* hash reference */
8432 hv = (HV*)POPPTR(ss,ix);
8433 TOPPTR(nss,ix) = hv_dup_inc(hv);
8434 gv = (GV*)POPPTR(ss,ix);
8435 TOPPTR(nss,ix) = gv_dup(gv);
8437 case SAVEt_INT: /* int reference */
8438 ptr = POPPTR(ss,ix);
8439 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8440 intval = (int)POPINT(ss,ix);
8441 TOPINT(nss,ix) = intval;
8443 case SAVEt_LONG: /* long reference */
8444 ptr = POPPTR(ss,ix);
8445 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8446 longval = (long)POPLONG(ss,ix);
8447 TOPLONG(nss,ix) = longval;
8449 case SAVEt_I32: /* I32 reference */
8450 case SAVEt_I16: /* I16 reference */
8451 case SAVEt_I8: /* I8 reference */
8452 ptr = POPPTR(ss,ix);
8453 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8457 case SAVEt_IV: /* IV reference */
8458 ptr = POPPTR(ss,ix);
8459 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8463 case SAVEt_SPTR: /* SV* reference */
8464 ptr = POPPTR(ss,ix);
8465 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8466 sv = (SV*)POPPTR(ss,ix);
8467 TOPPTR(nss,ix) = sv_dup(sv);
8469 case SAVEt_VPTR: /* random* reference */
8470 ptr = POPPTR(ss,ix);
8471 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8472 ptr = POPPTR(ss,ix);
8473 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8475 case SAVEt_PPTR: /* char* reference */
8476 ptr = POPPTR(ss,ix);
8477 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8478 c = (char*)POPPTR(ss,ix);
8479 TOPPTR(nss,ix) = pv_dup(c);
8481 case SAVEt_HPTR: /* HV* reference */
8482 ptr = POPPTR(ss,ix);
8483 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8484 hv = (HV*)POPPTR(ss,ix);
8485 TOPPTR(nss,ix) = hv_dup(hv);
8487 case SAVEt_APTR: /* AV* reference */
8488 ptr = POPPTR(ss,ix);
8489 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8490 av = (AV*)POPPTR(ss,ix);
8491 TOPPTR(nss,ix) = av_dup(av);
8494 gv = (GV*)POPPTR(ss,ix);
8495 TOPPTR(nss,ix) = gv_dup(gv);
8497 case SAVEt_GP: /* scalar reference */
8498 gp = (GP*)POPPTR(ss,ix);
8499 TOPPTR(nss,ix) = gp = gp_dup(gp);
8500 (void)GpREFCNT_inc(gp);
8501 gv = (GV*)POPPTR(ss,ix);
8502 TOPPTR(nss,ix) = gv_dup_inc(c);
8503 c = (char*)POPPTR(ss,ix);
8504 TOPPTR(nss,ix) = pv_dup(c);
8511 case SAVEt_MORTALIZESV:
8512 sv = (SV*)POPPTR(ss,ix);
8513 TOPPTR(nss,ix) = sv_dup_inc(sv);
8516 ptr = POPPTR(ss,ix);
8517 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8518 /* these are assumed to be refcounted properly */
8519 switch (((OP*)ptr)->op_type) {
8526 TOPPTR(nss,ix) = ptr;
8531 TOPPTR(nss,ix) = Nullop;
8536 TOPPTR(nss,ix) = Nullop;
8539 c = (char*)POPPTR(ss,ix);
8540 TOPPTR(nss,ix) = pv_dup_inc(c);
8543 longval = POPLONG(ss,ix);
8544 TOPLONG(nss,ix) = longval;
8547 hv = (HV*)POPPTR(ss,ix);
8548 TOPPTR(nss,ix) = hv_dup_inc(hv);
8549 c = (char*)POPPTR(ss,ix);
8550 TOPPTR(nss,ix) = pv_dup_inc(c);
8554 case SAVEt_DESTRUCTOR:
8555 ptr = POPPTR(ss,ix);
8556 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8557 dptr = POPDPTR(ss,ix);
8558 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8560 case SAVEt_DESTRUCTOR_X:
8561 ptr = POPPTR(ss,ix);
8562 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8563 dxptr = POPDXPTR(ss,ix);
8564 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8566 case SAVEt_REGCONTEXT:
8572 case SAVEt_STACK_POS: /* Position on Perl stack */
8576 case SAVEt_AELEM: /* array element */
8577 sv = (SV*)POPPTR(ss,ix);
8578 TOPPTR(nss,ix) = sv_dup_inc(sv);
8581 av = (AV*)POPPTR(ss,ix);
8582 TOPPTR(nss,ix) = av_dup_inc(av);
8584 case SAVEt_HELEM: /* hash element */
8585 sv = (SV*)POPPTR(ss,ix);
8586 TOPPTR(nss,ix) = sv_dup_inc(sv);
8587 sv = (SV*)POPPTR(ss,ix);
8588 TOPPTR(nss,ix) = sv_dup_inc(sv);
8589 hv = (HV*)POPPTR(ss,ix);
8590 TOPPTR(nss,ix) = hv_dup_inc(hv);
8593 ptr = POPPTR(ss,ix);
8594 TOPPTR(nss,ix) = ptr;
8601 av = (AV*)POPPTR(ss,ix);
8602 TOPPTR(nss,ix) = av_dup(av);
8605 longval = (long)POPLONG(ss,ix);
8606 TOPLONG(nss,ix) = longval;
8607 ptr = POPPTR(ss,ix);
8608 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8609 sv = (SV*)POPPTR(ss,ix);
8610 TOPPTR(nss,ix) = sv_dup(sv);
8613 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8625 perl_clone(PerlInterpreter *proto_perl, UV flags)
8628 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8631 #ifdef PERL_IMPLICIT_SYS
8632 return perl_clone_using(proto_perl, flags,
8634 proto_perl->IMemShared,
8635 proto_perl->IMemParse,
8645 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8646 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8647 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8648 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8649 struct IPerlDir* ipD, struct IPerlSock* ipS,
8650 struct IPerlProc* ipP)
8652 /* XXX many of the string copies here can be optimized if they're
8653 * constants; they need to be allocated as common memory and just
8654 * their pointers copied. */
8658 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8660 PERL_SET_THX(pPerl);
8661 # else /* !PERL_OBJECT */
8662 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8663 PERL_SET_THX(my_perl);
8666 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8672 # else /* !DEBUGGING */
8673 Zero(my_perl, 1, PerlInterpreter);
8674 # endif /* DEBUGGING */
8678 PL_MemShared = ipMS;
8686 # endif /* PERL_OBJECT */
8687 #else /* !PERL_IMPLICIT_SYS */
8689 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8690 PERL_SET_THX(my_perl);
8693 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8699 # else /* !DEBUGGING */
8700 Zero(my_perl, 1, PerlInterpreter);
8701 # endif /* DEBUGGING */
8702 #endif /* PERL_IMPLICIT_SYS */
8705 PL_xiv_arenaroot = NULL;
8707 PL_xnv_arenaroot = NULL;
8709 PL_xrv_arenaroot = NULL;
8711 PL_xpv_arenaroot = NULL;
8713 PL_xpviv_arenaroot = NULL;
8714 PL_xpviv_root = NULL;
8715 PL_xpvnv_arenaroot = NULL;
8716 PL_xpvnv_root = NULL;
8717 PL_xpvcv_arenaroot = NULL;
8718 PL_xpvcv_root = NULL;
8719 PL_xpvav_arenaroot = NULL;
8720 PL_xpvav_root = NULL;
8721 PL_xpvhv_arenaroot = NULL;
8722 PL_xpvhv_root = NULL;
8723 PL_xpvmg_arenaroot = NULL;
8724 PL_xpvmg_root = NULL;
8725 PL_xpvlv_arenaroot = NULL;
8726 PL_xpvlv_root = NULL;
8727 PL_xpvbm_arenaroot = NULL;
8728 PL_xpvbm_root = NULL;
8729 PL_he_arenaroot = NULL;
8731 PL_nice_chunk = NULL;
8732 PL_nice_chunk_size = 0;
8735 PL_sv_root = Nullsv;
8736 PL_sv_arenaroot = Nullsv;
8738 PL_debug = proto_perl->Idebug;
8740 /* create SV map for pointer relocation */
8741 PL_ptr_table = ptr_table_new();
8743 /* initialize these special pointers as early as possible */
8744 SvANY(&PL_sv_undef) = NULL;
8745 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8746 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8747 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8750 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8752 SvANY(&PL_sv_no) = new_XPVNV();
8754 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8755 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8756 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8757 SvCUR(&PL_sv_no) = 0;
8758 SvLEN(&PL_sv_no) = 1;
8759 SvNVX(&PL_sv_no) = 0;
8760 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8763 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8765 SvANY(&PL_sv_yes) = new_XPVNV();
8767 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8768 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8769 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8770 SvCUR(&PL_sv_yes) = 1;
8771 SvLEN(&PL_sv_yes) = 2;
8772 SvNVX(&PL_sv_yes) = 1;
8773 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8775 /* create shared string table */
8776 PL_strtab = newHV();
8777 HvSHAREKEYS_off(PL_strtab);
8778 hv_ksplit(PL_strtab, 512);
8779 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8781 PL_compiling = proto_perl->Icompiling;
8782 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8783 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8784 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8785 if (!specialWARN(PL_compiling.cop_warnings))
8786 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8787 if (!specialCopIO(PL_compiling.cop_io))
8788 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8789 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8791 /* pseudo environmental stuff */
8792 PL_origargc = proto_perl->Iorigargc;
8794 New(0, PL_origargv, i+1, char*);
8795 PL_origargv[i] = '\0';
8797 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8799 PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */
8800 PL_envgv = gv_dup(proto_perl->Ienvgv);
8801 PL_incgv = gv_dup(proto_perl->Iincgv);
8802 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8803 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8804 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8805 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8808 PL_minus_c = proto_perl->Iminus_c;
8809 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8810 PL_localpatches = proto_perl->Ilocalpatches;
8811 PL_splitstr = proto_perl->Isplitstr;
8812 PL_preprocess = proto_perl->Ipreprocess;
8813 PL_minus_n = proto_perl->Iminus_n;
8814 PL_minus_p = proto_perl->Iminus_p;
8815 PL_minus_l = proto_perl->Iminus_l;
8816 PL_minus_a = proto_perl->Iminus_a;
8817 PL_minus_F = proto_perl->Iminus_F;
8818 PL_doswitches = proto_perl->Idoswitches;
8819 PL_dowarn = proto_perl->Idowarn;
8820 PL_doextract = proto_perl->Idoextract;
8821 PL_sawampersand = proto_perl->Isawampersand;
8822 PL_unsafe = proto_perl->Iunsafe;
8823 PL_inplace = SAVEPV(proto_perl->Iinplace);
8824 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8825 PL_perldb = proto_perl->Iperldb;
8826 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8828 /* magical thingies */
8829 /* XXX time(&PL_basetime) when asked for? */
8830 PL_basetime = proto_perl->Ibasetime;
8831 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8833 PL_maxsysfd = proto_perl->Imaxsysfd;
8834 PL_multiline = proto_perl->Imultiline;
8835 PL_statusvalue = proto_perl->Istatusvalue;
8837 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8840 /* shortcuts to various I/O objects */
8841 PL_stdingv = gv_dup(proto_perl->Istdingv);
8842 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8843 PL_defgv = gv_dup(proto_perl->Idefgv);
8844 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8845 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8846 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8848 /* shortcuts to regexp stuff */
8849 PL_replgv = gv_dup(proto_perl->Ireplgv);
8851 /* shortcuts to misc objects */
8852 PL_errgv = gv_dup(proto_perl->Ierrgv);
8854 /* shortcuts to debugging objects */
8855 PL_DBgv = gv_dup(proto_perl->IDBgv);
8856 PL_DBline = gv_dup(proto_perl->IDBline);
8857 PL_DBsub = gv_dup(proto_perl->IDBsub);
8858 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8859 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8860 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8861 PL_lineary = av_dup(proto_perl->Ilineary);
8862 PL_dbargs = av_dup(proto_perl->Idbargs);
8865 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8866 PL_curstash = hv_dup(proto_perl->Tcurstash);
8867 PL_debstash = hv_dup(proto_perl->Idebstash);
8868 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8869 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8871 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8872 PL_endav = av_dup_inc(proto_perl->Iendav);
8873 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8874 PL_initav = av_dup_inc(proto_perl->Iinitav);
8876 PL_sub_generation = proto_perl->Isub_generation;
8878 /* funky return mechanisms */
8879 PL_forkprocess = proto_perl->Iforkprocess;
8881 /* subprocess state */
8882 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8884 /* internal state */
8885 PL_tainting = proto_perl->Itainting;
8886 PL_maxo = proto_perl->Imaxo;
8887 if (proto_perl->Iop_mask)
8888 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8890 PL_op_mask = Nullch;
8892 /* current interpreter roots */
8893 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8894 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8895 PL_main_start = proto_perl->Imain_start;
8896 PL_eval_root = proto_perl->Ieval_root;
8897 PL_eval_start = proto_perl->Ieval_start;
8899 /* runtime control stuff */
8900 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8901 PL_copline = proto_perl->Icopline;
8903 PL_filemode = proto_perl->Ifilemode;
8904 PL_lastfd = proto_perl->Ilastfd;
8905 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8908 PL_gensym = proto_perl->Igensym;
8909 PL_preambled = proto_perl->Ipreambled;
8910 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8911 PL_laststatval = proto_perl->Ilaststatval;
8912 PL_laststype = proto_perl->Ilaststype;
8913 PL_mess_sv = Nullsv;
8915 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8916 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8918 /* interpreter atexit processing */
8919 PL_exitlistlen = proto_perl->Iexitlistlen;
8920 if (PL_exitlistlen) {
8921 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8922 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8925 PL_exitlist = (PerlExitListEntry*)NULL;
8926 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8928 PL_profiledata = NULL;
8929 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8930 /* PL_rsfp_filters entries have fake IoDIRP() */
8931 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8933 PL_compcv = cv_dup(proto_perl->Icompcv);
8934 PL_comppad = av_dup(proto_perl->Icomppad);
8935 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8936 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8937 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8938 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8939 proto_perl->Tcurpad);
8941 #ifdef HAVE_INTERP_INTERN
8942 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8945 /* more statics moved here */
8946 PL_generation = proto_perl->Igeneration;
8947 PL_DBcv = cv_dup(proto_perl->IDBcv);
8949 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8950 PL_in_clean_all = proto_perl->Iin_clean_all;
8952 PL_uid = proto_perl->Iuid;
8953 PL_euid = proto_perl->Ieuid;
8954 PL_gid = proto_perl->Igid;
8955 PL_egid = proto_perl->Iegid;
8956 PL_nomemok = proto_perl->Inomemok;
8957 PL_an = proto_perl->Ian;
8958 PL_cop_seqmax = proto_perl->Icop_seqmax;
8959 PL_op_seqmax = proto_perl->Iop_seqmax;
8960 PL_evalseq = proto_perl->Ievalseq;
8961 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8962 PL_origalen = proto_perl->Iorigalen;
8963 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8964 PL_osname = SAVEPV(proto_perl->Iosname);
8965 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8966 PL_sighandlerp = proto_perl->Isighandlerp;
8969 PL_runops = proto_perl->Irunops;
8971 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8974 PL_cshlen = proto_perl->Icshlen;
8975 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8978 PL_lex_state = proto_perl->Ilex_state;
8979 PL_lex_defer = proto_perl->Ilex_defer;
8980 PL_lex_expect = proto_perl->Ilex_expect;
8981 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8982 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8983 PL_lex_starts = proto_perl->Ilex_starts;
8984 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8985 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8986 PL_lex_op = proto_perl->Ilex_op;
8987 PL_lex_inpat = proto_perl->Ilex_inpat;
8988 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8989 PL_lex_brackets = proto_perl->Ilex_brackets;
8990 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8991 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8992 PL_lex_casemods = proto_perl->Ilex_casemods;
8993 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8994 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8996 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8997 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8998 PL_nexttoke = proto_perl->Inexttoke;
9000 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9001 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9002 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9003 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9004 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9005 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9006 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9007 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9008 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9009 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9010 PL_pending_ident = proto_perl->Ipending_ident;
9011 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9013 PL_expect = proto_perl->Iexpect;
9015 PL_multi_start = proto_perl->Imulti_start;
9016 PL_multi_end = proto_perl->Imulti_end;
9017 PL_multi_open = proto_perl->Imulti_open;
9018 PL_multi_close = proto_perl->Imulti_close;
9020 PL_error_count = proto_perl->Ierror_count;
9021 PL_subline = proto_perl->Isubline;
9022 PL_subname = sv_dup_inc(proto_perl->Isubname);
9024 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9025 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9026 PL_padix = proto_perl->Ipadix;
9027 PL_padix_floor = proto_perl->Ipadix_floor;
9028 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9030 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9031 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9032 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9033 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9034 PL_last_lop_op = proto_perl->Ilast_lop_op;
9035 PL_in_my = proto_perl->Iin_my;
9036 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9038 PL_cryptseen = proto_perl->Icryptseen;
9041 PL_hints = proto_perl->Ihints;
9043 PL_amagic_generation = proto_perl->Iamagic_generation;
9045 #ifdef USE_LOCALE_COLLATE
9046 PL_collation_ix = proto_perl->Icollation_ix;
9047 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9048 PL_collation_standard = proto_perl->Icollation_standard;
9049 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9050 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9051 #endif /* USE_LOCALE_COLLATE */
9053 #ifdef USE_LOCALE_NUMERIC
9054 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9055 PL_numeric_standard = proto_perl->Inumeric_standard;
9056 PL_numeric_local = proto_perl->Inumeric_local;
9057 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9058 #endif /* !USE_LOCALE_NUMERIC */
9060 /* utf8 character classes */
9061 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9062 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9063 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9064 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9065 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9066 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9067 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9068 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9069 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9070 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9071 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9072 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9073 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9074 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9075 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9076 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9077 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9080 PL_last_swash_hv = Nullhv; /* reinits on demand */
9081 PL_last_swash_klen = 0;
9082 PL_last_swash_key[0]= '\0';
9083 PL_last_swash_tmps = (U8*)NULL;
9084 PL_last_swash_slen = 0;
9086 /* perly.c globals */
9087 PL_yydebug = proto_perl->Iyydebug;
9088 PL_yynerrs = proto_perl->Iyynerrs;
9089 PL_yyerrflag = proto_perl->Iyyerrflag;
9090 PL_yychar = proto_perl->Iyychar;
9091 PL_yyval = proto_perl->Iyyval;
9092 PL_yylval = proto_perl->Iyylval;
9094 PL_glob_index = proto_perl->Iglob_index;
9095 PL_srand_called = proto_perl->Isrand_called;
9096 PL_uudmap['M'] = 0; /* reinits on demand */
9097 PL_bitcount = Nullch; /* reinits on demand */
9099 if (proto_perl->Ipsig_pend) {
9100 Newz(0, PL_psig_pend, SIG_SIZE, int);
9103 PL_psig_pend = (int*)NULL;
9106 if (proto_perl->Ipsig_ptr) {
9107 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9108 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9109 for (i = 1; i < SIG_SIZE; i++) {
9110 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9111 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9115 PL_psig_ptr = (SV**)NULL;
9116 PL_psig_name = (SV**)NULL;
9119 /* thrdvar.h stuff */
9121 if (flags & CLONEf_COPY_STACKS) {
9122 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9123 PL_tmps_ix = proto_perl->Ttmps_ix;
9124 PL_tmps_max = proto_perl->Ttmps_max;
9125 PL_tmps_floor = proto_perl->Ttmps_floor;
9126 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9128 while (i <= PL_tmps_ix) {
9129 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9133 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9134 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9135 Newz(54, PL_markstack, i, I32);
9136 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9137 - proto_perl->Tmarkstack);
9138 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9139 - proto_perl->Tmarkstack);
9140 Copy(proto_perl->Tmarkstack, PL_markstack,
9141 PL_markstack_ptr - PL_markstack + 1, I32);
9143 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9144 * NOTE: unlike the others! */
9145 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9146 PL_scopestack_max = proto_perl->Tscopestack_max;
9147 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9148 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9150 /* next push_return() sets PL_retstack[PL_retstack_ix]
9151 * NOTE: unlike the others! */
9152 PL_retstack_ix = proto_perl->Tretstack_ix;
9153 PL_retstack_max = proto_perl->Tretstack_max;
9154 Newz(54, PL_retstack, PL_retstack_max, OP*);
9155 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9157 /* NOTE: si_dup() looks at PL_markstack */
9158 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9160 /* PL_curstack = PL_curstackinfo->si_stack; */
9161 PL_curstack = av_dup(proto_perl->Tcurstack);
9162 PL_mainstack = av_dup(proto_perl->Tmainstack);
9164 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9165 PL_stack_base = AvARRAY(PL_curstack);
9166 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9167 - proto_perl->Tstack_base);
9168 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9170 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9171 * NOTE: unlike the others! */
9172 PL_savestack_ix = proto_perl->Tsavestack_ix;
9173 PL_savestack_max = proto_perl->Tsavestack_max;
9174 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9175 PL_savestack = ss_dup(proto_perl);
9179 ENTER; /* perl_destruct() wants to LEAVE; */
9182 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9183 PL_top_env = &PL_start_env;
9185 PL_op = proto_perl->Top;
9188 PL_Xpv = (XPV*)NULL;
9189 PL_na = proto_perl->Tna;
9191 PL_statbuf = proto_perl->Tstatbuf;
9192 PL_statcache = proto_perl->Tstatcache;
9193 PL_statgv = gv_dup(proto_perl->Tstatgv);
9194 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9196 PL_timesbuf = proto_perl->Ttimesbuf;
9199 PL_tainted = proto_perl->Ttainted;
9200 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9201 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9202 PL_rs = sv_dup_inc(proto_perl->Trs);
9203 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9204 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9205 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9206 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9207 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9208 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9209 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9211 PL_restartop = proto_perl->Trestartop;
9212 PL_in_eval = proto_perl->Tin_eval;
9213 PL_delaymagic = proto_perl->Tdelaymagic;
9214 PL_dirty = proto_perl->Tdirty;
9215 PL_localizing = proto_perl->Tlocalizing;
9217 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9218 PL_protect = proto_perl->Tprotect;
9220 PL_errors = sv_dup_inc(proto_perl->Terrors);
9221 PL_av_fetch_sv = Nullsv;
9222 PL_hv_fetch_sv = Nullsv;
9223 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9224 PL_modcount = proto_perl->Tmodcount;
9225 PL_lastgotoprobe = Nullop;
9226 PL_dumpindent = proto_perl->Tdumpindent;
9228 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9229 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9230 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9231 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9232 PL_sortcxix = proto_perl->Tsortcxix;
9233 PL_efloatbuf = Nullch; /* reinits on demand */
9234 PL_efloatsize = 0; /* reinits on demand */
9238 PL_screamfirst = NULL;
9239 PL_screamnext = NULL;
9240 PL_maxscream = -1; /* reinits on demand */
9241 PL_lastscream = Nullsv;
9243 PL_watchaddr = NULL;
9244 PL_watchok = Nullch;
9246 PL_regdummy = proto_perl->Tregdummy;
9247 PL_regcomp_parse = Nullch;
9248 PL_regxend = Nullch;
9249 PL_regcode = (regnode*)NULL;
9252 PL_regprecomp = Nullch;
9257 PL_seen_zerolen = 0;
9259 PL_regcomp_rx = (regexp*)NULL;
9261 PL_colorset = 0; /* reinits PL_colors[] */
9262 /*PL_colors[6] = {0,0,0,0,0,0};*/
9263 PL_reg_whilem_seen = 0;
9264 PL_reginput = Nullch;
9267 PL_regstartp = (I32*)NULL;
9268 PL_regendp = (I32*)NULL;
9269 PL_reglastparen = (U32*)NULL;
9270 PL_regtill = Nullch;
9271 PL_reg_start_tmp = (char**)NULL;
9272 PL_reg_start_tmpl = 0;
9273 PL_regdata = (struct reg_data*)NULL;
9276 PL_reg_eval_set = 0;
9278 PL_regprogram = (regnode*)NULL;
9280 PL_regcc = (CURCUR*)NULL;
9281 PL_reg_call_cc = (struct re_cc_state*)NULL;
9282 PL_reg_re = (regexp*)NULL;
9283 PL_reg_ganch = Nullch;
9285 PL_reg_magic = (MAGIC*)NULL;
9287 PL_reg_oldcurpm = (PMOP*)NULL;
9288 PL_reg_curpm = (PMOP*)NULL;
9289 PL_reg_oldsaved = Nullch;
9290 PL_reg_oldsavedlen = 0;
9292 PL_reg_leftiter = 0;
9293 PL_reg_poscache = Nullch;
9294 PL_reg_poscache_size= 0;
9296 /* RE engine - function pointers */
9297 PL_regcompp = proto_perl->Tregcompp;
9298 PL_regexecp = proto_perl->Tregexecp;
9299 PL_regint_start = proto_perl->Tregint_start;
9300 PL_regint_string = proto_perl->Tregint_string;
9301 PL_regfree = proto_perl->Tregfree;
9303 PL_reginterp_cnt = 0;
9304 PL_reg_starttry = 0;
9306 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9307 ptr_table_free(PL_ptr_table);
9308 PL_ptr_table = NULL;
9311 /* Call the ->CLONE method, if it exists, for each of the stashes
9312 identified by sv_dup() above.
9314 while(av_len(PL_clone_callbacks) != -1) {
9315 HV* stash = (HV*) av_shift(PL_clone_callbacks);
9316 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
9317 if (cloner && GvCV(cloner)) {
9322 XPUSHs(newSVpv(HvNAME(stash), 0));
9324 call_sv((SV*)GvCV(cloner), G_DISCARD);
9331 return (PerlInterpreter*)pPerl;
9337 #else /* !USE_ITHREADS */
9343 #endif /* USE_ITHREADS */
9346 do_report_used(pTHXo_ SV *sv)
9348 if (SvTYPE(sv) != SVTYPEMASK) {
9349 PerlIO_printf(Perl_debug_log, "****\n");
9355 do_clean_objs(pTHXo_ SV *sv)
9359 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9360 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9361 if (SvWEAKREF(sv)) {
9372 /* XXX Might want to check arrays, etc. */
9375 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9377 do_clean_named_objs(pTHXo_ SV *sv)
9379 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9380 if ( SvOBJECT(GvSV(sv)) ||
9381 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9382 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9383 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9384 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9386 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9394 do_clean_all(pTHXo_ SV *sv)
9396 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9397 SvFLAGS(sv) |= SVf_BREAK;