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);
3220 GvINTRO_off(dstr); /* one-shot flag */
3221 Newz(602,gp, 1, GP);
3222 GvGP(dstr) = gp_ref(gp);
3223 GvSV(dstr) = NEWSV(72,0);
3224 GvLINE(dstr) = CopLINE(PL_curcop);
3225 GvEGV(dstr) = (GV*)dstr;
3228 switch (SvTYPE(sref)) {
3231 SAVESPTR(GvAV(dstr));
3233 dref = (SV*)GvAV(dstr);
3234 GvAV(dstr) = (AV*)sref;
3235 if (!GvIMPORTED_AV(dstr)
3236 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3238 GvIMPORTED_AV_on(dstr);
3243 SAVESPTR(GvHV(dstr));
3245 dref = (SV*)GvHV(dstr);
3246 GvHV(dstr) = (HV*)sref;
3247 if (!GvIMPORTED_HV(dstr)
3248 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3250 GvIMPORTED_HV_on(dstr);
3255 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3256 SvREFCNT_dec(GvCV(dstr));
3257 GvCV(dstr) = Nullcv;
3258 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3259 PL_sub_generation++;
3261 SAVESPTR(GvCV(dstr));
3264 dref = (SV*)GvCV(dstr);
3265 if (GvCV(dstr) != (CV*)sref) {
3266 CV* cv = GvCV(dstr);
3268 if (!GvCVGEN((GV*)dstr) &&
3269 (CvROOT(cv) || CvXSUB(cv)))
3271 /* ahem, death to those who redefine
3272 * active sort subs */
3273 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3274 PL_sortcop == CvSTART(cv))
3276 "Can't redefine active sort subroutine %s",
3277 GvENAME((GV*)dstr));
3278 /* Redefining a sub - warning is mandatory if
3279 it was a const and its value changed. */
3280 if (ckWARN(WARN_REDEFINE)
3282 && (!CvCONST((CV*)sref)
3283 || sv_cmp(cv_const_sv(cv),
3284 cv_const_sv((CV*)sref)))))
3286 Perl_warner(aTHX_ WARN_REDEFINE,
3288 ? "Constant subroutine %s redefined"
3289 : "Subroutine %s redefined",
3290 GvENAME((GV*)dstr));
3293 cv_ckproto(cv, (GV*)dstr,
3294 SvPOK(sref) ? SvPVX(sref) : Nullch);
3296 GvCV(dstr) = (CV*)sref;
3297 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3298 GvASSUMECV_on(dstr);
3299 PL_sub_generation++;
3301 if (!GvIMPORTED_CV(dstr)
3302 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3304 GvIMPORTED_CV_on(dstr);
3309 SAVESPTR(GvIOp(dstr));
3311 dref = (SV*)GvIOp(dstr);
3312 GvIOp(dstr) = (IO*)sref;
3316 SAVESPTR(GvFORM(dstr));
3318 dref = (SV*)GvFORM(dstr);
3319 GvFORM(dstr) = (CV*)sref;
3323 SAVESPTR(GvSV(dstr));
3325 dref = (SV*)GvSV(dstr);
3327 if (!GvIMPORTED_SV(dstr)
3328 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3330 GvIMPORTED_SV_on(dstr);
3338 if (SvTAINTED(sstr))
3343 (void)SvOOK_off(dstr); /* backoff */
3345 Safefree(SvPVX(dstr));
3346 SvLEN(dstr)=SvCUR(dstr)=0;
3349 (void)SvOK_off(dstr);
3350 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3352 if (sflags & SVp_NOK) {
3354 /* Only set the public OK flag if the source has public OK. */
3355 if (sflags & SVf_NOK)
3356 SvFLAGS(dstr) |= SVf_NOK;
3357 SvNVX(dstr) = SvNVX(sstr);
3359 if (sflags & SVp_IOK) {
3360 (void)SvIOKp_on(dstr);
3361 if (sflags & SVf_IOK)
3362 SvFLAGS(dstr) |= SVf_IOK;
3363 if (sflags & SVf_IVisUV)
3365 SvIVX(dstr) = SvIVX(sstr);
3367 if (SvAMAGIC(sstr)) {
3371 else if (sflags & SVp_POK) {
3374 * Check to see if we can just swipe the string. If so, it's a
3375 * possible small lose on short strings, but a big win on long ones.
3376 * It might even be a win on short strings if SvPVX(dstr)
3377 * has to be allocated and SvPVX(sstr) has to be freed.
3380 if (SvTEMP(sstr) && /* slated for free anyway? */
3381 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3382 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3383 SvLEN(sstr) && /* and really is a string */
3384 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3386 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3388 SvFLAGS(dstr) &= ~SVf_OOK;
3389 Safefree(SvPVX(dstr) - SvIVX(dstr));
3391 else if (SvLEN(dstr))
3392 Safefree(SvPVX(dstr));
3394 (void)SvPOK_only(dstr);
3395 SvPV_set(dstr, SvPVX(sstr));
3396 SvLEN_set(dstr, SvLEN(sstr));
3397 SvCUR_set(dstr, SvCUR(sstr));
3400 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3401 SvPV_set(sstr, Nullch);
3406 else { /* have to copy actual string */
3407 STRLEN len = SvCUR(sstr);
3409 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3410 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3411 SvCUR_set(dstr, len);
3412 *SvEND(dstr) = '\0';
3413 (void)SvPOK_only(dstr);
3415 if (sflags & SVf_UTF8)
3418 if (sflags & SVp_NOK) {
3420 if (sflags & SVf_NOK)
3421 SvFLAGS(dstr) |= SVf_NOK;
3422 SvNVX(dstr) = SvNVX(sstr);
3424 if (sflags & SVp_IOK) {
3425 (void)SvIOKp_on(dstr);
3426 if (sflags & SVf_IOK)
3427 SvFLAGS(dstr) |= SVf_IOK;
3428 if (sflags & SVf_IVisUV)
3430 SvIVX(dstr) = SvIVX(sstr);
3433 else if (sflags & SVp_IOK) {
3434 if (sflags & SVf_IOK)
3435 (void)SvIOK_only(dstr);
3437 (void)SvOK_off(dstr);
3438 (void)SvIOKp_on(dstr);
3440 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3441 if (sflags & SVf_IVisUV)
3443 SvIVX(dstr) = SvIVX(sstr);
3444 if (sflags & SVp_NOK) {
3445 if (sflags & SVf_NOK)
3446 (void)SvNOK_on(dstr);
3448 (void)SvNOKp_on(dstr);
3449 SvNVX(dstr) = SvNVX(sstr);
3452 else if (sflags & SVp_NOK) {
3453 if (sflags & SVf_NOK)
3454 (void)SvNOK_only(dstr);
3456 (void)SvOK_off(dstr);
3459 SvNVX(dstr) = SvNVX(sstr);
3462 if (dtype == SVt_PVGV) {
3463 if (ckWARN(WARN_MISC))
3464 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3467 (void)SvOK_off(dstr);
3469 if (SvTAINTED(sstr))
3474 =for apidoc sv_setsv_mg
3476 Like C<sv_setsv>, but also handles 'set' magic.
3482 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3484 sv_setsv(dstr,sstr);
3489 =for apidoc sv_setpvn
3491 Copies a string into an SV. The C<len> parameter indicates the number of
3492 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3498 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3500 register char *dptr;
3502 SV_CHECK_THINKFIRST(sv);
3508 /* len is STRLEN which is unsigned, need to copy to signed */
3511 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3517 Move(ptr,dptr,len,char);
3520 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3525 =for apidoc sv_setpvn_mg
3527 Like C<sv_setpvn>, but also handles 'set' magic.
3533 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3535 sv_setpvn(sv,ptr,len);
3540 =for apidoc sv_setpv
3542 Copies a string into an SV. The string must be null-terminated. Does not
3543 handle 'set' magic. See C<sv_setpv_mg>.
3549 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3551 register STRLEN len;
3553 SV_CHECK_THINKFIRST(sv);
3559 (void)SvUPGRADE(sv, SVt_PV);
3561 SvGROW(sv, len + 1);
3562 Move(ptr,SvPVX(sv),len+1,char);
3564 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3569 =for apidoc sv_setpv_mg
3571 Like C<sv_setpv>, but also handles 'set' magic.
3577 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3584 =for apidoc sv_usepvn
3586 Tells an SV to use C<ptr> to find its string value. Normally the string is
3587 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3588 The C<ptr> should point to memory that was allocated by C<malloc>. The
3589 string length, C<len>, must be supplied. This function will realloc the
3590 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3591 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3592 See C<sv_usepvn_mg>.
3598 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3600 SV_CHECK_THINKFIRST(sv);
3601 (void)SvUPGRADE(sv, SVt_PV);
3606 (void)SvOOK_off(sv);
3607 if (SvPVX(sv) && SvLEN(sv))
3608 Safefree(SvPVX(sv));
3609 Renew(ptr, len+1, char);
3612 SvLEN_set(sv, len+1);
3614 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3619 =for apidoc sv_usepvn_mg
3621 Like C<sv_usepvn>, but also handles 'set' magic.
3627 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3629 sv_usepvn(sv,ptr,len);
3634 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3636 if (SvREADONLY(sv)) {
3638 char *pvx = SvPVX(sv);
3639 STRLEN len = SvCUR(sv);
3640 U32 hash = SvUVX(sv);
3641 SvGROW(sv, len + 1);
3642 Move(pvx,SvPVX(sv),len,char);
3646 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3648 else if (PL_curcop != &PL_compiling)
3649 Perl_croak(aTHX_ PL_no_modify);
3652 sv_unref_flags(sv, flags);
3653 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3658 Perl_sv_force_normal(pTHX_ register SV *sv)
3660 sv_force_normal_flags(sv, 0);
3666 Efficient removal of characters from the beginning of the string buffer.
3667 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3668 the string buffer. The C<ptr> becomes the first character of the adjusted
3675 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3679 register STRLEN delta;
3681 if (!ptr || !SvPOKp(sv))
3683 SV_CHECK_THINKFIRST(sv);
3684 if (SvTYPE(sv) < SVt_PVIV)
3685 sv_upgrade(sv,SVt_PVIV);
3688 if (!SvLEN(sv)) { /* make copy of shared string */
3689 char *pvx = SvPVX(sv);
3690 STRLEN len = SvCUR(sv);
3691 SvGROW(sv, len + 1);
3692 Move(pvx,SvPVX(sv),len,char);
3696 SvFLAGS(sv) |= SVf_OOK;
3698 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3699 delta = ptr - SvPVX(sv);
3707 =for apidoc sv_catpvn
3709 Concatenates the string onto the end of the string which is in the SV. The
3710 C<len> indicates number of bytes to copy. If the SV has the UTF8
3711 status set, then the bytes appended should be valid UTF8.
3712 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3717 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3718 for binary compatibility only
3721 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3723 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3727 =for apidoc sv_catpvn_flags
3729 Concatenates the string onto the end of the string which is in the SV. The
3730 C<len> indicates number of bytes to copy. If the SV has the UTF8
3731 status set, then the bytes appended should be valid UTF8.
3732 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3733 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3734 in terms of this function.
3740 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3745 dstr = SvPV_force_flags(dsv, dlen, flags);
3746 SvGROW(dsv, dlen + slen + 1);
3749 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3752 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3757 =for apidoc sv_catpvn_mg
3759 Like C<sv_catpvn>, but also handles 'set' magic.
3765 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3767 sv_catpvn(sv,ptr,len);
3772 =for apidoc sv_catsv
3774 Concatenates the string from SV C<ssv> onto the end of the string in
3775 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3776 not 'set' magic. See C<sv_catsv_mg>.
3780 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3781 for binary compatibility only
3784 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3786 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3790 =for apidoc sv_catsv_flags
3792 Concatenates the string from SV C<ssv> onto the end of the string in
3793 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3794 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3795 and C<sv_catsv_nomg> are implemented in terms of this function.
3800 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3806 if ((spv = SvPV(ssv, slen))) {
3807 bool sutf8 = DO_UTF8(ssv);
3810 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3812 dutf8 = DO_UTF8(dsv);
3814 if (dutf8 != sutf8) {
3816 /* Not modifying source SV, so taking a temporary copy. */
3817 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3819 sv_utf8_upgrade(csv);
3820 spv = SvPV(csv, slen);
3823 sv_utf8_upgrade_nomg(dsv);
3825 sv_catpvn_nomg(dsv, spv, slen);
3830 =for apidoc sv_catsv_mg
3832 Like C<sv_catsv>, but also handles 'set' magic.
3838 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3845 =for apidoc sv_catpv
3847 Concatenates the string onto the end of the string which is in the SV.
3848 If the SV has the UTF8 status set, then the bytes appended should be
3849 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3854 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3856 register STRLEN len;
3862 junk = SvPV_force(sv, tlen);
3864 SvGROW(sv, tlen + len + 1);
3867 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3869 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3874 =for apidoc sv_catpv_mg
3876 Like C<sv_catpv>, but also handles 'set' magic.
3882 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3889 Perl_newSV(pTHX_ STRLEN len)
3895 sv_upgrade(sv, SVt_PV);
3896 SvGROW(sv, len + 1);
3901 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3904 =for apidoc sv_magic
3906 Adds magic to an SV.
3912 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3916 if (SvREADONLY(sv)) {
3917 if (PL_curcop != &PL_compiling
3918 /* XXX this used to be !strchr("gBf", how), which seems to
3919 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
3920 * too. I find this suprising, but have hadded PERL_MAGIC_sv
3921 * to the list of things to check - DAPM 19-May-01 */
3922 && how != PERL_MAGIC_regex_global
3923 && how != PERL_MAGIC_bm
3924 && how != PERL_MAGIC_fm
3925 && how != PERL_MAGIC_sv
3928 Perl_croak(aTHX_ PL_no_modify);
3931 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
3932 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3933 if (how == PERL_MAGIC_taint)
3939 (void)SvUPGRADE(sv, SVt_PVMG);
3941 Newz(702,mg, 1, MAGIC);
3942 mg->mg_moremagic = SvMAGIC(sv);
3945 /* Some magic sontains a reference loop, where the sv and object refer to
3946 each other. To prevent a avoid a reference loop that would prevent such
3947 objects being freed, we look for such loops and if we find one we avoid
3948 incrementing the object refcount. */
3949 if (!obj || obj == sv ||
3950 how == PERL_MAGIC_arylen ||
3951 how == PERL_MAGIC_qr ||
3952 (SvTYPE(obj) == SVt_PVGV &&
3953 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
3954 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
3955 GvFORM(obj) == (CV*)sv)))
3960 mg->mg_obj = SvREFCNT_inc(obj);
3961 mg->mg_flags |= MGf_REFCOUNTED;
3964 mg->mg_len = namlen;
3967 mg->mg_ptr = savepvn(name, namlen);
3968 else if (namlen == HEf_SVKEY)
3969 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3974 mg->mg_virtual = &PL_vtbl_sv;
3976 case PERL_MAGIC_overload:
3977 mg->mg_virtual = &PL_vtbl_amagic;
3979 case PERL_MAGIC_overload_elem:
3980 mg->mg_virtual = &PL_vtbl_amagicelem;
3982 case PERL_MAGIC_overload_table:
3983 mg->mg_virtual = &PL_vtbl_ovrld;
3986 mg->mg_virtual = &PL_vtbl_bm;
3988 case PERL_MAGIC_regdata:
3989 mg->mg_virtual = &PL_vtbl_regdata;
3991 case PERL_MAGIC_regdatum:
3992 mg->mg_virtual = &PL_vtbl_regdatum;
3994 case PERL_MAGIC_env:
3995 mg->mg_virtual = &PL_vtbl_env;
3998 mg->mg_virtual = &PL_vtbl_fm;
4000 case PERL_MAGIC_envelem:
4001 mg->mg_virtual = &PL_vtbl_envelem;
4003 case PERL_MAGIC_regex_global:
4004 mg->mg_virtual = &PL_vtbl_mglob;
4006 case PERL_MAGIC_isa:
4007 mg->mg_virtual = &PL_vtbl_isa;
4009 case PERL_MAGIC_isaelem:
4010 mg->mg_virtual = &PL_vtbl_isaelem;
4012 case PERL_MAGIC_nkeys:
4013 mg->mg_virtual = &PL_vtbl_nkeys;
4015 case PERL_MAGIC_dbfile:
4019 case PERL_MAGIC_dbline:
4020 mg->mg_virtual = &PL_vtbl_dbline;
4023 case PERL_MAGIC_mutex:
4024 mg->mg_virtual = &PL_vtbl_mutex;
4026 #endif /* USE_THREADS */
4027 #ifdef USE_LOCALE_COLLATE
4028 case PERL_MAGIC_collxfrm:
4029 mg->mg_virtual = &PL_vtbl_collxfrm;
4031 #endif /* USE_LOCALE_COLLATE */
4032 case PERL_MAGIC_tied:
4033 mg->mg_virtual = &PL_vtbl_pack;
4035 case PERL_MAGIC_tiedelem:
4036 case PERL_MAGIC_tiedscalar:
4037 mg->mg_virtual = &PL_vtbl_packelem;
4040 mg->mg_virtual = &PL_vtbl_regexp;
4042 case PERL_MAGIC_sig:
4043 mg->mg_virtual = &PL_vtbl_sig;
4045 case PERL_MAGIC_sigelem:
4046 mg->mg_virtual = &PL_vtbl_sigelem;
4048 case PERL_MAGIC_taint:
4049 mg->mg_virtual = &PL_vtbl_taint;
4052 case PERL_MAGIC_uvar:
4053 mg->mg_virtual = &PL_vtbl_uvar;
4055 case PERL_MAGIC_vec:
4056 mg->mg_virtual = &PL_vtbl_vec;
4058 case PERL_MAGIC_substr:
4059 mg->mg_virtual = &PL_vtbl_substr;
4061 case PERL_MAGIC_defelem:
4062 mg->mg_virtual = &PL_vtbl_defelem;
4064 case PERL_MAGIC_glob:
4065 mg->mg_virtual = &PL_vtbl_glob;
4067 case PERL_MAGIC_arylen:
4068 mg->mg_virtual = &PL_vtbl_arylen;
4070 case PERL_MAGIC_pos:
4071 mg->mg_virtual = &PL_vtbl_pos;
4073 case PERL_MAGIC_backref:
4074 mg->mg_virtual = &PL_vtbl_backref;
4076 case PERL_MAGIC_ext:
4077 /* Reserved for use by extensions not perl internals. */
4078 /* Useful for attaching extension internal data to perl vars. */
4079 /* Note that multiple extensions may clash if magical scalars */
4080 /* etc holding private data from one are passed to another. */
4084 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4088 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4092 =for apidoc sv_unmagic
4094 Removes magic from an SV.
4100 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4104 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4107 for (mg = *mgp; mg; mg = *mgp) {
4108 if (mg->mg_type == type) {
4109 MGVTBL* vtbl = mg->mg_virtual;
4110 *mgp = mg->mg_moremagic;
4111 if (vtbl && vtbl->svt_free)
4112 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4113 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4114 if (mg->mg_len >= 0)
4115 Safefree(mg->mg_ptr);
4116 else if (mg->mg_len == HEf_SVKEY)
4117 SvREFCNT_dec((SV*)mg->mg_ptr);
4119 if (mg->mg_flags & MGf_REFCOUNTED)
4120 SvREFCNT_dec(mg->mg_obj);
4124 mgp = &mg->mg_moremagic;
4128 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4135 =for apidoc sv_rvweaken
4143 Perl_sv_rvweaken(pTHX_ SV *sv)
4146 if (!SvOK(sv)) /* let undefs pass */
4149 Perl_croak(aTHX_ "Can't weaken a nonreference");
4150 else if (SvWEAKREF(sv)) {
4151 if (ckWARN(WARN_MISC))
4152 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4156 sv_add_backref(tsv, sv);
4163 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4167 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4168 av = (AV*)mg->mg_obj;
4171 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4172 SvREFCNT_dec(av); /* for sv_magic */
4178 S_sv_del_backref(pTHX_ SV *sv)
4185 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4186 Perl_croak(aTHX_ "panic: del_backref");
4187 av = (AV *)mg->mg_obj;
4192 svp[i] = &PL_sv_undef; /* XXX */
4199 =for apidoc sv_insert
4201 Inserts a string at the specified offset/length within the SV. Similar to
4202 the Perl substr() function.
4208 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4212 register char *midend;
4213 register char *bigend;
4219 Perl_croak(aTHX_ "Can't modify non-existent substring");
4220 SvPV_force(bigstr, curlen);
4221 (void)SvPOK_only_UTF8(bigstr);
4222 if (offset + len > curlen) {
4223 SvGROW(bigstr, offset+len+1);
4224 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4225 SvCUR_set(bigstr, offset+len);
4229 i = littlelen - len;
4230 if (i > 0) { /* string might grow */
4231 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4232 mid = big + offset + len;
4233 midend = bigend = big + SvCUR(bigstr);
4236 while (midend > mid) /* shove everything down */
4237 *--bigend = *--midend;
4238 Move(little,big+offset,littlelen,char);
4244 Move(little,SvPVX(bigstr)+offset,len,char);
4249 big = SvPVX(bigstr);
4252 bigend = big + SvCUR(bigstr);
4254 if (midend > bigend)
4255 Perl_croak(aTHX_ "panic: sv_insert");
4257 if (mid - big > bigend - midend) { /* faster to shorten from end */
4259 Move(little, mid, littlelen,char);
4262 i = bigend - midend;
4264 Move(midend, mid, i,char);
4268 SvCUR_set(bigstr, mid - big);
4271 else if ((i = mid - big)) { /* faster from front */
4272 midend -= littlelen;
4274 sv_chop(bigstr,midend-i);
4279 Move(little, mid, littlelen,char);
4281 else if (littlelen) {
4282 midend -= littlelen;
4283 sv_chop(bigstr,midend);
4284 Move(little,midend,littlelen,char);
4287 sv_chop(bigstr,midend);
4293 =for apidoc sv_replace
4295 Make the first argument a copy of the second, then delete the original.
4301 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4303 U32 refcnt = SvREFCNT(sv);
4304 SV_CHECK_THINKFIRST(sv);
4305 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4306 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4307 if (SvMAGICAL(sv)) {
4311 sv_upgrade(nsv, SVt_PVMG);
4312 SvMAGIC(nsv) = SvMAGIC(sv);
4313 SvFLAGS(nsv) |= SvMAGICAL(sv);
4319 assert(!SvREFCNT(sv));
4320 StructCopy(nsv,sv,SV);
4321 SvREFCNT(sv) = refcnt;
4322 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4327 =for apidoc sv_clear
4329 Clear an SV, making it empty. Does not free the memory used by the SV
4336 Perl_sv_clear(pTHX_ register SV *sv)
4340 assert(SvREFCNT(sv) == 0);
4343 if (PL_defstash) { /* Still have a symbol table? */
4348 Zero(&tmpref, 1, SV);
4349 sv_upgrade(&tmpref, SVt_RV);
4351 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4352 SvREFCNT(&tmpref) = 1;
4355 stash = SvSTASH(sv);
4356 destructor = StashHANDLER(stash,DESTROY);
4359 PUSHSTACKi(PERLSI_DESTROY);
4360 SvRV(&tmpref) = SvREFCNT_inc(sv);
4365 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4371 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4373 del_XRV(SvANY(&tmpref));
4376 if (PL_in_clean_objs)
4377 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4379 /* DESTROY gave object new lease on life */
4385 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4386 SvOBJECT_off(sv); /* Curse the object. */
4387 if (SvTYPE(sv) != SVt_PVIO)
4388 --PL_sv_objcount; /* XXX Might want something more general */
4391 if (SvTYPE(sv) >= SVt_PVMG) {
4394 if (SvFLAGS(sv) & SVpad_TYPED)
4395 SvREFCNT_dec(SvSTASH(sv));
4398 switch (SvTYPE(sv)) {
4401 IoIFP(sv) != PerlIO_stdin() &&
4402 IoIFP(sv) != PerlIO_stdout() &&
4403 IoIFP(sv) != PerlIO_stderr())
4405 io_close((IO*)sv, FALSE);
4407 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4408 PerlDir_close(IoDIRP(sv));
4409 IoDIRP(sv) = (DIR*)NULL;
4410 Safefree(IoTOP_NAME(sv));
4411 Safefree(IoFMT_NAME(sv));
4412 Safefree(IoBOTTOM_NAME(sv));
4427 SvREFCNT_dec(LvTARG(sv));
4431 Safefree(GvNAME(sv));
4432 /* cannot decrease stash refcount yet, as we might recursively delete
4433 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4434 of stash until current sv is completely gone.
4435 -- JohnPC, 27 Mar 1998 */
4436 stash = GvSTASH(sv);
4442 (void)SvOOK_off(sv);
4450 SvREFCNT_dec(SvRV(sv));
4452 else if (SvPVX(sv) && SvLEN(sv))
4453 Safefree(SvPVX(sv));
4454 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4455 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4467 switch (SvTYPE(sv)) {
4483 del_XPVIV(SvANY(sv));
4486 del_XPVNV(SvANY(sv));
4489 del_XPVMG(SvANY(sv));
4492 del_XPVLV(SvANY(sv));
4495 del_XPVAV(SvANY(sv));
4498 del_XPVHV(SvANY(sv));
4501 del_XPVCV(SvANY(sv));
4504 del_XPVGV(SvANY(sv));
4505 /* code duplication for increased performance. */
4506 SvFLAGS(sv) &= SVf_BREAK;
4507 SvFLAGS(sv) |= SVTYPEMASK;
4508 /* decrease refcount of the stash that owns this GV, if any */
4510 SvREFCNT_dec(stash);
4511 return; /* not break, SvFLAGS reset already happened */
4513 del_XPVBM(SvANY(sv));
4516 del_XPVFM(SvANY(sv));
4519 del_XPVIO(SvANY(sv));
4522 SvFLAGS(sv) &= SVf_BREAK;
4523 SvFLAGS(sv) |= SVTYPEMASK;
4527 Perl_sv_newref(pTHX_ SV *sv)
4530 ATOMIC_INC(SvREFCNT(sv));
4537 Free the memory used by an SV.
4543 Perl_sv_free(pTHX_ SV *sv)
4545 int refcount_is_zero;
4549 if (SvREFCNT(sv) == 0) {
4550 if (SvFLAGS(sv) & SVf_BREAK)
4552 if (PL_in_clean_all) /* All is fair */
4554 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4555 /* make sure SvREFCNT(sv)==0 happens very seldom */
4556 SvREFCNT(sv) = (~(U32)0)/2;
4559 if (ckWARN_d(WARN_INTERNAL))
4560 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4563 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4564 if (!refcount_is_zero)
4568 if (ckWARN_d(WARN_DEBUGGING))
4569 Perl_warner(aTHX_ WARN_DEBUGGING,
4570 "Attempt to free temp prematurely: SV 0x%"UVxf,
4575 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4576 /* make sure SvREFCNT(sv)==0 happens very seldom */
4577 SvREFCNT(sv) = (~(U32)0)/2;
4588 Returns the length of the string in the SV. See also C<SvCUR>.
4594 Perl_sv_len(pTHX_ register SV *sv)
4603 len = mg_length(sv);
4605 junk = SvPV(sv, len);
4610 =for apidoc sv_len_utf8
4612 Returns the number of characters in the string in an SV, counting wide
4613 UTF8 bytes as a single character.
4619 Perl_sv_len_utf8(pTHX_ register SV *sv)
4625 return mg_length(sv);
4629 U8 *s = (U8*)SvPV(sv, len);
4631 return Perl_utf8_length(aTHX_ s, s + len);
4636 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4641 I32 uoffset = *offsetp;
4647 start = s = (U8*)SvPV(sv, len);
4649 while (s < send && uoffset--)
4653 *offsetp = s - start;
4657 while (s < send && ulen--)
4667 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4676 s = (U8*)SvPV(sv, len);
4678 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4679 send = s + *offsetp;
4683 /* Call utf8n_to_uvchr() to validate the sequence */
4684 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4699 Returns a boolean indicating whether the strings in the two SVs are
4706 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4720 pv1 = SvPV(sv1, cur1);
4727 pv2 = SvPV(sv2, cur2);
4729 /* do not utf8ize the comparands as a side-effect */
4730 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4731 bool is_utf8 = TRUE;
4732 /* UTF-8ness differs */
4733 if (PL_hints & HINT_UTF8_DISTINCT)
4737 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4738 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4743 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4744 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4749 /* Downgrade not possible - cannot be eq */
4755 eq = memEQ(pv1, pv2, cur1);
4766 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4767 string in C<sv1> is less than, equal to, or greater than the string in
4774 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4779 bool pv1tmp = FALSE;
4780 bool pv2tmp = FALSE;
4787 pv1 = SvPV(sv1, cur1);
4794 pv2 = SvPV(sv2, cur2);
4796 /* do not utf8ize the comparands as a side-effect */
4797 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4798 if (PL_hints & HINT_UTF8_DISTINCT)
4799 return SvUTF8(sv1) ? 1 : -1;
4802 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4806 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4812 cmp = cur2 ? -1 : 0;
4816 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4819 cmp = retval < 0 ? -1 : 1;
4820 } else if (cur1 == cur2) {
4823 cmp = cur1 < cur2 ? -1 : 1;
4836 =for apidoc sv_cmp_locale
4838 Compares the strings in two SVs in a locale-aware manner. See
4845 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4847 #ifdef USE_LOCALE_COLLATE
4853 if (PL_collation_standard)
4857 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4859 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4861 if (!pv1 || !len1) {
4872 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4875 return retval < 0 ? -1 : 1;
4878 * When the result of collation is equality, that doesn't mean
4879 * that there are no differences -- some locales exclude some
4880 * characters from consideration. So to avoid false equalities,
4881 * we use the raw string as a tiebreaker.
4887 #endif /* USE_LOCALE_COLLATE */
4889 return sv_cmp(sv1, sv2);
4892 #ifdef USE_LOCALE_COLLATE
4894 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
4895 * scalar data of the variable transformed to such a format that
4896 * a normal memory comparison can be used to compare the data
4897 * according to the locale settings.
4900 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4904 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
4905 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4910 Safefree(mg->mg_ptr);
4912 if ((xf = mem_collxfrm(s, len, &xlen))) {
4913 if (SvREADONLY(sv)) {
4916 return xf + sizeof(PL_collation_ix);
4919 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
4920 mg = mg_find(sv, PERL_MAGIC_collxfrm);
4933 if (mg && mg->mg_ptr) {
4935 return mg->mg_ptr + sizeof(PL_collation_ix);
4943 #endif /* USE_LOCALE_COLLATE */
4948 Get a line from the filehandle and store it into the SV, optionally
4949 appending to the currently-stored string.
4955 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4959 register STDCHAR rslast;
4960 register STDCHAR *bp;
4964 SV_CHECK_THINKFIRST(sv);
4965 (void)SvUPGRADE(sv, SVt_PV);
4969 if (RsSNARF(PL_rs)) {
4973 else if (RsRECORD(PL_rs)) {
4974 I32 recsize, bytesread;
4977 /* Grab the size of the record we're getting */
4978 recsize = SvIV(SvRV(PL_rs));
4979 (void)SvPOK_only(sv); /* Validate pointer */
4980 buffer = SvGROW(sv, recsize + 1);
4983 /* VMS wants read instead of fread, because fread doesn't respect */
4984 /* RMS record boundaries. This is not necessarily a good thing to be */
4985 /* doing, but we've got no other real choice */
4986 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4988 bytesread = PerlIO_read(fp, buffer, recsize);
4990 SvCUR_set(sv, bytesread);
4991 buffer[bytesread] = '\0';
4992 if (PerlIO_isutf8(fp))
4996 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4998 else if (RsPARA(PL_rs)) {
5003 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5004 if (PerlIO_isutf8(fp)) {
5005 rsptr = SvPVutf8(PL_rs, rslen);
5008 if (SvUTF8(PL_rs)) {
5009 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5010 Perl_croak(aTHX_ "Wide character in $/");
5013 rsptr = SvPV(PL_rs, rslen);
5017 rslast = rslen ? rsptr[rslen - 1] : '\0';
5019 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5020 do { /* to make sure file boundaries work right */
5023 i = PerlIO_getc(fp);
5027 PerlIO_ungetc(fp,i);
5033 /* See if we know enough about I/O mechanism to cheat it ! */
5035 /* This used to be #ifdef test - it is made run-time test for ease
5036 of abstracting out stdio interface. One call should be cheap
5037 enough here - and may even be a macro allowing compile
5041 if (PerlIO_fast_gets(fp)) {
5044 * We're going to steal some values from the stdio struct
5045 * and put EVERYTHING in the innermost loop into registers.
5047 register STDCHAR *ptr;
5051 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5052 /* An ungetc()d char is handled separately from the regular
5053 * buffer, so we getc() it back out and stuff it in the buffer.
5055 i = PerlIO_getc(fp);
5056 if (i == EOF) return 0;
5057 *(--((*fp)->_ptr)) = (unsigned char) i;
5061 /* Here is some breathtakingly efficient cheating */
5063 cnt = PerlIO_get_cnt(fp); /* get count into register */
5064 (void)SvPOK_only(sv); /* validate pointer */
5065 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5066 if (cnt > 80 && SvLEN(sv) > append) {
5067 shortbuffered = cnt - SvLEN(sv) + append + 1;
5068 cnt -= shortbuffered;
5072 /* remember that cnt can be negative */
5073 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5078 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5079 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5080 DEBUG_P(PerlIO_printf(Perl_debug_log,
5081 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5082 DEBUG_P(PerlIO_printf(Perl_debug_log,
5083 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5084 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5085 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5090 while (cnt > 0) { /* this | eat */
5092 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5093 goto thats_all_folks; /* screams | sed :-) */
5097 Copy(ptr, bp, cnt, char); /* this | eat */
5098 bp += cnt; /* screams | dust */
5099 ptr += cnt; /* louder | sed :-) */
5104 if (shortbuffered) { /* oh well, must extend */
5105 cnt = shortbuffered;
5107 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5109 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5110 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5114 DEBUG_P(PerlIO_printf(Perl_debug_log,
5115 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5116 PTR2UV(ptr),(long)cnt));
5117 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5118 DEBUG_P(PerlIO_printf(Perl_debug_log,
5119 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5120 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5121 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5122 /* This used to call 'filbuf' in stdio form, but as that behaves like
5123 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5124 another abstraction. */
5125 i = PerlIO_getc(fp); /* get more characters */
5126 DEBUG_P(PerlIO_printf(Perl_debug_log,
5127 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5128 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5129 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5130 cnt = PerlIO_get_cnt(fp);
5131 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5132 DEBUG_P(PerlIO_printf(Perl_debug_log,
5133 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5135 if (i == EOF) /* all done for ever? */
5136 goto thats_really_all_folks;
5138 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5140 SvGROW(sv, bpx + cnt + 2);
5141 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5143 *bp++ = i; /* store character from PerlIO_getc */
5145 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5146 goto thats_all_folks;
5150 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5151 memNE((char*)bp - rslen, rsptr, rslen))
5152 goto screamer; /* go back to the fray */
5153 thats_really_all_folks:
5155 cnt += shortbuffered;
5156 DEBUG_P(PerlIO_printf(Perl_debug_log,
5157 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5158 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5159 DEBUG_P(PerlIO_printf(Perl_debug_log,
5160 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5161 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5162 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5164 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5165 DEBUG_P(PerlIO_printf(Perl_debug_log,
5166 "Screamer: done, len=%ld, string=|%.*s|\n",
5167 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5172 /*The big, slow, and stupid way */
5175 /* Need to work around EPOC SDK features */
5176 /* On WINS: MS VC5 generates calls to _chkstk, */
5177 /* if a `large' stack frame is allocated */
5178 /* gcc on MARM does not generate calls like these */
5184 register STDCHAR *bpe = buf + sizeof(buf);
5186 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5187 ; /* keep reading */
5191 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5192 /* Accomodate broken VAXC compiler, which applies U8 cast to
5193 * both args of ?: operator, causing EOF to change into 255
5195 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5199 sv_catpvn(sv, (char *) buf, cnt);
5201 sv_setpvn(sv, (char *) buf, cnt);
5203 if (i != EOF && /* joy */
5205 SvCUR(sv) < rslen ||
5206 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5210 * If we're reading from a TTY and we get a short read,
5211 * indicating that the user hit his EOF character, we need
5212 * to notice it now, because if we try to read from the TTY
5213 * again, the EOF condition will disappear.
5215 * The comparison of cnt to sizeof(buf) is an optimization
5216 * that prevents unnecessary calls to feof().
5220 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5225 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5226 while (i != EOF) { /* to make sure file boundaries work right */
5227 i = PerlIO_getc(fp);
5229 PerlIO_ungetc(fp,i);
5235 if (PerlIO_isutf8(fp))
5240 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5247 Auto-increment of the value in the SV.
5253 Perl_sv_inc(pTHX_ register SV *sv)
5262 if (SvTHINKFIRST(sv)) {
5263 if (SvREADONLY(sv)) {
5264 if (PL_curcop != &PL_compiling)
5265 Perl_croak(aTHX_ PL_no_modify);
5269 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5271 i = PTR2IV(SvRV(sv));
5276 flags = SvFLAGS(sv);
5277 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5278 /* It's (privately or publicly) a float, but not tested as an
5279 integer, so test it to see. */
5281 flags = SvFLAGS(sv);
5283 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5284 /* It's publicly an integer, or privately an integer-not-float */
5287 if (SvUVX(sv) == UV_MAX)
5288 sv_setnv(sv, (NV)UV_MAX + 1.0);
5290 (void)SvIOK_only_UV(sv);
5293 if (SvIVX(sv) == IV_MAX)
5294 sv_setuv(sv, (UV)IV_MAX + 1);
5296 (void)SvIOK_only(sv);
5302 if (flags & SVp_NOK) {
5303 (void)SvNOK_only(sv);
5308 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5309 if ((flags & SVTYPEMASK) < SVt_PVIV)
5310 sv_upgrade(sv, SVt_IV);
5311 (void)SvIOK_only(sv);
5316 while (isALPHA(*d)) d++;
5317 while (isDIGIT(*d)) d++;
5319 #ifdef PERL_PRESERVE_IVUV
5320 /* Got to punt this an an integer if needs be, but we don't issue
5321 warnings. Probably ought to make the sv_iv_please() that does
5322 the conversion if possible, and silently. */
5323 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5324 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5325 /* Need to try really hard to see if it's an integer.
5326 9.22337203685478e+18 is an integer.
5327 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5328 so $a="9.22337203685478e+18"; $a+0; $a++
5329 needs to be the same as $a="9.22337203685478e+18"; $a++
5336 /* sv_2iv *should* have made this an NV */
5337 if (flags & SVp_NOK) {
5338 (void)SvNOK_only(sv);
5342 /* I don't think we can get here. Maybe I should assert this
5343 And if we do get here I suspect that sv_setnv will croak. NWC
5345 #if defined(USE_LONG_DOUBLE)
5346 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",
5347 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5349 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5350 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5353 #endif /* PERL_PRESERVE_IVUV */
5354 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5358 while (d >= SvPVX(sv)) {
5366 /* MKS: The original code here died if letters weren't consecutive.
5367 * at least it didn't have to worry about non-C locales. The
5368 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5369 * arranged in order (although not consecutively) and that only
5370 * [A-Za-z] are accepted by isALPHA in the C locale.
5372 if (*d != 'z' && *d != 'Z') {
5373 do { ++*d; } while (!isALPHA(*d));
5376 *(d--) -= 'z' - 'a';
5381 *(d--) -= 'z' - 'a' + 1;
5385 /* oh,oh, the number grew */
5386 SvGROW(sv, SvCUR(sv) + 2);
5388 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5399 Auto-decrement of the value in the SV.
5405 Perl_sv_dec(pTHX_ register SV *sv)
5413 if (SvTHINKFIRST(sv)) {
5414 if (SvREADONLY(sv)) {
5415 if (PL_curcop != &PL_compiling)
5416 Perl_croak(aTHX_ PL_no_modify);
5420 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5422 i = PTR2IV(SvRV(sv));
5427 /* Unlike sv_inc we don't have to worry about string-never-numbers
5428 and keeping them magic. But we mustn't warn on punting */
5429 flags = SvFLAGS(sv);
5430 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5431 /* It's publicly an integer, or privately an integer-not-float */
5434 if (SvUVX(sv) == 0) {
5435 (void)SvIOK_only(sv);
5439 (void)SvIOK_only_UV(sv);
5443 if (SvIVX(sv) == IV_MIN)
5444 sv_setnv(sv, (NV)IV_MIN - 1.0);
5446 (void)SvIOK_only(sv);
5452 if (flags & SVp_NOK) {
5454 (void)SvNOK_only(sv);
5457 if (!(flags & SVp_POK)) {
5458 if ((flags & SVTYPEMASK) < SVt_PVNV)
5459 sv_upgrade(sv, SVt_NV);
5461 (void)SvNOK_only(sv);
5464 #ifdef PERL_PRESERVE_IVUV
5466 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5467 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5468 /* Need to try really hard to see if it's an integer.
5469 9.22337203685478e+18 is an integer.
5470 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5471 so $a="9.22337203685478e+18"; $a+0; $a--
5472 needs to be the same as $a="9.22337203685478e+18"; $a--
5479 /* sv_2iv *should* have made this an NV */
5480 if (flags & SVp_NOK) {
5481 (void)SvNOK_only(sv);
5485 /* I don't think we can get here. Maybe I should assert this
5486 And if we do get here I suspect that sv_setnv will croak. NWC
5488 #if defined(USE_LONG_DOUBLE)
5489 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",
5490 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5492 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5493 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5497 #endif /* PERL_PRESERVE_IVUV */
5498 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5502 =for apidoc sv_mortalcopy
5504 Creates a new SV which is a copy of the original SV. The new SV is marked
5510 /* Make a string that will exist for the duration of the expression
5511 * evaluation. Actually, it may have to last longer than that, but
5512 * hopefully we won't free it until it has been assigned to a
5513 * permanent location. */
5516 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5521 sv_setsv(sv,oldstr);
5523 PL_tmps_stack[++PL_tmps_ix] = sv;
5529 =for apidoc sv_newmortal
5531 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5537 Perl_sv_newmortal(pTHX)
5542 SvFLAGS(sv) = SVs_TEMP;
5544 PL_tmps_stack[++PL_tmps_ix] = sv;
5549 =for apidoc sv_2mortal
5551 Marks an SV as mortal. The SV will be destroyed when the current context
5557 /* same thing without the copying */
5560 Perl_sv_2mortal(pTHX_ register SV *sv)
5564 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5567 PL_tmps_stack[++PL_tmps_ix] = sv;
5575 Creates a new SV and copies a string into it. The reference count for the
5576 SV is set to 1. If C<len> is zero, Perl will compute the length using
5577 strlen(). For efficiency, consider using C<newSVpvn> instead.
5583 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5590 sv_setpvn(sv,s,len);
5595 =for apidoc newSVpvn
5597 Creates a new SV and copies a string into it. The reference count for the
5598 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5599 string. You are responsible for ensuring that the source string is at least
5606 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5611 sv_setpvn(sv,s,len);
5616 =for apidoc newSVpvn_share
5618 Creates a new SV and populates it with a string from
5619 the string table. Turns on READONLY and FAKE.
5620 The idea here is that as string table is used for shared hash
5621 keys these strings will have SvPVX == HeKEY and hash lookup
5622 will avoid string compare.
5628 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5631 bool is_utf8 = FALSE;
5636 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5637 STRLEN tmplen = len;
5638 /* See the note in hv.c:hv_fetch() --jhi */
5639 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5643 PERL_HASH(hash, src, len);
5645 sv_upgrade(sv, SVt_PVIV);
5646 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5658 #if defined(PERL_IMPLICIT_CONTEXT)
5660 Perl_newSVpvf_nocontext(const char* pat, ...)
5665 va_start(args, pat);
5666 sv = vnewSVpvf(pat, &args);
5673 =for apidoc newSVpvf
5675 Creates a new SV an initialize it with the string formatted like
5682 Perl_newSVpvf(pTHX_ const char* pat, ...)
5686 va_start(args, pat);
5687 sv = vnewSVpvf(pat, &args);
5693 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5697 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5704 Creates a new SV and copies a floating point value into it.
5705 The reference count for the SV is set to 1.
5711 Perl_newSVnv(pTHX_ NV n)
5723 Creates a new SV and copies an integer into it. The reference count for the
5730 Perl_newSViv(pTHX_ IV i)
5742 Creates a new SV and copies an unsigned integer into it.
5743 The reference count for the SV is set to 1.
5749 Perl_newSVuv(pTHX_ UV u)
5759 =for apidoc newRV_noinc
5761 Creates an RV wrapper for an SV. The reference count for the original
5762 SV is B<not> incremented.
5768 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5773 sv_upgrade(sv, SVt_RV);
5780 /* newRV_inc is #defined to newRV in sv.h */
5782 Perl_newRV(pTHX_ SV *tmpRef)
5784 return newRV_noinc(SvREFCNT_inc(tmpRef));
5790 Creates a new SV which is an exact duplicate of the original SV.
5795 /* make an exact duplicate of old */
5798 Perl_newSVsv(pTHX_ register SV *old)
5804 if (SvTYPE(old) == SVTYPEMASK) {
5805 if (ckWARN_d(WARN_INTERNAL))
5806 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5821 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5829 char todo[PERL_UCHAR_MAX+1];
5834 if (!*s) { /* reset ?? searches */
5835 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5836 pm->op_pmdynflags &= ~PMdf_USED;
5841 /* reset variables */
5843 if (!HvARRAY(stash))
5846 Zero(todo, 256, char);
5848 i = (unsigned char)*s;
5852 max = (unsigned char)*s++;
5853 for ( ; i <= max; i++) {
5856 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5857 for (entry = HvARRAY(stash)[i];
5859 entry = HeNEXT(entry))
5861 if (!todo[(U8)*HeKEY(entry)])
5863 gv = (GV*)HeVAL(entry);
5865 if (SvTHINKFIRST(sv)) {
5866 if (!SvREADONLY(sv) && SvROK(sv))
5871 if (SvTYPE(sv) >= SVt_PV) {
5873 if (SvPVX(sv) != Nullch)
5880 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5882 #ifdef USE_ENVIRON_ARRAY
5884 environ[0] = Nullch;
5893 Perl_sv_2io(pTHX_ SV *sv)
5899 switch (SvTYPE(sv)) {
5907 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5911 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5913 return sv_2io(SvRV(sv));
5914 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5920 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5927 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5934 return *gvp = Nullgv, Nullcv;
5935 switch (SvTYPE(sv)) {
5954 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5955 tryAMAGICunDEREF(to_cv);
5958 if (SvTYPE(sv) == SVt_PVCV) {
5967 Perl_croak(aTHX_ "Not a subroutine reference");
5972 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5978 if (lref && !GvCVu(gv)) {
5981 tmpsv = NEWSV(704,0);
5982 gv_efullname3(tmpsv, gv, Nullch);
5983 /* XXX this is probably not what they think they're getting.
5984 * It has the same effect as "sub name;", i.e. just a forward
5986 newSUB(start_subparse(FALSE, 0),
5987 newSVOP(OP_CONST, 0, tmpsv),
5992 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6001 Returns true if the SV has a true value by Perl's rules.
6007 Perl_sv_true(pTHX_ register SV *sv)
6013 if ((tXpv = (XPV*)SvANY(sv)) &&
6014 (tXpv->xpv_cur > 1 ||
6015 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6022 return SvIVX(sv) != 0;
6025 return SvNVX(sv) != 0.0;
6027 return sv_2bool(sv);
6033 Perl_sv_iv(pTHX_ register SV *sv)
6037 return (IV)SvUVX(sv);
6044 Perl_sv_uv(pTHX_ register SV *sv)
6049 return (UV)SvIVX(sv);
6055 Perl_sv_nv(pTHX_ register SV *sv)
6063 Perl_sv_pv(pTHX_ SV *sv)
6070 return sv_2pv(sv, &n_a);
6074 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6080 return sv_2pv(sv, lp);
6084 =for apidoc sv_pvn_force
6086 Get a sensible string out of the SV somehow.
6092 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6094 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6098 =for apidoc sv_pvn_force_flags
6100 Get a sensible string out of the SV somehow.
6101 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6102 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6103 implemented in terms of this function.
6109 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6113 if (SvTHINKFIRST(sv) && !SvROK(sv))
6114 sv_force_normal(sv);
6120 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6121 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6122 PL_op_name[PL_op->op_type]);
6125 s = sv_2pv_flags(sv, lp, flags);
6126 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6131 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6132 SvGROW(sv, len + 1);
6133 Move(s,SvPVX(sv),len,char);
6138 SvPOK_on(sv); /* validate pointer */
6140 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6141 PTR2UV(sv),SvPVX(sv)));
6148 Perl_sv_pvbyte(pTHX_ SV *sv)
6150 sv_utf8_downgrade(sv,0);
6155 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6157 sv_utf8_downgrade(sv,0);
6158 return sv_pvn(sv,lp);
6162 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6164 sv_utf8_downgrade(sv,0);
6165 return sv_pvn_force(sv,lp);
6169 Perl_sv_pvutf8(pTHX_ SV *sv)
6171 sv_utf8_upgrade(sv);
6176 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6178 sv_utf8_upgrade(sv);
6179 return sv_pvn(sv,lp);
6183 =for apidoc sv_pvutf8n_force
6185 Get a sensible UTF8-encoded string out of the SV somehow. See
6192 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6194 sv_utf8_upgrade(sv);
6195 return sv_pvn_force(sv,lp);
6199 =for apidoc sv_reftype
6201 Returns a string describing what the SV is a reference to.
6207 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6209 if (ob && SvOBJECT(sv))
6210 return HvNAME(SvSTASH(sv));
6212 switch (SvTYPE(sv)) {
6226 case SVt_PVLV: return "LVALUE";
6227 case SVt_PVAV: return "ARRAY";
6228 case SVt_PVHV: return "HASH";
6229 case SVt_PVCV: return "CODE";
6230 case SVt_PVGV: return "GLOB";
6231 case SVt_PVFM: return "FORMAT";
6232 case SVt_PVIO: return "IO";
6233 default: return "UNKNOWN";
6239 =for apidoc sv_isobject
6241 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6242 object. If the SV is not an RV, or if the object is not blessed, then this
6249 Perl_sv_isobject(pTHX_ SV *sv)
6266 Returns a boolean indicating whether the SV is blessed into the specified
6267 class. This does not check for subtypes; use C<sv_derived_from> to verify
6268 an inheritance relationship.
6274 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6286 return strEQ(HvNAME(SvSTASH(sv)), name);
6292 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6293 it will be upgraded to one. If C<classname> is non-null then the new SV will
6294 be blessed in the specified package. The new SV is returned and its
6295 reference count is 1.
6301 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6307 SV_CHECK_THINKFIRST(rv);
6310 if (SvTYPE(rv) >= SVt_PVMG) {
6311 U32 refcnt = SvREFCNT(rv);
6315 SvREFCNT(rv) = refcnt;
6318 if (SvTYPE(rv) < SVt_RV)
6319 sv_upgrade(rv, SVt_RV);
6320 else if (SvTYPE(rv) > SVt_RV) {
6321 (void)SvOOK_off(rv);
6322 if (SvPVX(rv) && SvLEN(rv))
6323 Safefree(SvPVX(rv));
6333 HV* stash = gv_stashpv(classname, TRUE);
6334 (void)sv_bless(rv, stash);
6340 =for apidoc sv_setref_pv
6342 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6343 argument will be upgraded to an RV. That RV will be modified to point to
6344 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6345 into the SV. The C<classname> argument indicates the package for the
6346 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6347 will be returned and will have a reference count of 1.
6349 Do not use with other Perl types such as HV, AV, SV, CV, because those
6350 objects will become corrupted by the pointer copy process.
6352 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6358 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6361 sv_setsv(rv, &PL_sv_undef);
6365 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6370 =for apidoc sv_setref_iv
6372 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6373 argument will be upgraded to an RV. That RV will be modified to point to
6374 the new SV. The C<classname> argument indicates the package for the
6375 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6376 will be returned and will have a reference count of 1.
6382 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6384 sv_setiv(newSVrv(rv,classname), iv);
6389 =for apidoc sv_setref_uv
6391 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6392 argument will be upgraded to an RV. That RV will be modified to point to
6393 the new SV. The C<classname> argument indicates the package for the
6394 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6395 will be returned and will have a reference count of 1.
6401 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6403 sv_setuv(newSVrv(rv,classname), uv);
6408 =for apidoc sv_setref_nv
6410 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6411 argument will be upgraded to an RV. That RV will be modified to point to
6412 the new SV. The C<classname> argument indicates the package for the
6413 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6414 will be returned and will have a reference count of 1.
6420 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6422 sv_setnv(newSVrv(rv,classname), nv);
6427 =for apidoc sv_setref_pvn
6429 Copies a string into a new SV, optionally blessing the SV. The length of the
6430 string must be specified with C<n>. The C<rv> argument will be upgraded to
6431 an RV. That RV will be modified to point to the new SV. The C<classname>
6432 argument indicates the package for the blessing. Set C<classname> to
6433 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6434 a reference count of 1.
6436 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6442 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6444 sv_setpvn(newSVrv(rv,classname), pv, n);
6449 =for apidoc sv_bless
6451 Blesses an SV into a specified package. The SV must be an RV. The package
6452 must be designated by its stash (see C<gv_stashpv()>). The reference count
6453 of the SV is unaffected.
6459 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6463 Perl_croak(aTHX_ "Can't bless non-reference value");
6465 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6466 if (SvREADONLY(tmpRef))
6467 Perl_croak(aTHX_ PL_no_modify);
6468 if (SvOBJECT(tmpRef)) {
6469 if (SvTYPE(tmpRef) != SVt_PVIO)
6471 SvREFCNT_dec(SvSTASH(tmpRef));
6474 SvOBJECT_on(tmpRef);
6475 if (SvTYPE(tmpRef) != SVt_PVIO)
6477 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6478 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6489 S_sv_unglob(pTHX_ SV *sv)
6493 assert(SvTYPE(sv) == SVt_PVGV);
6498 SvREFCNT_dec(GvSTASH(sv));
6499 GvSTASH(sv) = Nullhv;
6501 sv_unmagic(sv, PERL_MAGIC_glob);
6502 Safefree(GvNAME(sv));
6505 /* need to keep SvANY(sv) in the right arena */
6506 xpvmg = new_XPVMG();
6507 StructCopy(SvANY(sv), xpvmg, XPVMG);
6508 del_XPVGV(SvANY(sv));
6511 SvFLAGS(sv) &= ~SVTYPEMASK;
6512 SvFLAGS(sv) |= SVt_PVMG;
6516 =for apidoc sv_unref_flags
6518 Unsets the RV status of the SV, and decrements the reference count of
6519 whatever was being referenced by the RV. This can almost be thought of
6520 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6521 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6522 (otherwise the decrementing is conditional on the reference count being
6523 different from one or the reference being a readonly SV).
6530 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6534 if (SvWEAKREF(sv)) {
6542 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6544 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6545 sv_2mortal(rv); /* Schedule for freeing later */
6549 =for apidoc sv_unref
6551 Unsets the RV status of the SV, and decrements the reference count of
6552 whatever was being referenced by the RV. This can almost be thought of
6553 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6554 being zero. See C<SvROK_off>.
6560 Perl_sv_unref(pTHX_ SV *sv)
6562 sv_unref_flags(sv, 0);
6566 Perl_sv_taint(pTHX_ SV *sv)
6568 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6572 Perl_sv_untaint(pTHX_ SV *sv)
6574 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6575 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6582 Perl_sv_tainted(pTHX_ SV *sv)
6584 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6585 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6586 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6593 =for apidoc sv_setpviv
6595 Copies an integer into the given SV, also updating its string value.
6596 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6602 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6604 char buf[TYPE_CHARS(UV)];
6606 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6608 sv_setpvn(sv, ptr, ebuf - ptr);
6613 =for apidoc sv_setpviv_mg
6615 Like C<sv_setpviv>, but also handles 'set' magic.
6621 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6623 char buf[TYPE_CHARS(UV)];
6625 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6627 sv_setpvn(sv, ptr, ebuf - ptr);
6631 #if defined(PERL_IMPLICIT_CONTEXT)
6633 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6637 va_start(args, pat);
6638 sv_vsetpvf(sv, pat, &args);
6644 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6648 va_start(args, pat);
6649 sv_vsetpvf_mg(sv, pat, &args);
6655 =for apidoc sv_setpvf
6657 Processes its arguments like C<sprintf> and sets an SV to the formatted
6658 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6664 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6667 va_start(args, pat);
6668 sv_vsetpvf(sv, pat, &args);
6673 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6675 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6679 =for apidoc sv_setpvf_mg
6681 Like C<sv_setpvf>, but also handles 'set' magic.
6687 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6690 va_start(args, pat);
6691 sv_vsetpvf_mg(sv, pat, &args);
6696 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6698 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6702 #if defined(PERL_IMPLICIT_CONTEXT)
6704 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6708 va_start(args, pat);
6709 sv_vcatpvf(sv, pat, &args);
6714 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6718 va_start(args, pat);
6719 sv_vcatpvf_mg(sv, pat, &args);
6725 =for apidoc sv_catpvf
6727 Processes its arguments like C<sprintf> and appends the formatted
6728 output to an SV. If the appended data contains "wide" characters
6729 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6730 and characters >255 formatted with %c), the original SV might get
6731 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6732 C<SvSETMAGIC()> must typically be called after calling this function
6733 to handle 'set' magic.
6738 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6741 va_start(args, pat);
6742 sv_vcatpvf(sv, pat, &args);
6747 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6749 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6753 =for apidoc sv_catpvf_mg
6755 Like C<sv_catpvf>, but also handles 'set' magic.
6761 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6764 va_start(args, pat);
6765 sv_vcatpvf_mg(sv, pat, &args);
6770 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6772 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6777 =for apidoc sv_vsetpvfn
6779 Works like C<vcatpvfn> but copies the text into the SV instead of
6786 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6788 sv_setpvn(sv, "", 0);
6789 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6793 S_expect_number(pTHX_ char** pattern)
6796 switch (**pattern) {
6797 case '1': case '2': case '3':
6798 case '4': case '5': case '6':
6799 case '7': case '8': case '9':
6800 while (isDIGIT(**pattern))
6801 var = var * 10 + (*(*pattern)++ - '0');
6805 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6808 =for apidoc sv_vcatpvfn
6810 Processes its arguments like C<vsprintf> and appends the formatted output
6811 to an SV. Uses an array of SVs if the C style variable argument list is
6812 missing (NULL). When running with taint checks enabled, indicates via
6813 C<maybe_tainted> if results are untrustworthy (often due to the use of
6820 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6827 static char nullstr[] = "(null)";
6830 /* no matter what, this is a string now */
6831 (void)SvPV_force(sv, origlen);
6833 /* special-case "", "%s", and "%_" */
6836 if (patlen == 2 && pat[0] == '%') {
6840 char *s = va_arg(*args, char*);
6841 sv_catpv(sv, s ? s : nullstr);
6843 else if (svix < svmax) {
6844 sv_catsv(sv, *svargs);
6845 if (DO_UTF8(*svargs))
6851 argsv = va_arg(*args, SV*);
6852 sv_catsv(sv, argsv);
6857 /* See comment on '_' below */
6862 patend = (char*)pat + patlen;
6863 for (p = (char*)pat; p < patend; p = q) {
6866 bool vectorize = FALSE;
6867 bool vectorarg = FALSE;
6868 bool vec_utf = FALSE;
6874 bool has_precis = FALSE;
6876 bool is_utf = FALSE;
6879 U8 utf8buf[UTF8_MAXLEN+1];
6880 STRLEN esignlen = 0;
6882 char *eptr = Nullch;
6884 /* Times 4: a decimal digit takes more than 3 binary digits.
6885 * NV_DIG: mantissa takes than many decimal digits.
6886 * Plus 32: Playing safe. */
6887 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6888 /* large enough for "%#.#f" --chip */
6889 /* what about long double NVs? --jhi */
6892 U8 *vecstr = Null(U8*);
6904 STRLEN dotstrlen = 1;
6905 I32 efix = 0; /* explicit format parameter index */
6906 I32 ewix = 0; /* explicit width index */
6907 I32 epix = 0; /* explicit precision index */
6908 I32 evix = 0; /* explicit vector index */
6909 bool asterisk = FALSE;
6911 /* echo everything up to the next format specification */
6912 for (q = p; q < patend && *q != '%'; ++q) ;
6914 sv_catpvn(sv, p, q - p);
6921 We allow format specification elements in this order:
6922 \d+\$ explicit format parameter index
6924 \*?(\d+\$)?v vector with optional (optionally specified) arg
6925 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6926 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6928 [%bcdefginopsux_DFOUX] format (mandatory)
6930 if (EXPECT_NUMBER(q, width)) {
6971 if (EXPECT_NUMBER(q, ewix))
6980 if ((vectorarg = asterisk)) {
6990 EXPECT_NUMBER(q, width);
6995 vecsv = va_arg(*args, SV*);
6997 vecsv = (evix ? evix <= svmax : svix < svmax) ?
6998 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
6999 dotstr = SvPVx(vecsv, dotstrlen);
7004 vecsv = va_arg(*args, SV*);
7005 vecstr = (U8*)SvPVx(vecsv,veclen);
7006 vec_utf = DO_UTF8(vecsv);
7008 else if (efix ? efix <= svmax : svix < svmax) {
7009 vecsv = svargs[efix ? efix-1 : svix++];
7010 vecstr = (U8*)SvPVx(vecsv,veclen);
7011 vec_utf = DO_UTF8(vecsv);
7021 i = va_arg(*args, int);
7023 i = (ewix ? ewix <= svmax : svix < svmax) ?
7024 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7026 width = (i < 0) ? -i : i;
7036 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7039 i = va_arg(*args, int);
7041 i = (ewix ? ewix <= svmax : svix < svmax)
7042 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7043 precis = (i < 0) ? 0 : i;
7048 precis = precis * 10 + (*q++ - '0');
7056 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7067 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7068 if (*(q + 1) == 'l') { /* lld, llf */
7091 argsv = (efix ? efix <= svmax : svix < svmax) ?
7092 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7099 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7101 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7103 eptr = (char*)utf8buf;
7104 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7116 eptr = va_arg(*args, char*);
7118 #ifdef MACOS_TRADITIONAL
7119 /* On MacOS, %#s format is used for Pascal strings */
7124 elen = strlen(eptr);
7127 elen = sizeof nullstr - 1;
7131 eptr = SvPVx(argsv, elen);
7132 if (DO_UTF8(argsv)) {
7133 if (has_precis && precis < elen) {
7135 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7138 if (width) { /* fudge width (can't fudge elen) */
7139 width += elen - sv_len_utf8(argsv);
7148 * The "%_" hack might have to be changed someday,
7149 * if ISO or ANSI decide to use '_' for something.
7150 * So we keep it hidden from users' code.
7154 argsv = va_arg(*args, SV*);
7155 eptr = SvPVx(argsv, elen);
7161 if (has_precis && elen > precis)
7170 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7188 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7198 case 'h': iv = (short)va_arg(*args, int); break;
7199 default: iv = va_arg(*args, int); break;
7200 case 'l': iv = va_arg(*args, long); break;
7201 case 'V': iv = va_arg(*args, IV); break;
7203 case 'q': iv = va_arg(*args, Quad_t); break;
7210 case 'h': iv = (short)iv; break;
7212 case 'l': iv = (long)iv; break;
7215 case 'q': iv = (Quad_t)iv; break;
7222 esignbuf[esignlen++] = plus;
7226 esignbuf[esignlen++] = '-';
7268 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7278 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7279 default: uv = va_arg(*args, unsigned); break;
7280 case 'l': uv = va_arg(*args, unsigned long); break;
7281 case 'V': uv = va_arg(*args, UV); break;
7283 case 'q': uv = va_arg(*args, Quad_t); break;
7290 case 'h': uv = (unsigned short)uv; break;
7292 case 'l': uv = (unsigned long)uv; break;
7295 case 'q': uv = (Quad_t)uv; break;
7301 eptr = ebuf + sizeof ebuf;
7307 p = (char*)((c == 'X')
7308 ? "0123456789ABCDEF" : "0123456789abcdef");
7314 esignbuf[esignlen++] = '0';
7315 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7321 *--eptr = '0' + dig;
7323 if (alt && *eptr != '0')
7329 *--eptr = '0' + dig;
7332 esignbuf[esignlen++] = '0';
7333 esignbuf[esignlen++] = 'b';
7336 default: /* it had better be ten or less */
7337 #if defined(PERL_Y2KWARN)
7338 if (ckWARN(WARN_Y2K)) {
7340 char *s = SvPV(sv,n);
7341 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7342 && (n == 2 || !isDIGIT(s[n-3])))
7344 Perl_warner(aTHX_ WARN_Y2K,
7345 "Possible Y2K bug: %%%c %s",
7346 c, "format string following '19'");
7352 *--eptr = '0' + dig;
7353 } while (uv /= base);
7356 elen = (ebuf + sizeof ebuf) - eptr;
7359 zeros = precis - elen;
7360 else if (precis == 0 && elen == 1 && *eptr == '0')
7365 /* FLOATING POINT */
7368 c = 'f'; /* maybe %F isn't supported here */
7374 /* This is evil, but floating point is even more evil */
7377 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7380 if (c != 'e' && c != 'E') {
7382 (void)Perl_frexp(nv, &i);
7383 if (i == PERL_INT_MIN)
7384 Perl_die(aTHX_ "panic: frexp");
7386 need = BIT_DIGITS(i);
7388 need += has_precis ? precis : 6; /* known default */
7392 need += 20; /* fudge factor */
7393 if (PL_efloatsize < need) {
7394 Safefree(PL_efloatbuf);
7395 PL_efloatsize = need + 20; /* more fudge */
7396 New(906, PL_efloatbuf, PL_efloatsize, char);
7397 PL_efloatbuf[0] = '\0';
7400 eptr = ebuf + sizeof ebuf;
7403 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7405 /* Copy the one or more characters in a long double
7406 * format before the 'base' ([efgEFG]) character to
7407 * the format string. */
7408 static char const prifldbl[] = PERL_PRIfldbl;
7409 char const *p = prifldbl + sizeof(prifldbl) - 3;
7410 while (p >= prifldbl) { *--eptr = *p--; }
7415 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7420 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7432 /* No taint. Otherwise we are in the strange situation
7433 * where printf() taints but print($float) doesn't.
7435 (void)sprintf(PL_efloatbuf, eptr, nv);
7437 eptr = PL_efloatbuf;
7438 elen = strlen(PL_efloatbuf);
7445 i = SvCUR(sv) - origlen;
7448 case 'h': *(va_arg(*args, short*)) = i; break;
7449 default: *(va_arg(*args, int*)) = i; break;
7450 case 'l': *(va_arg(*args, long*)) = i; break;
7451 case 'V': *(va_arg(*args, IV*)) = i; break;
7453 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7458 sv_setuv_mg(argsv, (UV)i);
7459 continue; /* not "break" */
7466 if (!args && ckWARN(WARN_PRINTF) &&
7467 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7468 SV *msg = sv_newmortal();
7469 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7470 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7473 Perl_sv_catpvf(aTHX_ msg,
7474 "\"%%%c\"", c & 0xFF);
7476 Perl_sv_catpvf(aTHX_ msg,
7477 "\"%%\\%03"UVof"\"",
7480 sv_catpv(msg, "end of string");
7481 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7484 /* output mangled stuff ... */
7490 /* ... right here, because formatting flags should not apply */
7491 SvGROW(sv, SvCUR(sv) + elen + 1);
7493 Copy(eptr, p, elen, char);
7496 SvCUR(sv) = p - SvPVX(sv);
7497 continue; /* not "break" */
7500 have = esignlen + zeros + elen;
7501 need = (have > width ? have : width);
7504 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7506 if (esignlen && fill == '0') {
7507 for (i = 0; i < esignlen; i++)
7511 memset(p, fill, gap);
7514 if (esignlen && fill != '0') {
7515 for (i = 0; i < esignlen; i++)
7519 for (i = zeros; i; i--)
7523 Copy(eptr, p, elen, char);
7527 memset(p, ' ', gap);
7532 Copy(dotstr, p, dotstrlen, char);
7536 vectorize = FALSE; /* done iterating over vecstr */
7541 SvCUR(sv) = p - SvPVX(sv);
7549 #if defined(USE_ITHREADS)
7551 #if defined(USE_THREADS)
7552 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7555 #ifndef GpREFCNT_inc
7556 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7560 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7561 #define av_dup(s) (AV*)sv_dup((SV*)s)
7562 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7563 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7564 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7565 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7566 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7567 #define io_dup(s) (IO*)sv_dup((SV*)s)
7568 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7569 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7570 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7571 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7572 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7575 Perl_re_dup(pTHX_ REGEXP *r)
7577 /* XXX fix when pmop->op_pmregexp becomes shared */
7578 return ReREFCNT_inc(r);
7582 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7586 return (PerlIO*)NULL;
7588 /* look for it in the table first */
7589 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7593 /* create anew and remember what it is */
7594 ret = PerlIO_fdupopen(aTHX_ fp);
7595 ptr_table_store(PL_ptr_table, fp, ret);
7600 Perl_dirp_dup(pTHX_ DIR *dp)
7609 Perl_gp_dup(pTHX_ GP *gp)
7614 /* look for it in the table first */
7615 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7619 /* create anew and remember what it is */
7620 Newz(0, ret, 1, GP);
7621 ptr_table_store(PL_ptr_table, gp, ret);
7624 ret->gp_refcnt = 0; /* must be before any other dups! */
7625 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7626 ret->gp_io = io_dup_inc(gp->gp_io);
7627 ret->gp_form = cv_dup_inc(gp->gp_form);
7628 ret->gp_av = av_dup_inc(gp->gp_av);
7629 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7630 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7631 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7632 ret->gp_cvgen = gp->gp_cvgen;
7633 ret->gp_flags = gp->gp_flags;
7634 ret->gp_line = gp->gp_line;
7635 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7640 Perl_mg_dup(pTHX_ MAGIC *mg)
7642 MAGIC *mgprev = (MAGIC*)NULL;
7645 return (MAGIC*)NULL;
7646 /* look for it in the table first */
7647 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7651 for (; mg; mg = mg->mg_moremagic) {
7653 Newz(0, nmg, 1, MAGIC);
7655 mgprev->mg_moremagic = nmg;
7658 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7659 nmg->mg_private = mg->mg_private;
7660 nmg->mg_type = mg->mg_type;
7661 nmg->mg_flags = mg->mg_flags;
7662 if (mg->mg_type == PERL_MAGIC_qr) {
7663 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7666 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7667 ? sv_dup_inc(mg->mg_obj)
7668 : sv_dup(mg->mg_obj);
7670 nmg->mg_len = mg->mg_len;
7671 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7672 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7673 if (mg->mg_len >= 0) {
7674 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7675 if (mg->mg_type == PERL_MAGIC_overload_table &&
7676 AMT_AMAGIC((AMT*)mg->mg_ptr))
7678 AMT *amtp = (AMT*)mg->mg_ptr;
7679 AMT *namtp = (AMT*)nmg->mg_ptr;
7681 for (i = 1; i < NofAMmeth; i++) {
7682 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7686 else if (mg->mg_len == HEf_SVKEY)
7687 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7695 Perl_ptr_table_new(pTHX)
7698 Newz(0, tbl, 1, PTR_TBL_t);
7701 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7706 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7708 PTR_TBL_ENT_t *tblent;
7709 UV hash = PTR2UV(sv);
7711 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7712 for (; tblent; tblent = tblent->next) {
7713 if (tblent->oldval == sv)
7714 return tblent->newval;
7720 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7722 PTR_TBL_ENT_t *tblent, **otblent;
7723 /* XXX this may be pessimal on platforms where pointers aren't good
7724 * hash values e.g. if they grow faster in the most significant
7726 UV hash = PTR2UV(oldv);
7730 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7731 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7732 if (tblent->oldval == oldv) {
7733 tblent->newval = newv;
7738 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7739 tblent->oldval = oldv;
7740 tblent->newval = newv;
7741 tblent->next = *otblent;
7744 if (i && tbl->tbl_items > tbl->tbl_max)
7745 ptr_table_split(tbl);
7749 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7751 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7752 UV oldsize = tbl->tbl_max + 1;
7753 UV newsize = oldsize * 2;
7756 Renew(ary, newsize, PTR_TBL_ENT_t*);
7757 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7758 tbl->tbl_max = --newsize;
7760 for (i=0; i < oldsize; i++, ary++) {
7761 PTR_TBL_ENT_t **curentp, **entp, *ent;
7764 curentp = ary + oldsize;
7765 for (entp = ary, ent = *ary; ent; ent = *entp) {
7766 if ((newsize & PTR2UV(ent->oldval)) != i) {
7768 ent->next = *curentp;
7779 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7781 register PTR_TBL_ENT_t **array;
7782 register PTR_TBL_ENT_t *entry;
7783 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7787 if (!tbl || !tbl->tbl_items) {
7791 array = tbl->tbl_ary;
7798 entry = entry->next;
7802 if (++riter > max) {
7805 entry = array[riter];
7813 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7818 ptr_table_clear(tbl);
7819 Safefree(tbl->tbl_ary);
7828 S_gv_share(pTHX_ SV *sstr)
7831 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7833 if (GvIO(gv) || GvFORM(gv)) {
7834 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7836 else if (!GvCV(gv)) {
7840 /* CvPADLISTs cannot be shared */
7841 if (!CvXSUB(GvCV(gv))) {
7846 if (!GvSHARED(gv)) {
7848 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7849 HvNAME(GvSTASH(gv)), GvNAME(gv));
7855 * write attempts will die with
7856 * "Modification of a read-only value attempted"
7862 SvREADONLY_on(GvSV(gv));
7869 SvREADONLY_on(GvAV(gv));
7876 SvREADONLY_on(GvAV(gv));
7879 return sstr; /* he_dup() will SvREFCNT_inc() */
7883 Perl_sv_dup(pTHX_ SV *sstr)
7887 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7889 /* look for it in the table first */
7890 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7894 /* create anew and remember what it is */
7896 ptr_table_store(PL_ptr_table, sstr, dstr);
7899 SvFLAGS(dstr) = SvFLAGS(sstr);
7900 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7901 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7904 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7905 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7906 PL_watch_pvx, SvPVX(sstr));
7909 switch (SvTYPE(sstr)) {
7914 SvANY(dstr) = new_XIV();
7915 SvIVX(dstr) = SvIVX(sstr);
7918 SvANY(dstr) = new_XNV();
7919 SvNVX(dstr) = SvNVX(sstr);
7922 SvANY(dstr) = new_XRV();
7923 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
7924 ? sv_dup(SvRV(sstr))
7925 : sv_dup_inc(SvRV(sstr));
7928 SvANY(dstr) = new_XPV();
7929 SvCUR(dstr) = SvCUR(sstr);
7930 SvLEN(dstr) = SvLEN(sstr);
7932 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7933 ? sv_dup(SvRV(sstr))
7934 : sv_dup_inc(SvRV(sstr));
7935 else if (SvPVX(sstr) && SvLEN(sstr))
7936 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7938 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7941 SvANY(dstr) = new_XPVIV();
7942 SvCUR(dstr) = SvCUR(sstr);
7943 SvLEN(dstr) = SvLEN(sstr);
7944 SvIVX(dstr) = SvIVX(sstr);
7946 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7947 ? sv_dup(SvRV(sstr))
7948 : sv_dup_inc(SvRV(sstr));
7949 else if (SvPVX(sstr) && SvLEN(sstr))
7950 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7952 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7955 SvANY(dstr) = new_XPVNV();
7956 SvCUR(dstr) = SvCUR(sstr);
7957 SvLEN(dstr) = SvLEN(sstr);
7958 SvIVX(dstr) = SvIVX(sstr);
7959 SvNVX(dstr) = SvNVX(sstr);
7961 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7962 ? sv_dup(SvRV(sstr))
7963 : sv_dup_inc(SvRV(sstr));
7964 else if (SvPVX(sstr) && SvLEN(sstr))
7965 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7967 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7970 SvANY(dstr) = new_XPVMG();
7971 SvCUR(dstr) = SvCUR(sstr);
7972 SvLEN(dstr) = SvLEN(sstr);
7973 SvIVX(dstr) = SvIVX(sstr);
7974 SvNVX(dstr) = SvNVX(sstr);
7975 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7976 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7978 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7979 ? sv_dup(SvRV(sstr))
7980 : sv_dup_inc(SvRV(sstr));
7981 else if (SvPVX(sstr) && SvLEN(sstr))
7982 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7984 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7987 SvANY(dstr) = new_XPVBM();
7988 SvCUR(dstr) = SvCUR(sstr);
7989 SvLEN(dstr) = SvLEN(sstr);
7990 SvIVX(dstr) = SvIVX(sstr);
7991 SvNVX(dstr) = SvNVX(sstr);
7992 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7993 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7995 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
7996 ? sv_dup(SvRV(sstr))
7997 : sv_dup_inc(SvRV(sstr));
7998 else if (SvPVX(sstr) && SvLEN(sstr))
7999 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8001 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8002 BmRARE(dstr) = BmRARE(sstr);
8003 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8004 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8007 SvANY(dstr) = new_XPVLV();
8008 SvCUR(dstr) = SvCUR(sstr);
8009 SvLEN(dstr) = SvLEN(sstr);
8010 SvIVX(dstr) = SvIVX(sstr);
8011 SvNVX(dstr) = SvNVX(sstr);
8012 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8013 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8015 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8016 ? sv_dup(SvRV(sstr))
8017 : sv_dup_inc(SvRV(sstr));
8018 else if (SvPVX(sstr) && SvLEN(sstr))
8019 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8021 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8022 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8023 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8024 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8025 LvTYPE(dstr) = LvTYPE(sstr);
8028 if (GvSHARED((GV*)sstr)) {
8030 if ((share = gv_share(sstr))) {
8034 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8035 HvNAME(GvSTASH(share)), GvNAME(share));
8040 SvANY(dstr) = new_XPVGV();
8041 SvCUR(dstr) = SvCUR(sstr);
8042 SvLEN(dstr) = SvLEN(sstr);
8043 SvIVX(dstr) = SvIVX(sstr);
8044 SvNVX(dstr) = SvNVX(sstr);
8045 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8046 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8048 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8049 ? sv_dup(SvRV(sstr))
8050 : sv_dup_inc(SvRV(sstr));
8051 else if (SvPVX(sstr) && SvLEN(sstr))
8052 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8054 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8055 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8056 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8057 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8058 GvFLAGS(dstr) = GvFLAGS(sstr);
8059 GvGP(dstr) = gp_dup(GvGP(sstr));
8060 (void)GpREFCNT_inc(GvGP(dstr));
8063 SvANY(dstr) = new_XPVIO();
8064 SvCUR(dstr) = SvCUR(sstr);
8065 SvLEN(dstr) = SvLEN(sstr);
8066 SvIVX(dstr) = SvIVX(sstr);
8067 SvNVX(dstr) = SvNVX(sstr);
8068 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8069 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8071 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8072 ? sv_dup(SvRV(sstr))
8073 : sv_dup_inc(SvRV(sstr));
8074 else if (SvPVX(sstr) && SvLEN(sstr))
8075 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8077 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8078 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8079 if (IoOFP(sstr) == IoIFP(sstr))
8080 IoOFP(dstr) = IoIFP(dstr);
8082 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8083 /* PL_rsfp_filters entries have fake IoDIRP() */
8084 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8085 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8087 IoDIRP(dstr) = IoDIRP(sstr);
8088 IoLINES(dstr) = IoLINES(sstr);
8089 IoPAGE(dstr) = IoPAGE(sstr);
8090 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8091 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8092 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8093 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8094 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8095 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8096 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8097 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8098 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8099 IoTYPE(dstr) = IoTYPE(sstr);
8100 IoFLAGS(dstr) = IoFLAGS(sstr);
8103 SvANY(dstr) = new_XPVAV();
8104 SvCUR(dstr) = SvCUR(sstr);
8105 SvLEN(dstr) = SvLEN(sstr);
8106 SvIVX(dstr) = SvIVX(sstr);
8107 SvNVX(dstr) = SvNVX(sstr);
8108 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8109 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8110 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8111 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8112 if (AvARRAY((AV*)sstr)) {
8113 SV **dst_ary, **src_ary;
8114 SSize_t items = AvFILLp((AV*)sstr) + 1;
8116 src_ary = AvARRAY((AV*)sstr);
8117 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8118 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8119 SvPVX(dstr) = (char*)dst_ary;
8120 AvALLOC((AV*)dstr) = dst_ary;
8121 if (AvREAL((AV*)sstr)) {
8123 *dst_ary++ = sv_dup_inc(*src_ary++);
8127 *dst_ary++ = sv_dup(*src_ary++);
8129 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8130 while (items-- > 0) {
8131 *dst_ary++ = &PL_sv_undef;
8135 SvPVX(dstr) = Nullch;
8136 AvALLOC((AV*)dstr) = (SV**)NULL;
8140 SvANY(dstr) = new_XPVHV();
8141 SvCUR(dstr) = SvCUR(sstr);
8142 SvLEN(dstr) = SvLEN(sstr);
8143 SvIVX(dstr) = SvIVX(sstr);
8144 SvNVX(dstr) = SvNVX(sstr);
8145 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8146 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8147 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8148 if (HvARRAY((HV*)sstr)) {
8150 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8151 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8152 Newz(0, dxhv->xhv_array,
8153 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8154 while (i <= sxhv->xhv_max) {
8155 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8156 !!HvSHAREKEYS(sstr));
8159 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8162 SvPVX(dstr) = Nullch;
8163 HvEITER((HV*)dstr) = (HE*)NULL;
8165 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8166 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8167 if(HvNAME((HV*)dstr))
8168 av_push(PL_clone_callbacks, dstr);
8171 SvANY(dstr) = new_XPVFM();
8172 FmLINES(dstr) = FmLINES(sstr);
8176 SvANY(dstr) = new_XPVCV();
8178 SvCUR(dstr) = SvCUR(sstr);
8179 SvLEN(dstr) = SvLEN(sstr);
8180 SvIVX(dstr) = SvIVX(sstr);
8181 SvNVX(dstr) = SvNVX(sstr);
8182 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8183 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8184 if (SvPVX(sstr) && SvLEN(sstr))
8185 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8187 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8188 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8189 CvSTART(dstr) = CvSTART(sstr);
8190 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8191 CvXSUB(dstr) = CvXSUB(sstr);
8192 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8193 CvGV(dstr) = gv_dup(CvGV(sstr));
8194 CvDEPTH(dstr) = CvDEPTH(sstr);
8195 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8196 /* XXX padlists are real, but pretend to be not */
8197 AvREAL_on(CvPADLIST(sstr));
8198 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8199 AvREAL_off(CvPADLIST(sstr));
8200 AvREAL_off(CvPADLIST(dstr));
8203 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8204 if (!CvANON(sstr) || CvCLONED(sstr))
8205 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8207 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8208 CvFLAGS(dstr) = CvFLAGS(sstr);
8211 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8215 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8222 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8227 return (PERL_CONTEXT*)NULL;
8229 /* look for it in the table first */
8230 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8234 /* create anew and remember what it is */
8235 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8236 ptr_table_store(PL_ptr_table, cxs, ncxs);
8239 PERL_CONTEXT *cx = &cxs[ix];
8240 PERL_CONTEXT *ncx = &ncxs[ix];
8241 ncx->cx_type = cx->cx_type;
8242 if (CxTYPE(cx) == CXt_SUBST) {
8243 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8246 ncx->blk_oldsp = cx->blk_oldsp;
8247 ncx->blk_oldcop = cx->blk_oldcop;
8248 ncx->blk_oldretsp = cx->blk_oldretsp;
8249 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8250 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8251 ncx->blk_oldpm = cx->blk_oldpm;
8252 ncx->blk_gimme = cx->blk_gimme;
8253 switch (CxTYPE(cx)) {
8255 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8256 ? cv_dup_inc(cx->blk_sub.cv)
8257 : cv_dup(cx->blk_sub.cv));
8258 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8259 ? av_dup_inc(cx->blk_sub.argarray)
8261 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8262 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8263 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8264 ncx->blk_sub.lval = cx->blk_sub.lval;
8267 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8268 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8269 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8270 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8271 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8274 ncx->blk_loop.label = cx->blk_loop.label;
8275 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8276 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8277 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8278 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8279 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8280 ? cx->blk_loop.iterdata
8281 : gv_dup((GV*)cx->blk_loop.iterdata));
8282 ncx->blk_loop.oldcurpad
8283 = (SV**)ptr_table_fetch(PL_ptr_table,
8284 cx->blk_loop.oldcurpad);
8285 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8286 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8287 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8288 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8289 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8292 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8293 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8294 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8295 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8308 Perl_si_dup(pTHX_ PERL_SI *si)
8313 return (PERL_SI*)NULL;
8315 /* look for it in the table first */
8316 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8320 /* create anew and remember what it is */
8321 Newz(56, nsi, 1, PERL_SI);
8322 ptr_table_store(PL_ptr_table, si, nsi);
8324 nsi->si_stack = av_dup_inc(si->si_stack);
8325 nsi->si_cxix = si->si_cxix;
8326 nsi->si_cxmax = si->si_cxmax;
8327 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8328 nsi->si_type = si->si_type;
8329 nsi->si_prev = si_dup(si->si_prev);
8330 nsi->si_next = si_dup(si->si_next);
8331 nsi->si_markoff = si->si_markoff;
8336 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8337 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8338 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8339 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8340 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8341 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8342 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8343 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8344 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8345 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8346 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8347 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8350 #define pv_dup_inc(p) SAVEPV(p)
8351 #define pv_dup(p) SAVEPV(p)
8352 #define svp_dup_inc(p,pp) any_dup(p,pp)
8355 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8362 /* look for it in the table first */
8363 ret = ptr_table_fetch(PL_ptr_table, v);
8367 /* see if it is part of the interpreter structure */
8368 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8369 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8377 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8379 ANY *ss = proto_perl->Tsavestack;
8380 I32 ix = proto_perl->Tsavestack_ix;
8381 I32 max = proto_perl->Tsavestack_max;
8394 void (*dptr) (void*);
8395 void (*dxptr) (pTHXo_ void*);
8398 Newz(54, nss, max, ANY);
8404 case SAVEt_ITEM: /* normal string */
8405 sv = (SV*)POPPTR(ss,ix);
8406 TOPPTR(nss,ix) = sv_dup_inc(sv);
8407 sv = (SV*)POPPTR(ss,ix);
8408 TOPPTR(nss,ix) = sv_dup_inc(sv);
8410 case SAVEt_SV: /* scalar reference */
8411 sv = (SV*)POPPTR(ss,ix);
8412 TOPPTR(nss,ix) = sv_dup_inc(sv);
8413 gv = (GV*)POPPTR(ss,ix);
8414 TOPPTR(nss,ix) = gv_dup_inc(gv);
8416 case SAVEt_GENERIC_PVREF: /* generic char* */
8417 c = (char*)POPPTR(ss,ix);
8418 TOPPTR(nss,ix) = pv_dup(c);
8419 ptr = POPPTR(ss,ix);
8420 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8422 case SAVEt_GENERIC_SVREF: /* generic sv */
8423 case SAVEt_SVREF: /* scalar reference */
8424 sv = (SV*)POPPTR(ss,ix);
8425 TOPPTR(nss,ix) = sv_dup_inc(sv);
8426 ptr = POPPTR(ss,ix);
8427 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8429 case SAVEt_AV: /* array reference */
8430 av = (AV*)POPPTR(ss,ix);
8431 TOPPTR(nss,ix) = av_dup_inc(av);
8432 gv = (GV*)POPPTR(ss,ix);
8433 TOPPTR(nss,ix) = gv_dup(gv);
8435 case SAVEt_HV: /* hash reference */
8436 hv = (HV*)POPPTR(ss,ix);
8437 TOPPTR(nss,ix) = hv_dup_inc(hv);
8438 gv = (GV*)POPPTR(ss,ix);
8439 TOPPTR(nss,ix) = gv_dup(gv);
8441 case SAVEt_INT: /* int reference */
8442 ptr = POPPTR(ss,ix);
8443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8444 intval = (int)POPINT(ss,ix);
8445 TOPINT(nss,ix) = intval;
8447 case SAVEt_LONG: /* long reference */
8448 ptr = POPPTR(ss,ix);
8449 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8450 longval = (long)POPLONG(ss,ix);
8451 TOPLONG(nss,ix) = longval;
8453 case SAVEt_I32: /* I32 reference */
8454 case SAVEt_I16: /* I16 reference */
8455 case SAVEt_I8: /* I8 reference */
8456 ptr = POPPTR(ss,ix);
8457 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8461 case SAVEt_IV: /* IV reference */
8462 ptr = POPPTR(ss,ix);
8463 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8467 case SAVEt_SPTR: /* SV* reference */
8468 ptr = POPPTR(ss,ix);
8469 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8470 sv = (SV*)POPPTR(ss,ix);
8471 TOPPTR(nss,ix) = sv_dup(sv);
8473 case SAVEt_VPTR: /* random* reference */
8474 ptr = POPPTR(ss,ix);
8475 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8476 ptr = POPPTR(ss,ix);
8477 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8479 case SAVEt_PPTR: /* char* reference */
8480 ptr = POPPTR(ss,ix);
8481 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8482 c = (char*)POPPTR(ss,ix);
8483 TOPPTR(nss,ix) = pv_dup(c);
8485 case SAVEt_HPTR: /* HV* reference */
8486 ptr = POPPTR(ss,ix);
8487 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8488 hv = (HV*)POPPTR(ss,ix);
8489 TOPPTR(nss,ix) = hv_dup(hv);
8491 case SAVEt_APTR: /* AV* reference */
8492 ptr = POPPTR(ss,ix);
8493 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8494 av = (AV*)POPPTR(ss,ix);
8495 TOPPTR(nss,ix) = av_dup(av);
8498 gv = (GV*)POPPTR(ss,ix);
8499 TOPPTR(nss,ix) = gv_dup(gv);
8501 case SAVEt_GP: /* scalar reference */
8502 gp = (GP*)POPPTR(ss,ix);
8503 TOPPTR(nss,ix) = gp = gp_dup(gp);
8504 (void)GpREFCNT_inc(gp);
8505 gv = (GV*)POPPTR(ss,ix);
8506 TOPPTR(nss,ix) = gv_dup_inc(c);
8507 c = (char*)POPPTR(ss,ix);
8508 TOPPTR(nss,ix) = pv_dup(c);
8515 case SAVEt_MORTALIZESV:
8516 sv = (SV*)POPPTR(ss,ix);
8517 TOPPTR(nss,ix) = sv_dup_inc(sv);
8520 ptr = POPPTR(ss,ix);
8521 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8522 /* these are assumed to be refcounted properly */
8523 switch (((OP*)ptr)->op_type) {
8530 TOPPTR(nss,ix) = ptr;
8535 TOPPTR(nss,ix) = Nullop;
8540 TOPPTR(nss,ix) = Nullop;
8543 c = (char*)POPPTR(ss,ix);
8544 TOPPTR(nss,ix) = pv_dup_inc(c);
8547 longval = POPLONG(ss,ix);
8548 TOPLONG(nss,ix) = longval;
8551 hv = (HV*)POPPTR(ss,ix);
8552 TOPPTR(nss,ix) = hv_dup_inc(hv);
8553 c = (char*)POPPTR(ss,ix);
8554 TOPPTR(nss,ix) = pv_dup_inc(c);
8558 case SAVEt_DESTRUCTOR:
8559 ptr = POPPTR(ss,ix);
8560 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8561 dptr = POPDPTR(ss,ix);
8562 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8564 case SAVEt_DESTRUCTOR_X:
8565 ptr = POPPTR(ss,ix);
8566 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8567 dxptr = POPDXPTR(ss,ix);
8568 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8570 case SAVEt_REGCONTEXT:
8576 case SAVEt_STACK_POS: /* Position on Perl stack */
8580 case SAVEt_AELEM: /* array element */
8581 sv = (SV*)POPPTR(ss,ix);
8582 TOPPTR(nss,ix) = sv_dup_inc(sv);
8585 av = (AV*)POPPTR(ss,ix);
8586 TOPPTR(nss,ix) = av_dup_inc(av);
8588 case SAVEt_HELEM: /* hash element */
8589 sv = (SV*)POPPTR(ss,ix);
8590 TOPPTR(nss,ix) = sv_dup_inc(sv);
8591 sv = (SV*)POPPTR(ss,ix);
8592 TOPPTR(nss,ix) = sv_dup_inc(sv);
8593 hv = (HV*)POPPTR(ss,ix);
8594 TOPPTR(nss,ix) = hv_dup_inc(hv);
8597 ptr = POPPTR(ss,ix);
8598 TOPPTR(nss,ix) = ptr;
8605 av = (AV*)POPPTR(ss,ix);
8606 TOPPTR(nss,ix) = av_dup(av);
8609 longval = (long)POPLONG(ss,ix);
8610 TOPLONG(nss,ix) = longval;
8611 ptr = POPPTR(ss,ix);
8612 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8613 sv = (SV*)POPPTR(ss,ix);
8614 TOPPTR(nss,ix) = sv_dup(sv);
8617 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8629 perl_clone(PerlInterpreter *proto_perl, UV flags)
8632 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8635 #ifdef PERL_IMPLICIT_SYS
8636 return perl_clone_using(proto_perl, flags,
8638 proto_perl->IMemShared,
8639 proto_perl->IMemParse,
8649 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8650 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8651 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8652 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8653 struct IPerlDir* ipD, struct IPerlSock* ipS,
8654 struct IPerlProc* ipP)
8656 /* XXX many of the string copies here can be optimized if they're
8657 * constants; they need to be allocated as common memory and just
8658 * their pointers copied. */
8662 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8664 PERL_SET_THX(pPerl);
8665 # else /* !PERL_OBJECT */
8666 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8667 PERL_SET_THX(my_perl);
8670 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8676 # else /* !DEBUGGING */
8677 Zero(my_perl, 1, PerlInterpreter);
8678 # endif /* DEBUGGING */
8682 PL_MemShared = ipMS;
8690 # endif /* PERL_OBJECT */
8691 #else /* !PERL_IMPLICIT_SYS */
8693 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8694 PERL_SET_THX(my_perl);
8697 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8703 # else /* !DEBUGGING */
8704 Zero(my_perl, 1, PerlInterpreter);
8705 # endif /* DEBUGGING */
8706 #endif /* PERL_IMPLICIT_SYS */
8709 PL_xiv_arenaroot = NULL;
8711 PL_xnv_arenaroot = NULL;
8713 PL_xrv_arenaroot = NULL;
8715 PL_xpv_arenaroot = NULL;
8717 PL_xpviv_arenaroot = NULL;
8718 PL_xpviv_root = NULL;
8719 PL_xpvnv_arenaroot = NULL;
8720 PL_xpvnv_root = NULL;
8721 PL_xpvcv_arenaroot = NULL;
8722 PL_xpvcv_root = NULL;
8723 PL_xpvav_arenaroot = NULL;
8724 PL_xpvav_root = NULL;
8725 PL_xpvhv_arenaroot = NULL;
8726 PL_xpvhv_root = NULL;
8727 PL_xpvmg_arenaroot = NULL;
8728 PL_xpvmg_root = NULL;
8729 PL_xpvlv_arenaroot = NULL;
8730 PL_xpvlv_root = NULL;
8731 PL_xpvbm_arenaroot = NULL;
8732 PL_xpvbm_root = NULL;
8733 PL_he_arenaroot = NULL;
8735 PL_nice_chunk = NULL;
8736 PL_nice_chunk_size = 0;
8739 PL_sv_root = Nullsv;
8740 PL_sv_arenaroot = Nullsv;
8742 PL_debug = proto_perl->Idebug;
8744 /* create SV map for pointer relocation */
8745 PL_ptr_table = ptr_table_new();
8747 /* initialize these special pointers as early as possible */
8748 SvANY(&PL_sv_undef) = NULL;
8749 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8750 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8751 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8754 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8756 SvANY(&PL_sv_no) = new_XPVNV();
8758 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8759 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8760 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8761 SvCUR(&PL_sv_no) = 0;
8762 SvLEN(&PL_sv_no) = 1;
8763 SvNVX(&PL_sv_no) = 0;
8764 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8767 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8769 SvANY(&PL_sv_yes) = new_XPVNV();
8771 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8772 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8773 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8774 SvCUR(&PL_sv_yes) = 1;
8775 SvLEN(&PL_sv_yes) = 2;
8776 SvNVX(&PL_sv_yes) = 1;
8777 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8779 /* create shared string table */
8780 PL_strtab = newHV();
8781 HvSHAREKEYS_off(PL_strtab);
8782 hv_ksplit(PL_strtab, 512);
8783 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8785 PL_compiling = proto_perl->Icompiling;
8786 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8787 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8788 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8789 if (!specialWARN(PL_compiling.cop_warnings))
8790 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8791 if (!specialCopIO(PL_compiling.cop_io))
8792 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8793 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8795 /* pseudo environmental stuff */
8796 PL_origargc = proto_perl->Iorigargc;
8798 New(0, PL_origargv, i+1, char*);
8799 PL_origargv[i] = '\0';
8801 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8803 PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */
8804 PL_envgv = gv_dup(proto_perl->Ienvgv);
8805 PL_incgv = gv_dup(proto_perl->Iincgv);
8806 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8807 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8808 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8809 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8812 PL_minus_c = proto_perl->Iminus_c;
8813 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8814 PL_localpatches = proto_perl->Ilocalpatches;
8815 PL_splitstr = proto_perl->Isplitstr;
8816 PL_preprocess = proto_perl->Ipreprocess;
8817 PL_minus_n = proto_perl->Iminus_n;
8818 PL_minus_p = proto_perl->Iminus_p;
8819 PL_minus_l = proto_perl->Iminus_l;
8820 PL_minus_a = proto_perl->Iminus_a;
8821 PL_minus_F = proto_perl->Iminus_F;
8822 PL_doswitches = proto_perl->Idoswitches;
8823 PL_dowarn = proto_perl->Idowarn;
8824 PL_doextract = proto_perl->Idoextract;
8825 PL_sawampersand = proto_perl->Isawampersand;
8826 PL_unsafe = proto_perl->Iunsafe;
8827 PL_inplace = SAVEPV(proto_perl->Iinplace);
8828 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8829 PL_perldb = proto_perl->Iperldb;
8830 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8832 /* magical thingies */
8833 /* XXX time(&PL_basetime) when asked for? */
8834 PL_basetime = proto_perl->Ibasetime;
8835 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8837 PL_maxsysfd = proto_perl->Imaxsysfd;
8838 PL_multiline = proto_perl->Imultiline;
8839 PL_statusvalue = proto_perl->Istatusvalue;
8841 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8844 /* shortcuts to various I/O objects */
8845 PL_stdingv = gv_dup(proto_perl->Istdingv);
8846 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8847 PL_defgv = gv_dup(proto_perl->Idefgv);
8848 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8849 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8850 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8852 /* shortcuts to regexp stuff */
8853 PL_replgv = gv_dup(proto_perl->Ireplgv);
8855 /* shortcuts to misc objects */
8856 PL_errgv = gv_dup(proto_perl->Ierrgv);
8858 /* shortcuts to debugging objects */
8859 PL_DBgv = gv_dup(proto_perl->IDBgv);
8860 PL_DBline = gv_dup(proto_perl->IDBline);
8861 PL_DBsub = gv_dup(proto_perl->IDBsub);
8862 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8863 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8864 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8865 PL_lineary = av_dup(proto_perl->Ilineary);
8866 PL_dbargs = av_dup(proto_perl->Idbargs);
8869 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8870 PL_curstash = hv_dup(proto_perl->Tcurstash);
8871 PL_debstash = hv_dup(proto_perl->Idebstash);
8872 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8873 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8875 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8876 PL_endav = av_dup_inc(proto_perl->Iendav);
8877 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8878 PL_initav = av_dup_inc(proto_perl->Iinitav);
8880 PL_sub_generation = proto_perl->Isub_generation;
8882 /* funky return mechanisms */
8883 PL_forkprocess = proto_perl->Iforkprocess;
8885 /* subprocess state */
8886 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8888 /* internal state */
8889 PL_tainting = proto_perl->Itainting;
8890 PL_maxo = proto_perl->Imaxo;
8891 if (proto_perl->Iop_mask)
8892 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8894 PL_op_mask = Nullch;
8896 /* current interpreter roots */
8897 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8898 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8899 PL_main_start = proto_perl->Imain_start;
8900 PL_eval_root = proto_perl->Ieval_root;
8901 PL_eval_start = proto_perl->Ieval_start;
8903 /* runtime control stuff */
8904 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8905 PL_copline = proto_perl->Icopline;
8907 PL_filemode = proto_perl->Ifilemode;
8908 PL_lastfd = proto_perl->Ilastfd;
8909 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8912 PL_gensym = proto_perl->Igensym;
8913 PL_preambled = proto_perl->Ipreambled;
8914 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8915 PL_laststatval = proto_perl->Ilaststatval;
8916 PL_laststype = proto_perl->Ilaststype;
8917 PL_mess_sv = Nullsv;
8919 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8920 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8922 /* interpreter atexit processing */
8923 PL_exitlistlen = proto_perl->Iexitlistlen;
8924 if (PL_exitlistlen) {
8925 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8926 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8929 PL_exitlist = (PerlExitListEntry*)NULL;
8930 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8932 PL_profiledata = NULL;
8933 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8934 /* PL_rsfp_filters entries have fake IoDIRP() */
8935 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8937 PL_compcv = cv_dup(proto_perl->Icompcv);
8938 PL_comppad = av_dup(proto_perl->Icomppad);
8939 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8940 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8941 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8942 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8943 proto_perl->Tcurpad);
8945 #ifdef HAVE_INTERP_INTERN
8946 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8949 /* more statics moved here */
8950 PL_generation = proto_perl->Igeneration;
8951 PL_DBcv = cv_dup(proto_perl->IDBcv);
8953 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8954 PL_in_clean_all = proto_perl->Iin_clean_all;
8956 PL_uid = proto_perl->Iuid;
8957 PL_euid = proto_perl->Ieuid;
8958 PL_gid = proto_perl->Igid;
8959 PL_egid = proto_perl->Iegid;
8960 PL_nomemok = proto_perl->Inomemok;
8961 PL_an = proto_perl->Ian;
8962 PL_cop_seqmax = proto_perl->Icop_seqmax;
8963 PL_op_seqmax = proto_perl->Iop_seqmax;
8964 PL_evalseq = proto_perl->Ievalseq;
8965 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8966 PL_origalen = proto_perl->Iorigalen;
8967 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8968 PL_osname = SAVEPV(proto_perl->Iosname);
8969 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8970 PL_sighandlerp = proto_perl->Isighandlerp;
8973 PL_runops = proto_perl->Irunops;
8975 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8978 PL_cshlen = proto_perl->Icshlen;
8979 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8982 PL_lex_state = proto_perl->Ilex_state;
8983 PL_lex_defer = proto_perl->Ilex_defer;
8984 PL_lex_expect = proto_perl->Ilex_expect;
8985 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8986 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8987 PL_lex_starts = proto_perl->Ilex_starts;
8988 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8989 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8990 PL_lex_op = proto_perl->Ilex_op;
8991 PL_lex_inpat = proto_perl->Ilex_inpat;
8992 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8993 PL_lex_brackets = proto_perl->Ilex_brackets;
8994 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8995 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8996 PL_lex_casemods = proto_perl->Ilex_casemods;
8997 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8998 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9000 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9001 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9002 PL_nexttoke = proto_perl->Inexttoke;
9004 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9005 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9006 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9007 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9008 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9009 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9010 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9011 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9012 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9013 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9014 PL_pending_ident = proto_perl->Ipending_ident;
9015 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9017 PL_expect = proto_perl->Iexpect;
9019 PL_multi_start = proto_perl->Imulti_start;
9020 PL_multi_end = proto_perl->Imulti_end;
9021 PL_multi_open = proto_perl->Imulti_open;
9022 PL_multi_close = proto_perl->Imulti_close;
9024 PL_error_count = proto_perl->Ierror_count;
9025 PL_subline = proto_perl->Isubline;
9026 PL_subname = sv_dup_inc(proto_perl->Isubname);
9028 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9029 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9030 PL_padix = proto_perl->Ipadix;
9031 PL_padix_floor = proto_perl->Ipadix_floor;
9032 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9034 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9035 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9036 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9037 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9038 PL_last_lop_op = proto_perl->Ilast_lop_op;
9039 PL_in_my = proto_perl->Iin_my;
9040 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9042 PL_cryptseen = proto_perl->Icryptseen;
9045 PL_hints = proto_perl->Ihints;
9047 PL_amagic_generation = proto_perl->Iamagic_generation;
9049 #ifdef USE_LOCALE_COLLATE
9050 PL_collation_ix = proto_perl->Icollation_ix;
9051 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9052 PL_collation_standard = proto_perl->Icollation_standard;
9053 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9054 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9055 #endif /* USE_LOCALE_COLLATE */
9057 #ifdef USE_LOCALE_NUMERIC
9058 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9059 PL_numeric_standard = proto_perl->Inumeric_standard;
9060 PL_numeric_local = proto_perl->Inumeric_local;
9061 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9062 #endif /* !USE_LOCALE_NUMERIC */
9064 /* utf8 character classes */
9065 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9066 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9067 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9068 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9069 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9070 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9071 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9072 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9073 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9074 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9075 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9076 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9077 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9078 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9079 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9080 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9081 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9084 PL_last_swash_hv = Nullhv; /* reinits on demand */
9085 PL_last_swash_klen = 0;
9086 PL_last_swash_key[0]= '\0';
9087 PL_last_swash_tmps = (U8*)NULL;
9088 PL_last_swash_slen = 0;
9090 /* perly.c globals */
9091 PL_yydebug = proto_perl->Iyydebug;
9092 PL_yynerrs = proto_perl->Iyynerrs;
9093 PL_yyerrflag = proto_perl->Iyyerrflag;
9094 PL_yychar = proto_perl->Iyychar;
9095 PL_yyval = proto_perl->Iyyval;
9096 PL_yylval = proto_perl->Iyylval;
9098 PL_glob_index = proto_perl->Iglob_index;
9099 PL_srand_called = proto_perl->Isrand_called;
9100 PL_uudmap['M'] = 0; /* reinits on demand */
9101 PL_bitcount = Nullch; /* reinits on demand */
9103 if (proto_perl->Ipsig_pend) {
9104 Newz(0, PL_psig_pend, SIG_SIZE, int);
9107 PL_psig_pend = (int*)NULL;
9110 if (proto_perl->Ipsig_ptr) {
9111 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9112 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9113 for (i = 1; i < SIG_SIZE; i++) {
9114 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9115 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9119 PL_psig_ptr = (SV**)NULL;
9120 PL_psig_name = (SV**)NULL;
9123 /* thrdvar.h stuff */
9125 if (flags & CLONEf_COPY_STACKS) {
9126 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9127 PL_tmps_ix = proto_perl->Ttmps_ix;
9128 PL_tmps_max = proto_perl->Ttmps_max;
9129 PL_tmps_floor = proto_perl->Ttmps_floor;
9130 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9132 while (i <= PL_tmps_ix) {
9133 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9137 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9138 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9139 Newz(54, PL_markstack, i, I32);
9140 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9141 - proto_perl->Tmarkstack);
9142 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9143 - proto_perl->Tmarkstack);
9144 Copy(proto_perl->Tmarkstack, PL_markstack,
9145 PL_markstack_ptr - PL_markstack + 1, I32);
9147 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9148 * NOTE: unlike the others! */
9149 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9150 PL_scopestack_max = proto_perl->Tscopestack_max;
9151 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9152 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9154 /* next push_return() sets PL_retstack[PL_retstack_ix]
9155 * NOTE: unlike the others! */
9156 PL_retstack_ix = proto_perl->Tretstack_ix;
9157 PL_retstack_max = proto_perl->Tretstack_max;
9158 Newz(54, PL_retstack, PL_retstack_max, OP*);
9159 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9161 /* NOTE: si_dup() looks at PL_markstack */
9162 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9164 /* PL_curstack = PL_curstackinfo->si_stack; */
9165 PL_curstack = av_dup(proto_perl->Tcurstack);
9166 PL_mainstack = av_dup(proto_perl->Tmainstack);
9168 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9169 PL_stack_base = AvARRAY(PL_curstack);
9170 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9171 - proto_perl->Tstack_base);
9172 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9174 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9175 * NOTE: unlike the others! */
9176 PL_savestack_ix = proto_perl->Tsavestack_ix;
9177 PL_savestack_max = proto_perl->Tsavestack_max;
9178 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9179 PL_savestack = ss_dup(proto_perl);
9183 ENTER; /* perl_destruct() wants to LEAVE; */
9186 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9187 PL_top_env = &PL_start_env;
9189 PL_op = proto_perl->Top;
9192 PL_Xpv = (XPV*)NULL;
9193 PL_na = proto_perl->Tna;
9195 PL_statbuf = proto_perl->Tstatbuf;
9196 PL_statcache = proto_perl->Tstatcache;
9197 PL_statgv = gv_dup(proto_perl->Tstatgv);
9198 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9200 PL_timesbuf = proto_perl->Ttimesbuf;
9203 PL_tainted = proto_perl->Ttainted;
9204 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9205 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9206 PL_rs = sv_dup_inc(proto_perl->Trs);
9207 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9208 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9209 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9210 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9211 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9212 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9213 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9215 PL_restartop = proto_perl->Trestartop;
9216 PL_in_eval = proto_perl->Tin_eval;
9217 PL_delaymagic = proto_perl->Tdelaymagic;
9218 PL_dirty = proto_perl->Tdirty;
9219 PL_localizing = proto_perl->Tlocalizing;
9221 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9222 PL_protect = proto_perl->Tprotect;
9224 PL_errors = sv_dup_inc(proto_perl->Terrors);
9225 PL_av_fetch_sv = Nullsv;
9226 PL_hv_fetch_sv = Nullsv;
9227 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9228 PL_modcount = proto_perl->Tmodcount;
9229 PL_lastgotoprobe = Nullop;
9230 PL_dumpindent = proto_perl->Tdumpindent;
9232 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9233 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9234 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9235 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9236 PL_sortcxix = proto_perl->Tsortcxix;
9237 PL_efloatbuf = Nullch; /* reinits on demand */
9238 PL_efloatsize = 0; /* reinits on demand */
9242 PL_screamfirst = NULL;
9243 PL_screamnext = NULL;
9244 PL_maxscream = -1; /* reinits on demand */
9245 PL_lastscream = Nullsv;
9247 PL_watchaddr = NULL;
9248 PL_watchok = Nullch;
9250 PL_regdummy = proto_perl->Tregdummy;
9251 PL_regcomp_parse = Nullch;
9252 PL_regxend = Nullch;
9253 PL_regcode = (regnode*)NULL;
9256 PL_regprecomp = Nullch;
9261 PL_seen_zerolen = 0;
9263 PL_regcomp_rx = (regexp*)NULL;
9265 PL_colorset = 0; /* reinits PL_colors[] */
9266 /*PL_colors[6] = {0,0,0,0,0,0};*/
9267 PL_reg_whilem_seen = 0;
9268 PL_reginput = Nullch;
9271 PL_regstartp = (I32*)NULL;
9272 PL_regendp = (I32*)NULL;
9273 PL_reglastparen = (U32*)NULL;
9274 PL_regtill = Nullch;
9275 PL_reg_start_tmp = (char**)NULL;
9276 PL_reg_start_tmpl = 0;
9277 PL_regdata = (struct reg_data*)NULL;
9280 PL_reg_eval_set = 0;
9282 PL_regprogram = (regnode*)NULL;
9284 PL_regcc = (CURCUR*)NULL;
9285 PL_reg_call_cc = (struct re_cc_state*)NULL;
9286 PL_reg_re = (regexp*)NULL;
9287 PL_reg_ganch = Nullch;
9289 PL_reg_magic = (MAGIC*)NULL;
9291 PL_reg_oldcurpm = (PMOP*)NULL;
9292 PL_reg_curpm = (PMOP*)NULL;
9293 PL_reg_oldsaved = Nullch;
9294 PL_reg_oldsavedlen = 0;
9296 PL_reg_leftiter = 0;
9297 PL_reg_poscache = Nullch;
9298 PL_reg_poscache_size= 0;
9300 /* RE engine - function pointers */
9301 PL_regcompp = proto_perl->Tregcompp;
9302 PL_regexecp = proto_perl->Tregexecp;
9303 PL_regint_start = proto_perl->Tregint_start;
9304 PL_regint_string = proto_perl->Tregint_string;
9305 PL_regfree = proto_perl->Tregfree;
9307 PL_reginterp_cnt = 0;
9308 PL_reg_starttry = 0;
9310 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9311 ptr_table_free(PL_ptr_table);
9312 PL_ptr_table = NULL;
9315 while(av_len(PL_clone_callbacks) != -1) {
9316 HV* stash = (HV*) av_shift(PL_clone_callbacks);
9317 CV* cloner = (CV*) gv_fetchmethod_autoload(stash,"CLONE",0);
9320 cloner = GvCV(cloner);
9324 XPUSHs(newSVpv(HvNAME(stash),0));
9326 call_sv((SV*)cloner, G_DISCARD);
9334 return (PerlInterpreter*)pPerl;
9340 #else /* !USE_ITHREADS */
9346 #endif /* USE_ITHREADS */
9349 do_report_used(pTHXo_ SV *sv)
9351 if (SvTYPE(sv) != SVTYPEMASK) {
9352 PerlIO_printf(Perl_debug_log, "****\n");
9358 do_clean_objs(pTHXo_ SV *sv)
9362 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9363 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9364 if (SvWEAKREF(sv)) {
9375 /* XXX Might want to check arrays, etc. */
9378 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9380 do_clean_named_objs(pTHXo_ SV *sv)
9382 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9383 if ( SvOBJECT(GvSV(sv)) ||
9384 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9385 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9386 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9387 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9389 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9397 do_clean_all(pTHXo_ SV *sv)
9399 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9400 SvFLAGS(sv) |= SVf_BREAK;