3 * Copyright (c) 1991-2000, 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); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
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;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1329 =for apidoc sv_setuv_mg
1331 Like C<sv_setuv>, but also handles 'set' magic.
1337 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1344 =for apidoc sv_setnv
1346 Copies a double into the given SV. Does not handle 'set' magic. See
1353 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1355 SV_CHECK_THINKFIRST(sv);
1356 switch (SvTYPE(sv)) {
1359 sv_upgrade(sv, SVt_NV);
1364 sv_upgrade(sv, SVt_PVNV);
1373 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1374 PL_op_name[PL_op->op_type]);
1377 (void)SvNOK_only(sv); /* validate number */
1382 =for apidoc sv_setnv_mg
1384 Like C<sv_setnv>, but also handles 'set' magic.
1390 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1397 S_not_a_number(pTHX_ SV *sv)
1402 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1403 /* each *s can expand to 4 chars + "...\0",
1404 i.e. need room for 8 chars */
1406 for (s = SvPVX(sv); *s && d < limit; s++) {
1408 if (ch & 128 && !isPRINT_LC(ch)) {
1417 else if (ch == '\r') {
1421 else if (ch == '\f') {
1425 else if (ch == '\\') {
1429 else if (isPRINT_LC(ch))
1444 Perl_warner(aTHX_ WARN_NUMERIC,
1445 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1446 PL_op_desc[PL_op->op_type]);
1448 Perl_warner(aTHX_ WARN_NUMERIC,
1449 "Argument \"%s\" isn't numeric", tmpbuf);
1452 /* the number can be converted to integer with atol() or atoll() */
1453 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1454 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1455 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1456 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1457 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1459 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1460 until proven guilty, assume that things are not that bad... */
1463 Perl_sv_2iv(pTHX_ register SV *sv)
1467 if (SvGMAGICAL(sv)) {
1472 return I_V(SvNVX(sv));
1474 if (SvPOKp(sv) && SvLEN(sv))
1477 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1478 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1484 if (SvTHINKFIRST(sv)) {
1487 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1488 (SvRV(tmpstr) != SvRV(sv)))
1489 return SvIV(tmpstr);
1490 return PTR2IV(SvRV(sv));
1492 if (SvREADONLY(sv) && SvFAKE(sv)) {
1493 sv_force_normal(sv);
1495 if (SvREADONLY(sv) && !SvOK(sv)) {
1496 if (ckWARN(WARN_UNINITIALIZED))
1503 return (IV)(SvUVX(sv));
1510 /* We can cache the IV/UV value even if it not good enough
1511 * to reconstruct NV, since the conversion to PV will prefer
1515 if (SvTYPE(sv) == SVt_NV)
1516 sv_upgrade(sv, SVt_PVNV);
1519 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1520 SvIVX(sv) = I_V(SvNVX(sv));
1522 SvUVX(sv) = U_V(SvNVX(sv));
1525 DEBUG_c(PerlIO_printf(Perl_debug_log,
1526 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1530 return (IV)SvUVX(sv);
1533 else if (SvPOKp(sv) && SvLEN(sv)) {
1534 I32 numtype = looks_like_number(sv);
1536 /* We want to avoid a possible problem when we cache an IV which
1537 may be later translated to an NV, and the resulting NV is not
1538 the translation of the initial data.
1540 This means that if we cache such an IV, we need to cache the
1541 NV as well. Moreover, we trade speed for space, and do not
1542 cache the NV if not needed.
1544 if (numtype & IS_NUMBER_NOT_IV) {
1545 /* May be not an integer. Need to cache NV if we cache IV
1546 * - otherwise future conversion to NV will be wrong. */
1549 d = Atof(SvPVX(sv));
1551 if (SvTYPE(sv) < SVt_PVNV)
1552 sv_upgrade(sv, SVt_PVNV);
1556 #if defined(USE_LONG_DOUBLE)
1557 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1558 PTR2UV(sv), SvNVX(sv)));
1560 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1561 PTR2UV(sv), SvNVX(sv)));
1563 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1564 SvIVX(sv) = I_V(SvNVX(sv));
1566 SvUVX(sv) = U_V(SvNVX(sv));
1571 else { /* The NV may be reconstructed from IV - safe to cache IV,
1572 which may be calculated by atol(). */
1573 if (SvTYPE(sv) < SVt_PVIV)
1574 sv_upgrade(sv, SVt_PVIV);
1576 SvIVX(sv) = Atol(SvPVX(sv));
1577 if (! numtype && ckWARN(WARN_NUMERIC))
1582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1584 if (SvTYPE(sv) < SVt_IV)
1585 /* Typically the caller expects that sv_any is not NULL now. */
1586 sv_upgrade(sv, SVt_IV);
1589 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1590 PTR2UV(sv),SvIVX(sv)));
1591 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1595 Perl_sv_2uv(pTHX_ register SV *sv)
1599 if (SvGMAGICAL(sv)) {
1604 return U_V(SvNVX(sv));
1605 if (SvPOKp(sv) && SvLEN(sv))
1608 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1609 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1615 if (SvTHINKFIRST(sv)) {
1618 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1619 (SvRV(tmpstr) != SvRV(sv)))
1620 return SvUV(tmpstr);
1621 return PTR2UV(SvRV(sv));
1623 if (SvREADONLY(sv) && !SvOK(sv)) {
1624 if (ckWARN(WARN_UNINITIALIZED))
1634 return (UV)SvIVX(sv);
1638 /* We can cache the IV/UV value even if it not good enough
1639 * to reconstruct NV, since the conversion to PV will prefer
1642 if (SvTYPE(sv) == SVt_NV)
1643 sv_upgrade(sv, SVt_PVNV);
1645 if (SvNVX(sv) >= -0.5) {
1647 SvUVX(sv) = U_V(SvNVX(sv));
1650 SvIVX(sv) = I_V(SvNVX(sv));
1652 DEBUG_c(PerlIO_printf(Perl_debug_log,
1653 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1656 (IV)(UV)SvIVX(sv)));
1657 return (UV)SvIVX(sv);
1660 else if (SvPOKp(sv) && SvLEN(sv)) {
1661 I32 numtype = looks_like_number(sv);
1663 /* We want to avoid a possible problem when we cache a UV which
1664 may be later translated to an NV, and the resulting NV is not
1665 the translation of the initial data.
1667 This means that if we cache such a UV, we need to cache the
1668 NV as well. Moreover, we trade speed for space, and do not
1669 cache the NV if not needed.
1671 if (numtype & IS_NUMBER_NOT_IV) {
1672 /* May be not an integer. Need to cache NV if we cache IV
1673 * - otherwise future conversion to NV will be wrong. */
1676 d = Atof(SvPVX(sv));
1678 if (SvTYPE(sv) < SVt_PVNV)
1679 sv_upgrade(sv, SVt_PVNV);
1683 #if defined(USE_LONG_DOUBLE)
1684 DEBUG_c(PerlIO_printf(Perl_debug_log,
1685 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1686 PTR2UV(sv), SvNVX(sv)));
1688 DEBUG_c(PerlIO_printf(Perl_debug_log,
1689 "0x%"UVxf" 2nv(%g)\n",
1690 PTR2UV(sv), SvNVX(sv)));
1692 if (SvNVX(sv) < -0.5) {
1693 SvIVX(sv) = I_V(SvNVX(sv));
1696 SvUVX(sv) = U_V(SvNVX(sv));
1700 else if (numtype & IS_NUMBER_NEG) {
1701 /* The NV may be reconstructed from IV - safe to cache IV,
1702 which may be calculated by atol(). */
1703 if (SvTYPE(sv) == SVt_PV)
1704 sv_upgrade(sv, SVt_PVIV);
1706 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1708 else if (numtype) { /* Non-negative */
1709 /* The NV may be reconstructed from UV - safe to cache UV,
1710 which may be calculated by strtoul()/atol. */
1711 if (SvTYPE(sv) == SVt_PV)
1712 sv_upgrade(sv, SVt_PVIV);
1714 (void)SvIsUV_on(sv);
1716 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1717 #else /* no atou(), but we know the number fits into IV... */
1718 /* The only problem may be if it is negative... */
1719 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1722 else { /* Not a number. Cache 0. */
1723 if (SvTYPE(sv) < SVt_PVIV)
1724 sv_upgrade(sv, SVt_PVIV);
1726 (void)SvIsUV_on(sv);
1727 SvUVX(sv) = 0; /* We assume that 0s have the
1728 same bitmap in IV and UV. */
1729 if (ckWARN(WARN_NUMERIC))
1734 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1738 if (SvTYPE(sv) < SVt_IV)
1739 /* Typically the caller expects that sv_any is not NULL now. */
1740 sv_upgrade(sv, SVt_IV);
1744 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1745 PTR2UV(sv),SvUVX(sv)));
1746 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1750 Perl_sv_2nv(pTHX_ register SV *sv)
1754 if (SvGMAGICAL(sv)) {
1758 if (SvPOKp(sv) && SvLEN(sv)) {
1759 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1761 return Atof(SvPVX(sv));
1765 return (NV)SvUVX(sv);
1767 return (NV)SvIVX(sv);
1770 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1771 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1777 if (SvTHINKFIRST(sv)) {
1780 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1781 (SvRV(tmpstr) != SvRV(sv)))
1782 return SvNV(tmpstr);
1783 return PTR2NV(SvRV(sv));
1785 if (SvREADONLY(sv) && !SvOK(sv)) {
1786 if (ckWARN(WARN_UNINITIALIZED))
1791 if (SvTYPE(sv) < SVt_NV) {
1792 if (SvTYPE(sv) == SVt_IV)
1793 sv_upgrade(sv, SVt_PVNV);
1795 sv_upgrade(sv, SVt_NV);
1796 #if defined(USE_LONG_DOUBLE)
1798 STORE_NUMERIC_LOCAL_SET_STANDARD();
1799 PerlIO_printf(Perl_debug_log,
1800 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1801 PTR2UV(sv), SvNVX(sv));
1802 RESTORE_NUMERIC_LOCAL();
1806 STORE_NUMERIC_LOCAL_SET_STANDARD();
1807 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1808 PTR2UV(sv), SvNVX(sv));
1809 RESTORE_NUMERIC_LOCAL();
1813 else if (SvTYPE(sv) < SVt_PVNV)
1814 sv_upgrade(sv, SVt_PVNV);
1816 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1818 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1820 else if (SvPOKp(sv) && SvLEN(sv)) {
1821 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1823 SvNVX(sv) = Atof(SvPVX(sv));
1826 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1828 if (SvTYPE(sv) < SVt_NV)
1829 /* Typically the caller expects that sv_any is not NULL now. */
1830 sv_upgrade(sv, SVt_NV);
1834 #if defined(USE_LONG_DOUBLE)
1836 STORE_NUMERIC_LOCAL_SET_STANDARD();
1837 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1838 PTR2UV(sv), SvNVX(sv));
1839 RESTORE_NUMERIC_LOCAL();
1843 STORE_NUMERIC_LOCAL_SET_STANDARD();
1844 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1845 PTR2UV(sv), SvNVX(sv));
1846 RESTORE_NUMERIC_LOCAL();
1853 S_asIV(pTHX_ SV *sv)
1855 I32 numtype = looks_like_number(sv);
1858 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1859 return Atol(SvPVX(sv));
1861 if (ckWARN(WARN_NUMERIC))
1864 d = Atof(SvPVX(sv));
1869 S_asUV(pTHX_ SV *sv)
1871 I32 numtype = looks_like_number(sv);
1874 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1875 return Strtoul(SvPVX(sv), Null(char**), 10);
1878 if (ckWARN(WARN_NUMERIC))
1881 return U_V(Atof(SvPVX(sv)));
1885 * Returns a combination of (advisory only - can get false negatives)
1886 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1888 * 0 if does not look like number.
1890 * In fact possible values are 0 and
1891 * IS_NUMBER_TO_INT_BY_ATOL 123
1892 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1893 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1894 * IS_NUMBER_INFINITY
1895 * with a possible addition of IS_NUMBER_NEG.
1899 =for apidoc looks_like_number
1901 Test if an the content of an SV looks like a number (or is a
1908 Perl_looks_like_number(pTHX_ SV *sv)
1911 register char *send;
1912 register char *sbegin;
1913 register char *nbegin;
1922 else if (SvPOKp(sv))
1923 sbegin = SvPV(sv, len);
1926 send = sbegin + len;
1933 numtype = IS_NUMBER_NEG;
1940 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1941 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1945 /* next must be digit or the radix separator or beginning of infinity */
1949 } while (isDIGIT(*s));
1951 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1952 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1954 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1957 #ifdef USE_LOCALE_NUMERIC
1958 || IS_NUMERIC_RADIX(*s)
1962 numtype |= IS_NUMBER_NOT_IV;
1963 while (isDIGIT(*s)) /* optional digits after the radix */
1968 #ifdef USE_LOCALE_NUMERIC
1969 || IS_NUMERIC_RADIX(*s)
1973 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1974 /* no digits before the radix means we need digits after it */
1978 } while (isDIGIT(*s));
1983 else if (*s == 'I' || *s == 'i') {
1984 s++; if (*s != 'N' && *s != 'n') return 0;
1985 s++; if (*s != 'F' && *s != 'f') return 0;
1986 s++; if (*s == 'I' || *s == 'i') {
1987 s++; if (*s != 'N' && *s != 'n') return 0;
1988 s++; if (*s != 'I' && *s != 'i') return 0;
1989 s++; if (*s != 'T' && *s != 't') return 0;
1990 s++; if (*s != 'Y' && *s != 'y') return 0;
1999 numtype = IS_NUMBER_INFINITY;
2001 /* we can have an optional exponent part */
2002 if (*s == 'e' || *s == 'E') {
2003 numtype &= ~IS_NUMBER_NEG;
2004 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2006 if (*s == '+' || *s == '-')
2011 } while (isDIGIT(*s));
2021 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2022 return IS_NUMBER_TO_INT_BY_ATOL;
2027 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2030 return sv_2pv(sv, &n_a);
2033 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2035 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2037 char *ptr = buf + TYPE_CHARS(UV);
2051 *--ptr = '0' + (uv % 10);
2060 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2065 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2066 char *tmpbuf = tbuf;
2072 if (SvGMAGICAL(sv)) {
2080 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2082 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2087 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2092 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2093 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2100 if (SvTHINKFIRST(sv)) {
2103 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2104 (SvRV(tmpstr) != SvRV(sv)))
2105 return SvPV(tmpstr,*lp);
2112 switch (SvTYPE(sv)) {
2114 if ( ((SvFLAGS(sv) &
2115 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2116 == (SVs_OBJECT|SVs_RMG))
2117 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2118 && (mg = mg_find(sv, 'r'))) {
2119 regexp *re = (regexp *)mg->mg_obj;
2122 char *fptr = "msix";
2127 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2129 while((ch = *fptr++)) {
2131 reflags[left++] = ch;
2134 reflags[right--] = ch;
2139 reflags[left] = '-';
2143 mg->mg_len = re->prelen + 4 + left;
2144 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2145 Copy("(?", mg->mg_ptr, 2, char);
2146 Copy(reflags, mg->mg_ptr+2, left, char);
2147 Copy(":", mg->mg_ptr+left+2, 1, char);
2148 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2149 mg->mg_ptr[mg->mg_len - 1] = ')';
2150 mg->mg_ptr[mg->mg_len] = 0;
2152 PL_reginterp_cnt += re->program[0].next_off;
2164 case SVt_PVBM: if (SvROK(sv))
2167 s = "SCALAR"; break;
2168 case SVt_PVLV: s = "LVALUE"; break;
2169 case SVt_PVAV: s = "ARRAY"; break;
2170 case SVt_PVHV: s = "HASH"; break;
2171 case SVt_PVCV: s = "CODE"; break;
2172 case SVt_PVGV: s = "GLOB"; break;
2173 case SVt_PVFM: s = "FORMAT"; break;
2174 case SVt_PVIO: s = "IO"; break;
2175 default: s = "UNKNOWN"; break;
2179 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2182 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2188 if (SvREADONLY(sv) && !SvOK(sv)) {
2189 if (ckWARN(WARN_UNINITIALIZED))
2195 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2196 /* XXXX 64-bit? IV may have better precision... */
2197 /* I tried changing this to be 64-bit-aware and
2198 * the t/op/numconvert.t became very, very, angry.
2200 if (SvTYPE(sv) < SVt_PVNV)
2201 sv_upgrade(sv, SVt_PVNV);
2202 /* The +20 is pure guesswork. Configure test needed. --jhi */
2203 SvGROW(sv, NV_DIG + 20);
2205 olderrno = errno; /* some Xenix systems wipe out errno here */
2207 if (SvNVX(sv) == 0.0)
2208 (void)strcpy(s,"0");
2212 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2215 #ifdef FIXNEGATIVEZERO
2216 if (*s == '-' && s[1] == '0' && !s[2])
2225 else if (SvIOKp(sv)) {
2226 U32 isIOK = SvIOK(sv);
2227 U32 isUIOK = SvIsUV(sv);
2228 char buf[TYPE_CHARS(UV)];
2231 if (SvTYPE(sv) < SVt_PVIV)
2232 sv_upgrade(sv, SVt_PVIV);
2234 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2236 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2237 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2238 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2239 SvCUR_set(sv, ebuf - ptr);
2251 if (ckWARN(WARN_UNINITIALIZED)
2252 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2255 if (SvTYPE(sv) < SVt_PV)
2256 /* Typically the caller expects that sv_any is not NULL now. */
2257 sv_upgrade(sv, SVt_PV);
2260 *lp = s - SvPVX(sv);
2263 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2264 PTR2UV(sv),SvPVX(sv)));
2268 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2269 /* Sneaky stuff here */
2273 tsv = newSVpv(tmpbuf, 0);
2289 len = strlen(tmpbuf);
2291 #ifdef FIXNEGATIVEZERO
2292 if (len == 2 && t[0] == '-' && t[1] == '0') {
2297 (void)SvUPGRADE(sv, SVt_PV);
2299 s = SvGROW(sv, len + 1);
2308 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2311 return sv_2pvbyte(sv, &n_a);
2315 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2317 return sv_2pv(sv,lp);
2321 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2324 return sv_2pvutf8(sv, &n_a);
2328 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2330 sv_utf8_upgrade(sv);
2331 return sv_2pv(sv,lp);
2334 /* This function is only called on magical items */
2336 Perl_sv_2bool(pTHX_ register SV *sv)
2345 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2346 (SvRV(tmpsv) != SvRV(sv)))
2347 return SvTRUE(tmpsv);
2348 return SvRV(sv) != 0;
2351 register XPV* Xpvtmp;
2352 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2353 (*Xpvtmp->xpv_pv > '0' ||
2354 Xpvtmp->xpv_cur > 1 ||
2355 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2362 return SvIVX(sv) != 0;
2365 return SvNVX(sv) != 0.0;
2373 =for apidoc sv_utf8_upgrade
2375 Convert the PV of an SV to its UTF8-encoded form.
2381 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2386 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2389 /* This function could be much more efficient if we had a FLAG in SVs
2390 * to signal if there are any hibit chars in the PV.
2392 for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2397 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2398 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2399 SvCUR(sv) = len - 1;
2400 SvLEN(sv) = len; /* No longer know the real size. */
2402 Safefree(s); /* No longer using what was there before. */
2407 =for apidoc sv_utf8_downgrade
2409 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2410 This may not be possible if the PV contains non-byte encoding characters;
2411 if this is the case, either returns false or, if C<fail_ok> is not
2418 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2420 if (SvPOK(sv) && SvUTF8(sv)) {
2422 char *c = SvPVX(sv);
2423 STRLEN len = SvCUR(sv);
2425 if (!utf8_to_bytes((U8*)c, &len)) {
2430 Perl_croak(aTHX_ "Wide character in %s",
2431 PL_op_desc[PL_op->op_type]);
2433 Perl_croak(aTHX_ "Wide character");
2445 =for apidoc sv_utf8_encode
2447 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2448 flag so that it looks like bytes again. Nothing calls this.
2454 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2456 sv_utf8_upgrade(sv);
2461 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2465 bool has_utf = FALSE;
2466 if (!sv_utf8_downgrade(sv, TRUE))
2469 /* it is actually just a matter of turning the utf8 flag on, but
2470 * we want to make sure everything inside is valid utf8 first.
2473 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
2476 while (c < SvEND(sv)) {
2487 /* Note: sv_setsv() should not be called with a source string that needs
2488 * to be reused, since it may destroy the source string if it is marked
2493 =for apidoc sv_setsv
2495 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2496 The source SV may be destroyed if it is mortal. Does not handle 'set'
2497 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2504 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2506 register U32 sflags;
2512 SV_CHECK_THINKFIRST(dstr);
2514 sstr = &PL_sv_undef;
2515 stype = SvTYPE(sstr);
2516 dtype = SvTYPE(dstr);
2520 /* There's a lot of redundancy below but we're going for speed here */
2525 if (dtype != SVt_PVGV) {
2526 (void)SvOK_off(dstr);
2534 sv_upgrade(dstr, SVt_IV);
2537 sv_upgrade(dstr, SVt_PVNV);
2541 sv_upgrade(dstr, SVt_PVIV);
2544 (void)SvIOK_only(dstr);
2545 SvIVX(dstr) = SvIVX(sstr);
2548 if (SvTAINTED(sstr))
2559 sv_upgrade(dstr, SVt_NV);
2564 sv_upgrade(dstr, SVt_PVNV);
2567 SvNVX(dstr) = SvNVX(sstr);
2568 (void)SvNOK_only(dstr);
2569 if (SvTAINTED(sstr))
2577 sv_upgrade(dstr, SVt_RV);
2578 else if (dtype == SVt_PVGV &&
2579 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2582 if (GvIMPORTED(dstr) != GVf_IMPORTED
2583 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2585 GvIMPORTED_on(dstr);
2596 sv_upgrade(dstr, SVt_PV);
2599 if (dtype < SVt_PVIV)
2600 sv_upgrade(dstr, SVt_PVIV);
2603 if (dtype < SVt_PVNV)
2604 sv_upgrade(dstr, SVt_PVNV);
2611 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2612 PL_op_name[PL_op->op_type]);
2614 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2618 if (dtype <= SVt_PVGV) {
2620 if (dtype != SVt_PVGV) {
2621 char *name = GvNAME(sstr);
2622 STRLEN len = GvNAMELEN(sstr);
2623 sv_upgrade(dstr, SVt_PVGV);
2624 sv_magic(dstr, dstr, '*', Nullch, 0);
2625 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2626 GvNAME(dstr) = savepvn(name, len);
2627 GvNAMELEN(dstr) = len;
2628 SvFAKE_on(dstr); /* can coerce to non-glob */
2630 /* ahem, death to those who redefine active sort subs */
2631 else if (PL_curstackinfo->si_type == PERLSI_SORT
2632 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2633 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2635 (void)SvOK_off(dstr);
2636 GvINTRO_off(dstr); /* one-shot flag */
2638 GvGP(dstr) = gp_ref(GvGP(sstr));
2639 if (SvTAINTED(sstr))
2641 if (GvIMPORTED(dstr) != GVf_IMPORTED
2642 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2644 GvIMPORTED_on(dstr);
2652 if (SvGMAGICAL(sstr)) {
2654 if (SvTYPE(sstr) != stype) {
2655 stype = SvTYPE(sstr);
2656 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2660 if (stype == SVt_PVLV)
2661 (void)SvUPGRADE(dstr, SVt_PVNV);
2663 (void)SvUPGRADE(dstr, stype);
2666 sflags = SvFLAGS(sstr);
2668 if (sflags & SVf_ROK) {
2669 if (dtype >= SVt_PV) {
2670 if (dtype == SVt_PVGV) {
2671 SV *sref = SvREFCNT_inc(SvRV(sstr));
2673 int intro = GvINTRO(dstr);
2678 GvINTRO_off(dstr); /* one-shot flag */
2679 Newz(602,gp, 1, GP);
2680 GvGP(dstr) = gp_ref(gp);
2681 GvSV(dstr) = NEWSV(72,0);
2682 GvLINE(dstr) = CopLINE(PL_curcop);
2683 GvEGV(dstr) = (GV*)dstr;
2686 switch (SvTYPE(sref)) {
2689 SAVESPTR(GvAV(dstr));
2691 dref = (SV*)GvAV(dstr);
2692 GvAV(dstr) = (AV*)sref;
2693 if (!GvIMPORTED_AV(dstr)
2694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2696 GvIMPORTED_AV_on(dstr);
2701 SAVESPTR(GvHV(dstr));
2703 dref = (SV*)GvHV(dstr);
2704 GvHV(dstr) = (HV*)sref;
2705 if (!GvIMPORTED_HV(dstr)
2706 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2708 GvIMPORTED_HV_on(dstr);
2713 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2714 SvREFCNT_dec(GvCV(dstr));
2715 GvCV(dstr) = Nullcv;
2716 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2717 PL_sub_generation++;
2719 SAVESPTR(GvCV(dstr));
2722 dref = (SV*)GvCV(dstr);
2723 if (GvCV(dstr) != (CV*)sref) {
2724 CV* cv = GvCV(dstr);
2726 if (!GvCVGEN((GV*)dstr) &&
2727 (CvROOT(cv) || CvXSUB(cv)))
2730 /* ahem, death to those who redefine
2731 * active sort subs */
2732 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2733 PL_sortcop == CvSTART(cv))
2735 "Can't redefine active sort subroutine %s",
2736 GvENAME((GV*)dstr));
2737 /* Redefining a sub - warning is mandatory if
2738 it was a const and its value changed. */
2739 if (ckWARN(WARN_REDEFINE)
2741 && (!CvCONST((CV*)sref)
2742 || sv_cmp(cv_const_sv(cv),
2743 cv_const_sv((CV*)sref)))))
2745 Perl_warner(aTHX_ WARN_REDEFINE,
2747 ? "Constant subroutine %s redefined"
2748 : "Subroutine %s redefined",
2749 GvENAME((GV*)dstr));
2752 cv_ckproto(cv, (GV*)dstr,
2753 SvPOK(sref) ? SvPVX(sref) : Nullch);
2755 GvCV(dstr) = (CV*)sref;
2756 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2757 GvASSUMECV_on(dstr);
2758 PL_sub_generation++;
2760 if (!GvIMPORTED_CV(dstr)
2761 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2763 GvIMPORTED_CV_on(dstr);
2768 SAVESPTR(GvIOp(dstr));
2770 dref = (SV*)GvIOp(dstr);
2771 GvIOp(dstr) = (IO*)sref;
2775 SAVESPTR(GvFORM(dstr));
2777 dref = (SV*)GvFORM(dstr);
2778 GvFORM(dstr) = (CV*)sref;
2782 SAVESPTR(GvSV(dstr));
2784 dref = (SV*)GvSV(dstr);
2786 if (!GvIMPORTED_SV(dstr)
2787 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2789 GvIMPORTED_SV_on(dstr);
2797 if (SvTAINTED(sstr))
2802 (void)SvOOK_off(dstr); /* backoff */
2804 Safefree(SvPVX(dstr));
2805 SvLEN(dstr)=SvCUR(dstr)=0;
2808 (void)SvOK_off(dstr);
2809 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2811 if (sflags & SVp_NOK) {
2813 SvNVX(dstr) = SvNVX(sstr);
2815 if (sflags & SVp_IOK) {
2816 (void)SvIOK_on(dstr);
2817 SvIVX(dstr) = SvIVX(sstr);
2818 if (sflags & SVf_IVisUV)
2821 if (SvAMAGIC(sstr)) {
2825 else if (sflags & SVp_POK) {
2828 * Check to see if we can just swipe the string. If so, it's a
2829 * possible small lose on short strings, but a big win on long ones.
2830 * It might even be a win on short strings if SvPVX(dstr)
2831 * has to be allocated and SvPVX(sstr) has to be freed.
2834 if (SvTEMP(sstr) && /* slated for free anyway? */
2835 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2836 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
2837 SvLEN(sstr) && /* and really is a string */
2838 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
2840 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2842 SvFLAGS(dstr) &= ~SVf_OOK;
2843 Safefree(SvPVX(dstr) - SvIVX(dstr));
2845 else if (SvLEN(dstr))
2846 Safefree(SvPVX(dstr));
2848 (void)SvPOK_only(dstr);
2849 SvPV_set(dstr, SvPVX(sstr));
2850 SvLEN_set(dstr, SvLEN(sstr));
2851 SvCUR_set(dstr, SvCUR(sstr));
2854 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2855 SvPV_set(sstr, Nullch);
2860 else { /* have to copy actual string */
2861 STRLEN len = SvCUR(sstr);
2863 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2864 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2865 SvCUR_set(dstr, len);
2866 *SvEND(dstr) = '\0';
2867 (void)SvPOK_only(dstr);
2869 if ((sflags & SVf_UTF8) && !IN_BYTE)
2872 if (sflags & SVp_NOK) {
2874 SvNVX(dstr) = SvNVX(sstr);
2876 if (sflags & SVp_IOK) {
2877 (void)SvIOK_on(dstr);
2878 SvIVX(dstr) = SvIVX(sstr);
2879 if (sflags & SVf_IVisUV)
2883 else if (sflags & SVp_NOK) {
2884 SvNVX(dstr) = SvNVX(sstr);
2885 (void)SvNOK_only(dstr);
2886 if (sflags & SVf_IOK) {
2887 (void)SvIOK_on(dstr);
2888 SvIVX(dstr) = SvIVX(sstr);
2889 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2890 if (sflags & SVf_IVisUV)
2894 else if (sflags & SVp_IOK) {
2895 (void)SvIOK_only(dstr);
2896 SvIVX(dstr) = SvIVX(sstr);
2897 if (sflags & SVf_IVisUV)
2901 if (dtype == SVt_PVGV) {
2902 if (ckWARN(WARN_MISC))
2903 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2906 (void)SvOK_off(dstr);
2908 if (SvTAINTED(sstr))
2913 =for apidoc sv_setsv_mg
2915 Like C<sv_setsv>, but also handles 'set' magic.
2921 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2923 sv_setsv(dstr,sstr);
2928 =for apidoc sv_setpvn
2930 Copies a string into an SV. The C<len> parameter indicates the number of
2931 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2937 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2939 register char *dptr;
2941 /* len is STRLEN which is unsigned, need to copy to signed */
2945 SV_CHECK_THINKFIRST(sv);
2950 (void)SvUPGRADE(sv, SVt_PV);
2952 SvGROW(sv, len + 1);
2954 Move(ptr,dptr,len,char);
2957 (void)SvPOK_only(sv); /* validate pointer */
2962 =for apidoc sv_setpvn_mg
2964 Like C<sv_setpvn>, but also handles 'set' magic.
2970 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2972 sv_setpvn(sv,ptr,len);
2977 =for apidoc sv_setpv
2979 Copies a string into an SV. The string must be null-terminated. Does not
2980 handle 'set' magic. See C<sv_setpv_mg>.
2986 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2988 register STRLEN len;
2990 SV_CHECK_THINKFIRST(sv);
2996 (void)SvUPGRADE(sv, SVt_PV);
2998 SvGROW(sv, len + 1);
2999 Move(ptr,SvPVX(sv),len+1,char);
3001 (void)SvPOK_only(sv); /* validate pointer */
3006 =for apidoc sv_setpv_mg
3008 Like C<sv_setpv>, but also handles 'set' magic.
3014 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3021 =for apidoc sv_usepvn
3023 Tells an SV to use C<ptr> to find its string value. Normally the string is
3024 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3025 The C<ptr> should point to memory that was allocated by C<malloc>. The
3026 string length, C<len>, must be supplied. This function will realloc the
3027 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3028 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3029 See C<sv_usepvn_mg>.
3035 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3037 SV_CHECK_THINKFIRST(sv);
3038 (void)SvUPGRADE(sv, SVt_PV);
3043 (void)SvOOK_off(sv);
3044 if (SvPVX(sv) && SvLEN(sv))
3045 Safefree(SvPVX(sv));
3046 Renew(ptr, len+1, char);
3049 SvLEN_set(sv, len+1);
3051 (void)SvPOK_only(sv); /* validate pointer */
3056 =for apidoc sv_usepvn_mg
3058 Like C<sv_usepvn>, but also handles 'set' magic.
3064 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3066 sv_usepvn(sv,ptr,len);
3071 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3073 if (SvREADONLY(sv)) {
3075 char *pvx = SvPVX(sv);
3076 STRLEN len = SvCUR(sv);
3077 U32 hash = SvUVX(sv);
3078 SvGROW(sv, len + 1);
3079 Move(pvx,SvPVX(sv),len,char);
3083 unsharepvn(pvx,len,hash);
3085 else if (PL_curcop != &PL_compiling)
3086 Perl_croak(aTHX_ PL_no_modify);
3089 sv_unref_flags(sv, flags);
3090 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3095 Perl_sv_force_normal(pTHX_ register SV *sv)
3097 sv_force_normal_flags(sv, 0);
3103 Efficient removal of characters from the beginning of the string buffer.
3104 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3105 the string buffer. The C<ptr> becomes the first character of the adjusted
3112 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3116 register STRLEN delta;
3118 if (!ptr || !SvPOKp(sv))
3120 SV_CHECK_THINKFIRST(sv);
3121 if (SvTYPE(sv) < SVt_PVIV)
3122 sv_upgrade(sv,SVt_PVIV);
3125 if (!SvLEN(sv)) { /* make copy of shared string */
3126 char *pvx = SvPVX(sv);
3127 STRLEN len = SvCUR(sv);
3128 SvGROW(sv, len + 1);
3129 Move(pvx,SvPVX(sv),len,char);
3133 SvFLAGS(sv) |= SVf_OOK;
3135 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3136 delta = ptr - SvPVX(sv);
3144 =for apidoc sv_catpvn
3146 Concatenates the string onto the end of the string which is in the SV. The
3147 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3148 'set' magic. See C<sv_catpvn_mg>.
3154 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3159 junk = SvPV_force(sv, tlen);
3160 SvGROW(sv, tlen + len + 1);
3163 Move(ptr,SvPVX(sv)+tlen,len,char);
3166 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3171 =for apidoc sv_catpvn_mg
3173 Like C<sv_catpvn>, but also handles 'set' magic.
3179 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3181 sv_catpvn(sv,ptr,len);
3186 =for apidoc sv_catsv
3188 Concatenates the string from SV C<ssv> onto the end of the string in SV
3189 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3195 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3201 if ((s = SvPV(sstr, len))) {
3202 if (DO_UTF8(sstr)) {
3203 sv_utf8_upgrade(dstr);
3204 sv_catpvn(dstr,s,len);
3208 sv_catpvn(dstr,s,len);
3213 =for apidoc sv_catsv_mg
3215 Like C<sv_catsv>, but also handles 'set' magic.
3221 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3223 sv_catsv(dstr,sstr);
3228 =for apidoc sv_catpv
3230 Concatenates the string onto the end of the string which is in the SV.
3231 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3237 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3239 register STRLEN len;
3245 junk = SvPV_force(sv, tlen);
3247 SvGROW(sv, tlen + len + 1);
3250 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3252 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3257 =for apidoc sv_catpv_mg
3259 Like C<sv_catpv>, but also handles 'set' magic.
3265 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3272 Perl_newSV(pTHX_ STRLEN len)
3278 sv_upgrade(sv, SVt_PV);
3279 SvGROW(sv, len + 1);
3284 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3287 =for apidoc sv_magic
3289 Adds magic to an SV.
3295 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3299 if (SvREADONLY(sv)) {
3300 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3301 Perl_croak(aTHX_ PL_no_modify);
3303 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3304 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3311 (void)SvUPGRADE(sv, SVt_PVMG);
3313 Newz(702,mg, 1, MAGIC);
3314 mg->mg_moremagic = SvMAGIC(sv);
3317 if (!obj || obj == sv || how == '#' || how == 'r')
3320 mg->mg_obj = SvREFCNT_inc(obj);
3321 mg->mg_flags |= MGf_REFCOUNTED;
3324 mg->mg_len = namlen;
3327 mg->mg_ptr = savepvn(name, namlen);
3328 else if (namlen == HEf_SVKEY)
3329 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3333 mg->mg_virtual = &PL_vtbl_sv;
3336 mg->mg_virtual = &PL_vtbl_amagic;
3339 mg->mg_virtual = &PL_vtbl_amagicelem;
3345 mg->mg_virtual = &PL_vtbl_bm;
3348 mg->mg_virtual = &PL_vtbl_regdata;
3351 mg->mg_virtual = &PL_vtbl_regdatum;
3354 mg->mg_virtual = &PL_vtbl_env;
3357 mg->mg_virtual = &PL_vtbl_fm;
3360 mg->mg_virtual = &PL_vtbl_envelem;
3363 mg->mg_virtual = &PL_vtbl_mglob;
3366 mg->mg_virtual = &PL_vtbl_isa;
3369 mg->mg_virtual = &PL_vtbl_isaelem;
3372 mg->mg_virtual = &PL_vtbl_nkeys;
3379 mg->mg_virtual = &PL_vtbl_dbline;
3383 mg->mg_virtual = &PL_vtbl_mutex;
3385 #endif /* USE_THREADS */
3386 #ifdef USE_LOCALE_COLLATE
3388 mg->mg_virtual = &PL_vtbl_collxfrm;
3390 #endif /* USE_LOCALE_COLLATE */
3392 mg->mg_virtual = &PL_vtbl_pack;
3396 mg->mg_virtual = &PL_vtbl_packelem;
3399 mg->mg_virtual = &PL_vtbl_regexp;
3402 mg->mg_virtual = &PL_vtbl_sig;
3405 mg->mg_virtual = &PL_vtbl_sigelem;
3408 mg->mg_virtual = &PL_vtbl_taint;
3412 mg->mg_virtual = &PL_vtbl_uvar;
3415 mg->mg_virtual = &PL_vtbl_vec;
3418 mg->mg_virtual = &PL_vtbl_substr;
3421 mg->mg_virtual = &PL_vtbl_defelem;
3424 mg->mg_virtual = &PL_vtbl_glob;
3427 mg->mg_virtual = &PL_vtbl_arylen;
3430 mg->mg_virtual = &PL_vtbl_pos;
3433 mg->mg_virtual = &PL_vtbl_backref;
3435 case '~': /* Reserved for use by extensions not perl internals. */
3436 /* Useful for attaching extension internal data to perl vars. */
3437 /* Note that multiple extensions may clash if magical scalars */
3438 /* etc holding private data from one are passed to another. */
3442 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3446 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3450 =for apidoc sv_unmagic
3452 Removes magic from an SV.
3458 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3462 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3465 for (mg = *mgp; mg; mg = *mgp) {
3466 if (mg->mg_type == type) {
3467 MGVTBL* vtbl = mg->mg_virtual;
3468 *mgp = mg->mg_moremagic;
3469 if (vtbl && vtbl->svt_free)
3470 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3471 if (mg->mg_ptr && mg->mg_type != 'g')
3472 if (mg->mg_len >= 0)
3473 Safefree(mg->mg_ptr);
3474 else if (mg->mg_len == HEf_SVKEY)
3475 SvREFCNT_dec((SV*)mg->mg_ptr);
3476 if (mg->mg_flags & MGf_REFCOUNTED)
3477 SvREFCNT_dec(mg->mg_obj);
3481 mgp = &mg->mg_moremagic;
3485 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3492 =for apidoc sv_rvweaken
3500 Perl_sv_rvweaken(pTHX_ SV *sv)
3503 if (!SvOK(sv)) /* let undefs pass */
3506 Perl_croak(aTHX_ "Can't weaken a nonreference");
3507 else if (SvWEAKREF(sv)) {
3508 if (ckWARN(WARN_MISC))
3509 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3513 sv_add_backref(tsv, sv);
3520 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3524 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3525 av = (AV*)mg->mg_obj;
3528 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3529 SvREFCNT_dec(av); /* for sv_magic */
3535 S_sv_del_backref(pTHX_ SV *sv)
3542 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3543 Perl_croak(aTHX_ "panic: del_backref");
3544 av = (AV *)mg->mg_obj;
3549 svp[i] = &PL_sv_undef; /* XXX */
3556 =for apidoc sv_insert
3558 Inserts a string at the specified offset/length within the SV. Similar to
3559 the Perl substr() function.
3565 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3569 register char *midend;
3570 register char *bigend;
3576 Perl_croak(aTHX_ "Can't modify non-existent substring");
3577 SvPV_force(bigstr, curlen);
3578 (void)SvPOK_only_UTF8(bigstr);
3579 if (offset + len > curlen) {
3580 SvGROW(bigstr, offset+len+1);
3581 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3582 SvCUR_set(bigstr, offset+len);
3586 i = littlelen - len;
3587 if (i > 0) { /* string might grow */
3588 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3589 mid = big + offset + len;
3590 midend = bigend = big + SvCUR(bigstr);
3593 while (midend > mid) /* shove everything down */
3594 *--bigend = *--midend;
3595 Move(little,big+offset,littlelen,char);
3601 Move(little,SvPVX(bigstr)+offset,len,char);
3606 big = SvPVX(bigstr);
3609 bigend = big + SvCUR(bigstr);
3611 if (midend > bigend)
3612 Perl_croak(aTHX_ "panic: sv_insert");
3614 if (mid - big > bigend - midend) { /* faster to shorten from end */
3616 Move(little, mid, littlelen,char);
3619 i = bigend - midend;
3621 Move(midend, mid, i,char);
3625 SvCUR_set(bigstr, mid - big);
3628 else if ((i = mid - big)) { /* faster from front */
3629 midend -= littlelen;
3631 sv_chop(bigstr,midend-i);
3636 Move(little, mid, littlelen,char);
3638 else if (littlelen) {
3639 midend -= littlelen;
3640 sv_chop(bigstr,midend);
3641 Move(little,midend,littlelen,char);
3644 sv_chop(bigstr,midend);
3650 =for apidoc sv_replace
3652 Make the first argument a copy of the second, then delete the original.
3658 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3660 U32 refcnt = SvREFCNT(sv);
3661 SV_CHECK_THINKFIRST(sv);
3662 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3663 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3664 if (SvMAGICAL(sv)) {
3668 sv_upgrade(nsv, SVt_PVMG);
3669 SvMAGIC(nsv) = SvMAGIC(sv);
3670 SvFLAGS(nsv) |= SvMAGICAL(sv);
3676 assert(!SvREFCNT(sv));
3677 StructCopy(nsv,sv,SV);
3678 SvREFCNT(sv) = refcnt;
3679 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3684 =for apidoc sv_clear
3686 Clear an SV, making it empty. Does not free the memory used by the SV
3693 Perl_sv_clear(pTHX_ register SV *sv)
3697 assert(SvREFCNT(sv) == 0);
3700 if (PL_defstash) { /* Still have a symbol table? */
3705 Zero(&tmpref, 1, SV);
3706 sv_upgrade(&tmpref, SVt_RV);
3708 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3709 SvREFCNT(&tmpref) = 1;
3712 stash = SvSTASH(sv);
3713 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3716 PUSHSTACKi(PERLSI_DESTROY);
3717 SvRV(&tmpref) = SvREFCNT_inc(sv);
3722 call_sv((SV*)GvCV(destructor),
3723 G_DISCARD|G_EVAL|G_KEEPERR);
3729 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3731 del_XRV(SvANY(&tmpref));
3734 if (PL_in_clean_objs)
3735 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3737 /* DESTROY gave object new lease on life */
3743 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3744 SvOBJECT_off(sv); /* Curse the object. */
3745 if (SvTYPE(sv) != SVt_PVIO)
3746 --PL_sv_objcount; /* XXX Might want something more general */
3749 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3752 switch (SvTYPE(sv)) {
3755 IoIFP(sv) != PerlIO_stdin() &&
3756 IoIFP(sv) != PerlIO_stdout() &&
3757 IoIFP(sv) != PerlIO_stderr())
3759 io_close((IO*)sv, FALSE);
3761 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3762 PerlDir_close(IoDIRP(sv));
3763 IoDIRP(sv) = (DIR*)NULL;
3764 Safefree(IoTOP_NAME(sv));
3765 Safefree(IoFMT_NAME(sv));
3766 Safefree(IoBOTTOM_NAME(sv));
3781 SvREFCNT_dec(LvTARG(sv));
3785 Safefree(GvNAME(sv));
3786 /* cannot decrease stash refcount yet, as we might recursively delete
3787 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3788 of stash until current sv is completely gone.
3789 -- JohnPC, 27 Mar 1998 */
3790 stash = GvSTASH(sv);
3796 (void)SvOOK_off(sv);
3804 SvREFCNT_dec(SvRV(sv));
3806 else if (SvPVX(sv) && SvLEN(sv))
3807 Safefree(SvPVX(sv));
3808 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3809 unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3821 switch (SvTYPE(sv)) {
3837 del_XPVIV(SvANY(sv));
3840 del_XPVNV(SvANY(sv));
3843 del_XPVMG(SvANY(sv));
3846 del_XPVLV(SvANY(sv));
3849 del_XPVAV(SvANY(sv));
3852 del_XPVHV(SvANY(sv));
3855 del_XPVCV(SvANY(sv));
3858 del_XPVGV(SvANY(sv));
3859 /* code duplication for increased performance. */
3860 SvFLAGS(sv) &= SVf_BREAK;
3861 SvFLAGS(sv) |= SVTYPEMASK;
3862 /* decrease refcount of the stash that owns this GV, if any */
3864 SvREFCNT_dec(stash);
3865 return; /* not break, SvFLAGS reset already happened */
3867 del_XPVBM(SvANY(sv));
3870 del_XPVFM(SvANY(sv));
3873 del_XPVIO(SvANY(sv));
3876 SvFLAGS(sv) &= SVf_BREAK;
3877 SvFLAGS(sv) |= SVTYPEMASK;
3881 Perl_sv_newref(pTHX_ SV *sv)
3884 ATOMIC_INC(SvREFCNT(sv));
3891 Free the memory used by an SV.
3897 Perl_sv_free(pTHX_ SV *sv)
3899 int refcount_is_zero;
3903 if (SvREFCNT(sv) == 0) {
3904 if (SvFLAGS(sv) & SVf_BREAK)
3906 if (PL_in_clean_all) /* All is fair */
3908 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3909 /* make sure SvREFCNT(sv)==0 happens very seldom */
3910 SvREFCNT(sv) = (~(U32)0)/2;
3913 if (ckWARN_d(WARN_INTERNAL))
3914 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3917 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3918 if (!refcount_is_zero)
3922 if (ckWARN_d(WARN_DEBUGGING))
3923 Perl_warner(aTHX_ WARN_DEBUGGING,
3924 "Attempt to free temp prematurely: SV 0x%"UVxf,
3929 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3930 /* make sure SvREFCNT(sv)==0 happens very seldom */
3931 SvREFCNT(sv) = (~(U32)0)/2;
3942 Returns the length of the string in the SV. See also C<SvCUR>.
3948 Perl_sv_len(pTHX_ register SV *sv)
3957 len = mg_length(sv);
3959 junk = SvPV(sv, len);
3964 =for apidoc sv_len_utf8
3966 Returns the number of characters in the string in an SV, counting wide
3967 UTF8 bytes as a single character.
3973 Perl_sv_len_utf8(pTHX_ register SV *sv)
3980 return mg_length(sv);
3985 U8 *s = (U8*)SvPV(sv, len);
3987 return Perl_utf8_length(aTHX_ s, s + len);
3992 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3997 I32 uoffset = *offsetp;
4003 start = s = (U8*)SvPV(sv, len);
4005 while (s < send && uoffset--)
4009 *offsetp = s - start;
4013 while (s < send && ulen--)
4023 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4032 s = (U8*)SvPV(sv, len);
4034 Perl_croak(aTHX_ "panic: bad byte offset");
4035 send = s + *offsetp;
4042 if (ckWARN_d(WARN_UTF8))
4043 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4053 Returns a boolean indicating whether the strings in the two SVs are
4060 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4067 bool pv1tmp = FALSE;
4068 bool pv2tmp = FALSE;
4075 pv1 = SvPV(sv1, cur1);
4082 pv2 = SvPV(sv2, cur2);
4084 /* do not utf8ize the comparands as a side-effect */
4085 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4087 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4091 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4097 eq = memEQ(pv1, pv2, cur1);
4110 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4111 string in C<sv1> is less than, equal to, or greater than the string in
4118 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4123 bool pv1tmp = FALSE;
4124 bool pv2tmp = FALSE;
4131 pv1 = SvPV(sv1, cur1);
4138 pv2 = SvPV(sv2, cur2);
4140 /* do not utf8ize the comparands as a side-effect */
4141 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4143 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4147 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4153 cmp = cur2 ? -1 : 0;
4157 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4160 cmp = retval < 0 ? -1 : 1;
4161 } else if (cur1 == cur2) {
4164 cmp = cur1 < cur2 ? -1 : 1;
4177 =for apidoc sv_cmp_locale
4179 Compares the strings in two SVs in a locale-aware manner. See
4186 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4188 #ifdef USE_LOCALE_COLLATE
4194 if (PL_collation_standard)
4198 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4200 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4202 if (!pv1 || !len1) {
4213 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4216 return retval < 0 ? -1 : 1;
4219 * When the result of collation is equality, that doesn't mean
4220 * that there are no differences -- some locales exclude some
4221 * characters from consideration. So to avoid false equalities,
4222 * we use the raw string as a tiebreaker.
4228 #endif /* USE_LOCALE_COLLATE */
4230 return sv_cmp(sv1, sv2);
4233 #ifdef USE_LOCALE_COLLATE
4235 * Any scalar variable may carry an 'o' magic that contains the
4236 * scalar data of the variable transformed to such a format that
4237 * a normal memory comparison can be used to compare the data
4238 * according to the locale settings.
4241 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4245 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4246 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4251 Safefree(mg->mg_ptr);
4253 if ((xf = mem_collxfrm(s, len, &xlen))) {
4254 if (SvREADONLY(sv)) {
4257 return xf + sizeof(PL_collation_ix);
4260 sv_magic(sv, 0, 'o', 0, 0);
4261 mg = mg_find(sv, 'o');
4274 if (mg && mg->mg_ptr) {
4276 return mg->mg_ptr + sizeof(PL_collation_ix);
4284 #endif /* USE_LOCALE_COLLATE */
4289 Get a line from the filehandle and store it into the SV, optionally
4290 appending to the currently-stored string.
4296 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4300 register STDCHAR rslast;
4301 register STDCHAR *bp;
4305 SV_CHECK_THINKFIRST(sv);
4306 (void)SvUPGRADE(sv, SVt_PV);
4310 if (RsSNARF(PL_rs)) {
4314 else if (RsRECORD(PL_rs)) {
4315 I32 recsize, bytesread;
4318 /* Grab the size of the record we're getting */
4319 recsize = SvIV(SvRV(PL_rs));
4320 (void)SvPOK_only(sv); /* Validate pointer */
4321 buffer = SvGROW(sv, recsize + 1);
4324 /* VMS wants read instead of fread, because fread doesn't respect */
4325 /* RMS record boundaries. This is not necessarily a good thing to be */
4326 /* doing, but we've got no other real choice */
4327 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4329 bytesread = PerlIO_read(fp, buffer, recsize);
4331 SvCUR_set(sv, bytesread);
4332 buffer[bytesread] = '\0';
4333 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4335 else if (RsPARA(PL_rs)) {
4340 rsptr = SvPV(PL_rs, rslen);
4341 rslast = rslen ? rsptr[rslen - 1] : '\0';
4343 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4344 do { /* to make sure file boundaries work right */
4347 i = PerlIO_getc(fp);
4351 PerlIO_ungetc(fp,i);
4357 /* See if we know enough about I/O mechanism to cheat it ! */
4359 /* This used to be #ifdef test - it is made run-time test for ease
4360 of abstracting out stdio interface. One call should be cheap
4361 enough here - and may even be a macro allowing compile
4365 if (PerlIO_fast_gets(fp)) {
4368 * We're going to steal some values from the stdio struct
4369 * and put EVERYTHING in the innermost loop into registers.
4371 register STDCHAR *ptr;
4375 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4376 /* An ungetc()d char is handled separately from the regular
4377 * buffer, so we getc() it back out and stuff it in the buffer.
4379 i = PerlIO_getc(fp);
4380 if (i == EOF) return 0;
4381 *(--((*fp)->_ptr)) = (unsigned char) i;
4385 /* Here is some breathtakingly efficient cheating */
4387 cnt = PerlIO_get_cnt(fp); /* get count into register */
4388 (void)SvPOK_only(sv); /* validate pointer */
4389 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4390 if (cnt > 80 && SvLEN(sv) > append) {
4391 shortbuffered = cnt - SvLEN(sv) + append + 1;
4392 cnt -= shortbuffered;
4396 /* remember that cnt can be negative */
4397 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4402 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4403 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4404 DEBUG_P(PerlIO_printf(Perl_debug_log,
4405 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4406 DEBUG_P(PerlIO_printf(Perl_debug_log,
4407 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4408 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4409 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4414 while (cnt > 0) { /* this | eat */
4416 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4417 goto thats_all_folks; /* screams | sed :-) */
4421 Copy(ptr, bp, cnt, char); /* this | eat */
4422 bp += cnt; /* screams | dust */
4423 ptr += cnt; /* louder | sed :-) */
4428 if (shortbuffered) { /* oh well, must extend */
4429 cnt = shortbuffered;
4431 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4433 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4434 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4438 DEBUG_P(PerlIO_printf(Perl_debug_log,
4439 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4440 PTR2UV(ptr),(long)cnt));
4441 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4442 DEBUG_P(PerlIO_printf(Perl_debug_log,
4443 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4444 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4445 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4446 /* This used to call 'filbuf' in stdio form, but as that behaves like
4447 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4448 another abstraction. */
4449 i = PerlIO_getc(fp); /* get more characters */
4450 DEBUG_P(PerlIO_printf(Perl_debug_log,
4451 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4452 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4453 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4454 cnt = PerlIO_get_cnt(fp);
4455 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4456 DEBUG_P(PerlIO_printf(Perl_debug_log,
4457 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4459 if (i == EOF) /* all done for ever? */
4460 goto thats_really_all_folks;
4462 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4464 SvGROW(sv, bpx + cnt + 2);
4465 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4467 *bp++ = i; /* store character from PerlIO_getc */
4469 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4470 goto thats_all_folks;
4474 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4475 memNE((char*)bp - rslen, rsptr, rslen))
4476 goto screamer; /* go back to the fray */
4477 thats_really_all_folks:
4479 cnt += shortbuffered;
4480 DEBUG_P(PerlIO_printf(Perl_debug_log,
4481 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4482 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4483 DEBUG_P(PerlIO_printf(Perl_debug_log,
4484 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4485 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4486 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4488 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4489 DEBUG_P(PerlIO_printf(Perl_debug_log,
4490 "Screamer: done, len=%ld, string=|%.*s|\n",
4491 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4496 /*The big, slow, and stupid way */
4499 /* Need to work around EPOC SDK features */
4500 /* On WINS: MS VC5 generates calls to _chkstk, */
4501 /* if a `large' stack frame is allocated */
4502 /* gcc on MARM does not generate calls like these */
4508 register STDCHAR *bpe = buf + sizeof(buf);
4510 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4511 ; /* keep reading */
4515 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4516 /* Accomodate broken VAXC compiler, which applies U8 cast to
4517 * both args of ?: operator, causing EOF to change into 255
4519 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4523 sv_catpvn(sv, (char *) buf, cnt);
4525 sv_setpvn(sv, (char *) buf, cnt);
4527 if (i != EOF && /* joy */
4529 SvCUR(sv) < rslen ||
4530 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4534 * If we're reading from a TTY and we get a short read,
4535 * indicating that the user hit his EOF character, we need
4536 * to notice it now, because if we try to read from the TTY
4537 * again, the EOF condition will disappear.
4539 * The comparison of cnt to sizeof(buf) is an optimization
4540 * that prevents unnecessary calls to feof().
4544 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4549 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4550 while (i != EOF) { /* to make sure file boundaries work right */
4551 i = PerlIO_getc(fp);
4553 PerlIO_ungetc(fp,i);
4559 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4566 Auto-increment of the value in the SV.
4572 Perl_sv_inc(pTHX_ register SV *sv)
4581 if (SvTHINKFIRST(sv)) {
4582 if (SvREADONLY(sv)) {
4583 if (PL_curcop != &PL_compiling)
4584 Perl_croak(aTHX_ PL_no_modify);
4588 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4590 i = PTR2IV(SvRV(sv));
4595 flags = SvFLAGS(sv);
4596 if (flags & SVp_NOK) {
4597 (void)SvNOK_only(sv);
4601 if (flags & SVp_IOK) {
4603 if (SvUVX(sv) == UV_MAX)
4604 sv_setnv(sv, (NV)UV_MAX + 1.0);
4606 (void)SvIOK_only_UV(sv);
4609 if (SvIVX(sv) == IV_MAX)
4610 sv_setnv(sv, (NV)IV_MAX + 1.0);
4612 (void)SvIOK_only(sv);
4618 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4619 if ((flags & SVTYPEMASK) < SVt_PVNV)
4620 sv_upgrade(sv, SVt_IV);
4621 (void)SvIOK_only(sv);
4626 while (isALPHA(*d)) d++;
4627 while (isDIGIT(*d)) d++;
4629 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4633 while (d >= SvPVX(sv)) {
4641 /* MKS: The original code here died if letters weren't consecutive.
4642 * at least it didn't have to worry about non-C locales. The
4643 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4644 * arranged in order (although not consecutively) and that only
4645 * [A-Za-z] are accepted by isALPHA in the C locale.
4647 if (*d != 'z' && *d != 'Z') {
4648 do { ++*d; } while (!isALPHA(*d));
4651 *(d--) -= 'z' - 'a';
4656 *(d--) -= 'z' - 'a' + 1;
4660 /* oh,oh, the number grew */
4661 SvGROW(sv, SvCUR(sv) + 2);
4663 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4674 Auto-decrement of the value in the SV.
4680 Perl_sv_dec(pTHX_ register SV *sv)
4688 if (SvTHINKFIRST(sv)) {
4689 if (SvREADONLY(sv)) {
4690 if (PL_curcop != &PL_compiling)
4691 Perl_croak(aTHX_ PL_no_modify);
4695 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4697 i = PTR2IV(SvRV(sv));
4702 flags = SvFLAGS(sv);
4703 if (flags & SVp_NOK) {
4705 (void)SvNOK_only(sv);
4708 if (flags & SVp_IOK) {
4710 if (SvUVX(sv) == 0) {
4711 (void)SvIOK_only(sv);
4715 (void)SvIOK_only_UV(sv);
4719 if (SvIVX(sv) == IV_MIN)
4720 sv_setnv(sv, (NV)IV_MIN - 1.0);
4722 (void)SvIOK_only(sv);
4728 if (!(flags & SVp_POK)) {
4729 if ((flags & SVTYPEMASK) < SVt_PVNV)
4730 sv_upgrade(sv, SVt_NV);
4732 (void)SvNOK_only(sv);
4735 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4739 =for apidoc sv_mortalcopy
4741 Creates a new SV which is a copy of the original SV. The new SV is marked
4747 /* Make a string that will exist for the duration of the expression
4748 * evaluation. Actually, it may have to last longer than that, but
4749 * hopefully we won't free it until it has been assigned to a
4750 * permanent location. */
4753 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4758 sv_setsv(sv,oldstr);
4760 PL_tmps_stack[++PL_tmps_ix] = sv;
4766 =for apidoc sv_newmortal
4768 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4774 Perl_sv_newmortal(pTHX)
4779 SvFLAGS(sv) = SVs_TEMP;
4781 PL_tmps_stack[++PL_tmps_ix] = sv;
4786 =for apidoc sv_2mortal
4788 Marks an SV as mortal. The SV will be destroyed when the current context
4794 /* same thing without the copying */
4797 Perl_sv_2mortal(pTHX_ register SV *sv)
4801 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4804 PL_tmps_stack[++PL_tmps_ix] = sv;
4812 Creates a new SV and copies a string into it. The reference count for the
4813 SV is set to 1. If C<len> is zero, Perl will compute the length using
4814 strlen(). For efficiency, consider using C<newSVpvn> instead.
4820 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4827 sv_setpvn(sv,s,len);
4832 =for apidoc newSVpvn
4834 Creates a new SV and copies a string into it. The reference count for the
4835 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4836 string. You are responsible for ensuring that the source string is at least
4843 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4848 sv_setpvn(sv,s,len);
4853 =for apidoc newSVpvn_share
4855 Creates a new SV and populates it with a string from
4856 the string table. Turns on READONLY and FAKE.
4857 The idea here is that as string table is used for shared hash
4858 keys these strings will have SvPVX == HeKEY and hash lookup
4859 will avoid string compare.
4865 Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4869 PERL_HASH(hash, src, len);
4871 sv_upgrade(sv, SVt_PVIV);
4872 SvPVX(sv) = sharepvn(src, len, hash);
4882 #if defined(PERL_IMPLICIT_CONTEXT)
4884 Perl_newSVpvf_nocontext(const char* pat, ...)
4889 va_start(args, pat);
4890 sv = vnewSVpvf(pat, &args);
4897 =for apidoc newSVpvf
4899 Creates a new SV an initialize it with the string formatted like
4906 Perl_newSVpvf(pTHX_ const char* pat, ...)
4910 va_start(args, pat);
4911 sv = vnewSVpvf(pat, &args);
4917 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4921 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4928 Creates a new SV and copies a floating point value into it.
4929 The reference count for the SV is set to 1.
4935 Perl_newSVnv(pTHX_ NV n)
4947 Creates a new SV and copies an integer into it. The reference count for the
4954 Perl_newSViv(pTHX_ IV i)
4966 Creates a new SV and copies an unsigned integer into it.
4967 The reference count for the SV is set to 1.
4973 Perl_newSVuv(pTHX_ UV u)
4983 =for apidoc newRV_noinc
4985 Creates an RV wrapper for an SV. The reference count for the original
4986 SV is B<not> incremented.
4992 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4997 sv_upgrade(sv, SVt_RV);
5004 /* newRV_inc is #defined to newRV in sv.h */
5006 Perl_newRV(pTHX_ SV *tmpRef)
5008 return newRV_noinc(SvREFCNT_inc(tmpRef));
5014 Creates a new SV which is an exact duplicate of the original SV.
5019 /* make an exact duplicate of old */
5022 Perl_newSVsv(pTHX_ register SV *old)
5028 if (SvTYPE(old) == SVTYPEMASK) {
5029 if (ckWARN_d(WARN_INTERNAL))
5030 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5045 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5053 char todo[PERL_UCHAR_MAX+1];
5058 if (!*s) { /* reset ?? searches */
5059 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5060 pm->op_pmdynflags &= ~PMdf_USED;
5065 /* reset variables */
5067 if (!HvARRAY(stash))
5070 Zero(todo, 256, char);
5072 i = (unsigned char)*s;
5076 max = (unsigned char)*s++;
5077 for ( ; i <= max; i++) {
5080 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5081 for (entry = HvARRAY(stash)[i];
5083 entry = HeNEXT(entry))
5085 if (!todo[(U8)*HeKEY(entry)])
5087 gv = (GV*)HeVAL(entry);
5089 if (SvTHINKFIRST(sv)) {
5090 if (!SvREADONLY(sv) && SvROK(sv))
5095 if (SvTYPE(sv) >= SVt_PV) {
5097 if (SvPVX(sv) != Nullch)
5104 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5106 #ifdef USE_ENVIRON_ARRAY
5108 environ[0] = Nullch;
5117 Perl_sv_2io(pTHX_ SV *sv)
5123 switch (SvTYPE(sv)) {
5131 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5135 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5137 return sv_2io(SvRV(sv));
5138 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5144 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5151 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5158 return *gvp = Nullgv, Nullcv;
5159 switch (SvTYPE(sv)) {
5178 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5179 tryAMAGICunDEREF(to_cv);
5182 if (SvTYPE(sv) == SVt_PVCV) {
5191 Perl_croak(aTHX_ "Not a subroutine reference");
5196 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5202 if (lref && !GvCVu(gv)) {
5205 tmpsv = NEWSV(704,0);
5206 gv_efullname3(tmpsv, gv, Nullch);
5207 /* XXX this is probably not what they think they're getting.
5208 * It has the same effect as "sub name;", i.e. just a forward
5210 newSUB(start_subparse(FALSE, 0),
5211 newSVOP(OP_CONST, 0, tmpsv),
5216 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5225 Returns true if the SV has a true value by Perl's rules.
5231 Perl_sv_true(pTHX_ register SV *sv)
5237 if ((tXpv = (XPV*)SvANY(sv)) &&
5238 (tXpv->xpv_cur > 1 ||
5239 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5246 return SvIVX(sv) != 0;
5249 return SvNVX(sv) != 0.0;
5251 return sv_2bool(sv);
5257 Perl_sv_iv(pTHX_ register SV *sv)
5261 return (IV)SvUVX(sv);
5268 Perl_sv_uv(pTHX_ register SV *sv)
5273 return (UV)SvIVX(sv);
5279 Perl_sv_nv(pTHX_ register SV *sv)
5287 Perl_sv_pv(pTHX_ SV *sv)
5294 return sv_2pv(sv, &n_a);
5298 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5304 return sv_2pv(sv, lp);
5308 =for apidoc sv_pvn_force
5310 Get a sensible string out of the SV somehow.
5316 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5320 if (SvTHINKFIRST(sv) && !SvROK(sv))
5321 sv_force_normal(sv);
5327 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5328 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5329 PL_op_name[PL_op->op_type]);
5333 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5338 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5339 SvGROW(sv, len + 1);
5340 Move(s,SvPVX(sv),len,char);
5345 SvPOK_on(sv); /* validate pointer */
5347 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5348 PTR2UV(sv),SvPVX(sv)));
5355 Perl_sv_pvbyte(pTHX_ SV *sv)
5361 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5363 return sv_pvn(sv,lp);
5367 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5369 return sv_pvn_force(sv,lp);
5373 Perl_sv_pvutf8(pTHX_ SV *sv)
5375 sv_utf8_upgrade(sv);
5380 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5382 sv_utf8_upgrade(sv);
5383 return sv_pvn(sv,lp);
5387 =for apidoc sv_pvutf8n_force
5389 Get a sensible UTF8-encoded string out of the SV somehow. See
5396 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5398 sv_utf8_upgrade(sv);
5399 return sv_pvn_force(sv,lp);
5403 =for apidoc sv_reftype
5405 Returns a string describing what the SV is a reference to.
5411 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5413 if (ob && SvOBJECT(sv))
5414 return HvNAME(SvSTASH(sv));
5416 switch (SvTYPE(sv)) {
5430 case SVt_PVLV: return "LVALUE";
5431 case SVt_PVAV: return "ARRAY";
5432 case SVt_PVHV: return "HASH";
5433 case SVt_PVCV: return "CODE";
5434 case SVt_PVGV: return "GLOB";
5435 case SVt_PVFM: return "FORMAT";
5436 case SVt_PVIO: return "IO";
5437 default: return "UNKNOWN";
5443 =for apidoc sv_isobject
5445 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5446 object. If the SV is not an RV, or if the object is not blessed, then this
5453 Perl_sv_isobject(pTHX_ SV *sv)
5470 Returns a boolean indicating whether the SV is blessed into the specified
5471 class. This does not check for subtypes; use C<sv_derived_from> to verify
5472 an inheritance relationship.
5478 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5490 return strEQ(HvNAME(SvSTASH(sv)), name);
5496 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5497 it will be upgraded to one. If C<classname> is non-null then the new SV will
5498 be blessed in the specified package. The new SV is returned and its
5499 reference count is 1.
5505 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5511 SV_CHECK_THINKFIRST(rv);
5514 if (SvTYPE(rv) >= SVt_PVMG) {
5515 U32 refcnt = SvREFCNT(rv);
5519 SvREFCNT(rv) = refcnt;
5522 if (SvTYPE(rv) < SVt_RV)
5523 sv_upgrade(rv, SVt_RV);
5524 else if (SvTYPE(rv) > SVt_RV) {
5525 (void)SvOOK_off(rv);
5526 if (SvPVX(rv) && SvLEN(rv))
5527 Safefree(SvPVX(rv));
5537 HV* stash = gv_stashpv(classname, TRUE);
5538 (void)sv_bless(rv, stash);
5544 =for apidoc sv_setref_pv
5546 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5547 argument will be upgraded to an RV. That RV will be modified to point to
5548 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5549 into the SV. The C<classname> argument indicates the package for the
5550 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5551 will be returned and will have a reference count of 1.
5553 Do not use with other Perl types such as HV, AV, SV, CV, because those
5554 objects will become corrupted by the pointer copy process.
5556 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5562 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5565 sv_setsv(rv, &PL_sv_undef);
5569 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5574 =for apidoc sv_setref_iv
5576 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5577 argument will be upgraded to an RV. That RV will be modified to point to
5578 the new SV. The C<classname> argument indicates the package for the
5579 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5580 will be returned and will have a reference count of 1.
5586 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5588 sv_setiv(newSVrv(rv,classname), iv);
5593 =for apidoc sv_setref_nv
5595 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5596 argument will be upgraded to an RV. That RV will be modified to point to
5597 the new SV. The C<classname> argument indicates the package for the
5598 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5599 will be returned and will have a reference count of 1.
5605 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5607 sv_setnv(newSVrv(rv,classname), nv);
5612 =for apidoc sv_setref_pvn
5614 Copies a string into a new SV, optionally blessing the SV. The length of the
5615 string must be specified with C<n>. The C<rv> argument will be upgraded to
5616 an RV. That RV will be modified to point to the new SV. The C<classname>
5617 argument indicates the package for the blessing. Set C<classname> to
5618 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5619 a reference count of 1.
5621 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5627 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5629 sv_setpvn(newSVrv(rv,classname), pv, n);
5634 =for apidoc sv_bless
5636 Blesses an SV into a specified package. The SV must be an RV. The package
5637 must be designated by its stash (see C<gv_stashpv()>). The reference count
5638 of the SV is unaffected.
5644 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5648 Perl_croak(aTHX_ "Can't bless non-reference value");
5650 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5651 if (SvREADONLY(tmpRef))
5652 Perl_croak(aTHX_ PL_no_modify);
5653 if (SvOBJECT(tmpRef)) {
5654 if (SvTYPE(tmpRef) != SVt_PVIO)
5656 SvREFCNT_dec(SvSTASH(tmpRef));
5659 SvOBJECT_on(tmpRef);
5660 if (SvTYPE(tmpRef) != SVt_PVIO)
5662 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5663 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5674 S_sv_unglob(pTHX_ SV *sv)
5678 assert(SvTYPE(sv) == SVt_PVGV);
5683 SvREFCNT_dec(GvSTASH(sv));
5684 GvSTASH(sv) = Nullhv;
5686 sv_unmagic(sv, '*');
5687 Safefree(GvNAME(sv));
5690 /* need to keep SvANY(sv) in the right arena */
5691 xpvmg = new_XPVMG();
5692 StructCopy(SvANY(sv), xpvmg, XPVMG);
5693 del_XPVGV(SvANY(sv));
5696 SvFLAGS(sv) &= ~SVTYPEMASK;
5697 SvFLAGS(sv) |= SVt_PVMG;
5701 =for apidoc sv_unref_flags
5703 Unsets the RV status of the SV, and decrements the reference count of
5704 whatever was being referenced by the RV. This can almost be thought of
5705 as a reversal of C<newSVrv>. The C<cflags> argument can contain
5706 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
5707 (otherwise the decrementing is conditional on the reference count being
5708 different from one or the reference being a readonly SV).
5715 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
5719 if (SvWEAKREF(sv)) {
5727 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
5729 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
5730 sv_2mortal(rv); /* Schedule for freeing later */
5734 =for apidoc sv_unref
5736 Unsets the RV status of the SV, and decrements the reference count of
5737 whatever was being referenced by the RV. This can almost be thought of
5738 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
5739 being zero. See C<SvROK_off>.
5745 Perl_sv_unref(pTHX_ SV *sv)
5747 sv_unref_flags(sv, 0);
5751 Perl_sv_taint(pTHX_ SV *sv)
5753 sv_magic((sv), Nullsv, 't', Nullch, 0);
5757 Perl_sv_untaint(pTHX_ SV *sv)
5759 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5760 MAGIC *mg = mg_find(sv, 't');
5767 Perl_sv_tainted(pTHX_ SV *sv)
5769 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5770 MAGIC *mg = mg_find(sv, 't');
5771 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5778 =for apidoc sv_setpviv
5780 Copies an integer into the given SV, also updating its string value.
5781 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5787 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5789 char buf[TYPE_CHARS(UV)];
5791 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5793 sv_setpvn(sv, ptr, ebuf - ptr);
5798 =for apidoc sv_setpviv_mg
5800 Like C<sv_setpviv>, but also handles 'set' magic.
5806 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5808 char buf[TYPE_CHARS(UV)];
5810 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5812 sv_setpvn(sv, ptr, ebuf - ptr);
5816 #if defined(PERL_IMPLICIT_CONTEXT)
5818 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5822 va_start(args, pat);
5823 sv_vsetpvf(sv, pat, &args);
5829 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5833 va_start(args, pat);
5834 sv_vsetpvf_mg(sv, pat, &args);
5840 =for apidoc sv_setpvf
5842 Processes its arguments like C<sprintf> and sets an SV to the formatted
5843 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5849 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5852 va_start(args, pat);
5853 sv_vsetpvf(sv, pat, &args);
5858 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5860 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5864 =for apidoc sv_setpvf_mg
5866 Like C<sv_setpvf>, but also handles 'set' magic.
5872 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5875 va_start(args, pat);
5876 sv_vsetpvf_mg(sv, pat, &args);
5881 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5883 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5887 #if defined(PERL_IMPLICIT_CONTEXT)
5889 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5893 va_start(args, pat);
5894 sv_vcatpvf(sv, pat, &args);
5899 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5903 va_start(args, pat);
5904 sv_vcatpvf_mg(sv, pat, &args);
5910 =for apidoc sv_catpvf
5912 Processes its arguments like C<sprintf> and appends the formatted output
5913 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5914 typically be called after calling this function to handle 'set' magic.
5920 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5923 va_start(args, pat);
5924 sv_vcatpvf(sv, pat, &args);
5929 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5931 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5935 =for apidoc sv_catpvf_mg
5937 Like C<sv_catpvf>, but also handles 'set' magic.
5943 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5946 va_start(args, pat);
5947 sv_vcatpvf_mg(sv, pat, &args);
5952 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5954 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5959 =for apidoc sv_vsetpvfn
5961 Works like C<vcatpvfn> but copies the text into the SV instead of
5968 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5970 sv_setpvn(sv, "", 0);
5971 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5975 =for apidoc sv_vcatpvfn
5977 Processes its arguments like C<vsprintf> and appends the formatted output
5978 to an SV. Uses an array of SVs if the C style variable argument list is
5979 missing (NULL). When running with taint checks enabled, indicates via
5980 C<maybe_tainted> if results are untrustworthy (often due to the use of
5987 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5994 static char nullstr[] = "(null)";
5997 /* no matter what, this is a string now */
5998 (void)SvPV_force(sv, origlen);
6000 /* special-case "", "%s", and "%_" */
6003 if (patlen == 2 && pat[0] == '%') {
6007 char *s = va_arg(*args, char*);
6008 sv_catpv(sv, s ? s : nullstr);
6010 else if (svix < svmax) {
6011 sv_catsv(sv, *svargs);
6012 if (DO_UTF8(*svargs))
6018 argsv = va_arg(*args, SV*);
6019 sv_catsv(sv, argsv);
6024 /* See comment on '_' below */
6029 patend = (char*)pat + patlen;
6030 for (p = (char*)pat; p < patend; p = q) {
6033 bool vectorize = FALSE;
6040 bool has_precis = FALSE;
6042 bool is_utf = FALSE;
6045 U8 utf8buf[UTF8_MAXLEN+1];
6046 STRLEN esignlen = 0;
6048 char *eptr = Nullch;
6050 /* Times 4: a decimal digit takes more than 3 binary digits.
6051 * NV_DIG: mantissa takes than many decimal digits.
6052 * Plus 32: Playing safe. */
6053 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6054 /* large enough for "%#.#f" --chip */
6055 /* what about long double NVs? --jhi */
6058 U8 *vecstr = Null(U8*);
6070 STRLEN dotstrlen = 1;
6071 I32 epix = 0; /* explicit parameter index */
6072 I32 ewix = 0; /* explicit width index */
6073 bool asterisk = FALSE;
6075 for (q = p; q < patend && *q != '%'; ++q) ;
6077 sv_catpvn(sv, p, q - p);
6106 case '*': /* printf("%*vX",":",$ipv6addr) */
6111 vecsv = va_arg(*args, SV*);
6112 else if (svix < svmax)
6113 vecsv = svargs[svix++];
6116 dotstr = SvPVx(vecsv,dotstrlen);
6144 case '1': case '2': case '3':
6145 case '4': case '5': case '6':
6146 case '7': case '8': case '9':
6149 width = width * 10 + (*q++ - '0');
6151 if (asterisk && ewix == 0) {
6156 } else if (epix == 0) {
6168 i = va_arg(*args, int);
6170 i = (ewix ? ewix <= svmax : svix < svmax) ?
6171 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6173 width = (i < 0) ? -i : i;
6182 i = va_arg(*args, int);
6184 i = (ewix ? ewix <= svmax : svix < svmax)
6185 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6186 precis = (i < 0) ? 0 : i;
6192 precis = precis * 10 + (*q++ - '0');
6199 vecsv = va_arg(*args, SV*);
6200 vecstr = (U8*)SvPVx(vecsv,veclen);
6201 utf = DO_UTF8(vecsv);
6203 else if (epix ? epix <= svmax : svix < svmax) {
6204 vecsv = svargs[epix ? epix-1 : svix++];
6205 vecstr = (U8*)SvPVx(vecsv,veclen);
6206 utf = DO_UTF8(vecsv);
6217 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6228 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6229 if (*(q + 1) == 'l') { /* lld, llf */
6256 uv = va_arg(*args, int);
6258 uv = (epix ? epix <= svmax : svix < svmax) ?
6259 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6260 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6261 eptr = (char*)utf8buf;
6262 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6274 eptr = va_arg(*args, char*);
6276 #ifdef MACOS_TRADITIONAL
6277 /* On MacOS, %#s format is used for Pascal strings */
6282 elen = strlen(eptr);
6285 elen = sizeof nullstr - 1;
6288 else if (epix ? epix <= svmax : svix < svmax) {
6289 argsv = svargs[epix ? epix-1 : svix++];
6290 eptr = SvPVx(argsv, elen);
6291 if (DO_UTF8(argsv)) {
6292 if (has_precis && precis < elen) {
6294 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6297 if (width) { /* fudge width (can't fudge elen) */
6298 width += elen - sv_len_utf8(argsv);
6307 * The "%_" hack might have to be changed someday,
6308 * if ISO or ANSI decide to use '_' for something.
6309 * So we keep it hidden from users' code.
6313 argsv = va_arg(*args,SV*);
6314 eptr = SvPVx(argsv, elen);
6320 if (has_precis && elen > precis)
6330 uv = PTR2UV(va_arg(*args, void*));
6332 uv = (epix ? epix <= svmax : svix < svmax) ?
6333 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
6353 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
6363 case 'h': iv = (short)va_arg(*args, int); break;
6364 default: iv = va_arg(*args, int); break;
6365 case 'l': iv = va_arg(*args, long); break;
6366 case 'V': iv = va_arg(*args, IV); break;
6368 case 'q': iv = va_arg(*args, Quad_t); break;
6373 iv = (epix ? epix <= svmax : svix < svmax) ?
6374 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6376 case 'h': iv = (short)iv; break;
6378 case 'l': iv = (long)iv; break;
6381 case 'q': iv = (Quad_t)iv; break;
6388 esignbuf[esignlen++] = plus;
6392 esignbuf[esignlen++] = '-';
6436 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
6446 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6447 default: uv = va_arg(*args, unsigned); break;
6448 case 'l': uv = va_arg(*args, unsigned long); break;
6449 case 'V': uv = va_arg(*args, UV); break;
6451 case 'q': uv = va_arg(*args, Quad_t); break;
6456 uv = (epix ? epix <= svmax : svix < svmax) ?
6457 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
6459 case 'h': uv = (unsigned short)uv; break;
6461 case 'l': uv = (unsigned long)uv; break;
6464 case 'q': uv = (Quad_t)uv; break;
6470 eptr = ebuf + sizeof ebuf;
6476 p = (char*)((c == 'X')
6477 ? "0123456789ABCDEF" : "0123456789abcdef");
6483 esignbuf[esignlen++] = '0';
6484 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6490 *--eptr = '0' + dig;
6492 if (alt && *eptr != '0')
6498 *--eptr = '0' + dig;
6501 esignbuf[esignlen++] = '0';
6502 esignbuf[esignlen++] = 'b';
6505 default: /* it had better be ten or less */
6506 #if defined(PERL_Y2KWARN)
6507 if (ckWARN(WARN_Y2K)) {
6509 char *s = SvPV(sv,n);
6510 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6511 && (n == 2 || !isDIGIT(s[n-3])))
6513 Perl_warner(aTHX_ WARN_Y2K,
6514 "Possible Y2K bug: %%%c %s",
6515 c, "format string following '19'");
6521 *--eptr = '0' + dig;
6522 } while (uv /= base);
6525 elen = (ebuf + sizeof ebuf) - eptr;
6528 zeros = precis - elen;
6529 else if (precis == 0 && elen == 1 && *eptr == '0')
6534 /* FLOATING POINT */
6537 c = 'f'; /* maybe %F isn't supported here */
6543 /* This is evil, but floating point is even more evil */
6547 nv = va_arg(*args, NV);
6549 nv = (epix ? epix <= svmax : svix < svmax) ?
6550 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
6553 if (c != 'e' && c != 'E') {
6555 (void)Perl_frexp(nv, &i);
6556 if (i == PERL_INT_MIN)
6557 Perl_die(aTHX_ "panic: frexp");
6559 need = BIT_DIGITS(i);
6561 need += has_precis ? precis : 6; /* known default */
6565 need += 20; /* fudge factor */
6566 if (PL_efloatsize < need) {
6567 Safefree(PL_efloatbuf);
6568 PL_efloatsize = need + 20; /* more fudge */
6569 New(906, PL_efloatbuf, PL_efloatsize, char);
6570 PL_efloatbuf[0] = '\0';
6573 eptr = ebuf + sizeof ebuf;
6576 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
6578 /* Copy the one or more characters in a long double
6579 * format before the 'base' ([efgEFG]) character to
6580 * the format string. */
6581 static char const prifldbl[] = PERL_PRIfldbl;
6582 char const *p = prifldbl + sizeof(prifldbl) - 3;
6583 while (p >= prifldbl) { *--eptr = *p--; }
6588 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6593 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6605 /* No taint. Otherwise we are in the strange situation
6606 * where printf() taints but print($float) doesn't.
6608 (void)sprintf(PL_efloatbuf, eptr, nv);
6610 eptr = PL_efloatbuf;
6611 elen = strlen(PL_efloatbuf);
6618 i = SvCUR(sv) - origlen;
6621 case 'h': *(va_arg(*args, short*)) = i; break;
6622 default: *(va_arg(*args, int*)) = i; break;
6623 case 'l': *(va_arg(*args, long*)) = i; break;
6624 case 'V': *(va_arg(*args, IV*)) = i; break;
6626 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6630 else if (epix ? epix <= svmax : svix < svmax)
6631 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
6632 continue; /* not "break" */
6639 if (!args && ckWARN(WARN_PRINTF) &&
6640 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6641 SV *msg = sv_newmortal();
6642 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6643 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6646 Perl_sv_catpvf(aTHX_ msg,
6647 "\"%%%c\"", c & 0xFF);
6649 Perl_sv_catpvf(aTHX_ msg,
6650 "\"%%\\%03"UVof"\"",
6653 sv_catpv(msg, "end of string");
6654 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6657 /* output mangled stuff ... */
6663 /* ... right here, because formatting flags should not apply */
6664 SvGROW(sv, SvCUR(sv) + elen + 1);
6666 memcpy(p, eptr, elen);
6669 SvCUR(sv) = p - SvPVX(sv);
6670 continue; /* not "break" */
6673 have = esignlen + zeros + elen;
6674 need = (have > width ? have : width);
6677 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6679 if (esignlen && fill == '0') {
6680 for (i = 0; i < esignlen; i++)
6684 memset(p, fill, gap);
6687 if (esignlen && fill != '0') {
6688 for (i = 0; i < esignlen; i++)
6692 for (i = zeros; i; i--)
6696 memcpy(p, eptr, elen);
6700 memset(p, ' ', gap);
6705 memcpy(p, dotstr, dotstrlen);
6709 vectorize = FALSE; /* done iterating over vecstr */
6714 SvCUR(sv) = p - SvPVX(sv);
6722 #if defined(USE_ITHREADS)
6724 #if defined(USE_THREADS)
6725 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6728 #ifndef GpREFCNT_inc
6729 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6733 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6734 #define av_dup(s) (AV*)sv_dup((SV*)s)
6735 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6736 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6737 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6738 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6739 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6740 #define io_dup(s) (IO*)sv_dup((SV*)s)
6741 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6742 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6743 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6744 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6745 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6748 Perl_re_dup(pTHX_ REGEXP *r)
6750 /* XXX fix when pmop->op_pmregexp becomes shared */
6751 return ReREFCNT_inc(r);
6755 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6759 return (PerlIO*)NULL;
6761 /* look for it in the table first */
6762 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6766 /* create anew and remember what it is */
6767 ret = PerlIO_fdupopen(aTHX_ fp);
6768 ptr_table_store(PL_ptr_table, fp, ret);
6773 Perl_dirp_dup(pTHX_ DIR *dp)
6782 Perl_gp_dup(pTHX_ GP *gp)
6787 /* look for it in the table first */
6788 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6792 /* create anew and remember what it is */
6793 Newz(0, ret, 1, GP);
6794 ptr_table_store(PL_ptr_table, gp, ret);
6797 ret->gp_refcnt = 0; /* must be before any other dups! */
6798 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6799 ret->gp_io = io_dup_inc(gp->gp_io);
6800 ret->gp_form = cv_dup_inc(gp->gp_form);
6801 ret->gp_av = av_dup_inc(gp->gp_av);
6802 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6803 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6804 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6805 ret->gp_cvgen = gp->gp_cvgen;
6806 ret->gp_flags = gp->gp_flags;
6807 ret->gp_line = gp->gp_line;
6808 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6813 Perl_mg_dup(pTHX_ MAGIC *mg)
6815 MAGIC *mgret = (MAGIC*)NULL;
6818 return (MAGIC*)NULL;
6819 /* look for it in the table first */
6820 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6824 for (; mg; mg = mg->mg_moremagic) {
6826 Newz(0, nmg, 1, MAGIC);
6830 mgprev->mg_moremagic = nmg;
6831 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6832 nmg->mg_private = mg->mg_private;
6833 nmg->mg_type = mg->mg_type;
6834 nmg->mg_flags = mg->mg_flags;
6835 if (mg->mg_type == 'r') {
6836 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6839 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6840 ? sv_dup_inc(mg->mg_obj)
6841 : sv_dup(mg->mg_obj);
6843 nmg->mg_len = mg->mg_len;
6844 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6845 if (mg->mg_ptr && mg->mg_type != 'g') {
6846 if (mg->mg_len >= 0) {
6847 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6848 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6849 AMT *amtp = (AMT*)mg->mg_ptr;
6850 AMT *namtp = (AMT*)nmg->mg_ptr;
6852 for (i = 1; i < NofAMmeth; i++) {
6853 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6857 else if (mg->mg_len == HEf_SVKEY)
6858 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6866 Perl_ptr_table_new(pTHX)
6869 Newz(0, tbl, 1, PTR_TBL_t);
6872 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6877 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6879 PTR_TBL_ENT_t *tblent;
6880 UV hash = PTR2UV(sv);
6882 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6883 for (; tblent; tblent = tblent->next) {
6884 if (tblent->oldval == sv)
6885 return tblent->newval;
6891 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6893 PTR_TBL_ENT_t *tblent, **otblent;
6894 /* XXX this may be pessimal on platforms where pointers aren't good
6895 * hash values e.g. if they grow faster in the most significant
6897 UV hash = PTR2UV(oldv);
6901 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6902 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6903 if (tblent->oldval == oldv) {
6904 tblent->newval = newv;
6909 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6910 tblent->oldval = oldv;
6911 tblent->newval = newv;
6912 tblent->next = *otblent;
6915 if (i && tbl->tbl_items > tbl->tbl_max)
6916 ptr_table_split(tbl);
6920 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6922 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6923 UV oldsize = tbl->tbl_max + 1;
6924 UV newsize = oldsize * 2;
6927 Renew(ary, newsize, PTR_TBL_ENT_t*);
6928 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6929 tbl->tbl_max = --newsize;
6931 for (i=0; i < oldsize; i++, ary++) {
6932 PTR_TBL_ENT_t **curentp, **entp, *ent;
6935 curentp = ary + oldsize;
6936 for (entp = ary, ent = *ary; ent; ent = *entp) {
6937 if ((newsize & PTR2UV(ent->oldval)) != i) {
6939 ent->next = *curentp;
6954 Perl_sv_dup(pTHX_ SV *sstr)
6958 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6960 /* look for it in the table first */
6961 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6965 /* create anew and remember what it is */
6967 ptr_table_store(PL_ptr_table, sstr, dstr);
6970 SvFLAGS(dstr) = SvFLAGS(sstr);
6971 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6972 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6975 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6976 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6977 PL_watch_pvx, SvPVX(sstr));
6980 switch (SvTYPE(sstr)) {
6985 SvANY(dstr) = new_XIV();
6986 SvIVX(dstr) = SvIVX(sstr);
6989 SvANY(dstr) = new_XNV();
6990 SvNVX(dstr) = SvNVX(sstr);
6993 SvANY(dstr) = new_XRV();
6994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6997 SvANY(dstr) = new_XPV();
6998 SvCUR(dstr) = SvCUR(sstr);
6999 SvLEN(dstr) = SvLEN(sstr);
7001 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7002 else if (SvPVX(sstr) && SvLEN(sstr))
7003 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7005 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7008 SvANY(dstr) = new_XPVIV();
7009 SvCUR(dstr) = SvCUR(sstr);
7010 SvLEN(dstr) = SvLEN(sstr);
7011 SvIVX(dstr) = SvIVX(sstr);
7013 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7014 else if (SvPVX(sstr) && SvLEN(sstr))
7015 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7017 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7020 SvANY(dstr) = new_XPVNV();
7021 SvCUR(dstr) = SvCUR(sstr);
7022 SvLEN(dstr) = SvLEN(sstr);
7023 SvIVX(dstr) = SvIVX(sstr);
7024 SvNVX(dstr) = SvNVX(sstr);
7026 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7027 else if (SvPVX(sstr) && SvLEN(sstr))
7028 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7030 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7033 SvANY(dstr) = new_XPVMG();
7034 SvCUR(dstr) = SvCUR(sstr);
7035 SvLEN(dstr) = SvLEN(sstr);
7036 SvIVX(dstr) = SvIVX(sstr);
7037 SvNVX(dstr) = SvNVX(sstr);
7038 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7039 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7041 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7042 else if (SvPVX(sstr) && SvLEN(sstr))
7043 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7045 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7048 SvANY(dstr) = new_XPVBM();
7049 SvCUR(dstr) = SvCUR(sstr);
7050 SvLEN(dstr) = SvLEN(sstr);
7051 SvIVX(dstr) = SvIVX(sstr);
7052 SvNVX(dstr) = SvNVX(sstr);
7053 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7054 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7056 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7057 else if (SvPVX(sstr) && SvLEN(sstr))
7058 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7060 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7061 BmRARE(dstr) = BmRARE(sstr);
7062 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7063 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7066 SvANY(dstr) = new_XPVLV();
7067 SvCUR(dstr) = SvCUR(sstr);
7068 SvLEN(dstr) = SvLEN(sstr);
7069 SvIVX(dstr) = SvIVX(sstr);
7070 SvNVX(dstr) = SvNVX(sstr);
7071 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7072 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7074 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7075 else if (SvPVX(sstr) && SvLEN(sstr))
7076 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7078 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7079 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7080 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7081 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7082 LvTYPE(dstr) = LvTYPE(sstr);
7085 SvANY(dstr) = new_XPVGV();
7086 SvCUR(dstr) = SvCUR(sstr);
7087 SvLEN(dstr) = SvLEN(sstr);
7088 SvIVX(dstr) = SvIVX(sstr);
7089 SvNVX(dstr) = SvNVX(sstr);
7090 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7091 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7093 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7094 else if (SvPVX(sstr) && SvLEN(sstr))
7095 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7097 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7098 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7099 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7100 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7101 GvFLAGS(dstr) = GvFLAGS(sstr);
7102 GvGP(dstr) = gp_dup(GvGP(sstr));
7103 (void)GpREFCNT_inc(GvGP(dstr));
7106 SvANY(dstr) = new_XPVIO();
7107 SvCUR(dstr) = SvCUR(sstr);
7108 SvLEN(dstr) = SvLEN(sstr);
7109 SvIVX(dstr) = SvIVX(sstr);
7110 SvNVX(dstr) = SvNVX(sstr);
7111 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7112 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7114 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7115 else if (SvPVX(sstr) && SvLEN(sstr))
7116 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7118 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7119 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7120 if (IoOFP(sstr) == IoIFP(sstr))
7121 IoOFP(dstr) = IoIFP(dstr);
7123 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7124 /* PL_rsfp_filters entries have fake IoDIRP() */
7125 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7126 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7128 IoDIRP(dstr) = IoDIRP(sstr);
7129 IoLINES(dstr) = IoLINES(sstr);
7130 IoPAGE(dstr) = IoPAGE(sstr);
7131 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7132 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7133 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7134 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7135 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7136 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7137 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7138 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7139 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7140 IoTYPE(dstr) = IoTYPE(sstr);
7141 IoFLAGS(dstr) = IoFLAGS(sstr);
7144 SvANY(dstr) = new_XPVAV();
7145 SvCUR(dstr) = SvCUR(sstr);
7146 SvLEN(dstr) = SvLEN(sstr);
7147 SvIVX(dstr) = SvIVX(sstr);
7148 SvNVX(dstr) = SvNVX(sstr);
7149 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7150 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7151 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7152 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7153 if (AvARRAY((AV*)sstr)) {
7154 SV **dst_ary, **src_ary;
7155 SSize_t items = AvFILLp((AV*)sstr) + 1;
7157 src_ary = AvARRAY((AV*)sstr);
7158 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7159 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7160 SvPVX(dstr) = (char*)dst_ary;
7161 AvALLOC((AV*)dstr) = dst_ary;
7162 if (AvREAL((AV*)sstr)) {
7164 *dst_ary++ = sv_dup_inc(*src_ary++);
7168 *dst_ary++ = sv_dup(*src_ary++);
7170 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7171 while (items-- > 0) {
7172 *dst_ary++ = &PL_sv_undef;
7176 SvPVX(dstr) = Nullch;
7177 AvALLOC((AV*)dstr) = (SV**)NULL;
7181 SvANY(dstr) = new_XPVHV();
7182 SvCUR(dstr) = SvCUR(sstr);
7183 SvLEN(dstr) = SvLEN(sstr);
7184 SvIVX(dstr) = SvIVX(sstr);
7185 SvNVX(dstr) = SvNVX(sstr);
7186 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7187 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7188 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7189 if (HvARRAY((HV*)sstr)) {
7191 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7192 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7193 Newz(0, dxhv->xhv_array,
7194 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7195 while (i <= sxhv->xhv_max) {
7196 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7197 !!HvSHAREKEYS(sstr));
7200 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7203 SvPVX(dstr) = Nullch;
7204 HvEITER((HV*)dstr) = (HE*)NULL;
7206 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7207 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7210 SvANY(dstr) = new_XPVFM();
7211 FmLINES(dstr) = FmLINES(sstr);
7215 SvANY(dstr) = new_XPVCV();
7217 SvCUR(dstr) = SvCUR(sstr);
7218 SvLEN(dstr) = SvLEN(sstr);
7219 SvIVX(dstr) = SvIVX(sstr);
7220 SvNVX(dstr) = SvNVX(sstr);
7221 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7222 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7223 if (SvPVX(sstr) && SvLEN(sstr))
7224 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7226 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7227 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7228 CvSTART(dstr) = CvSTART(sstr);
7229 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7230 CvXSUB(dstr) = CvXSUB(sstr);
7231 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7232 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7233 CvDEPTH(dstr) = CvDEPTH(sstr);
7234 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7235 /* XXX padlists are real, but pretend to be not */
7236 AvREAL_on(CvPADLIST(sstr));
7237 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7238 AvREAL_off(CvPADLIST(sstr));
7239 AvREAL_off(CvPADLIST(dstr));
7242 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7243 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7244 CvFLAGS(dstr) = CvFLAGS(sstr);
7247 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7251 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7258 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7263 return (PERL_CONTEXT*)NULL;
7265 /* look for it in the table first */
7266 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7270 /* create anew and remember what it is */
7271 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7272 ptr_table_store(PL_ptr_table, cxs, ncxs);
7275 PERL_CONTEXT *cx = &cxs[ix];
7276 PERL_CONTEXT *ncx = &ncxs[ix];
7277 ncx->cx_type = cx->cx_type;
7278 if (CxTYPE(cx) == CXt_SUBST) {
7279 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7282 ncx->blk_oldsp = cx->blk_oldsp;
7283 ncx->blk_oldcop = cx->blk_oldcop;
7284 ncx->blk_oldretsp = cx->blk_oldretsp;
7285 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7286 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7287 ncx->blk_oldpm = cx->blk_oldpm;
7288 ncx->blk_gimme = cx->blk_gimme;
7289 switch (CxTYPE(cx)) {
7291 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7292 ? cv_dup_inc(cx->blk_sub.cv)
7293 : cv_dup(cx->blk_sub.cv));
7294 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7295 ? av_dup_inc(cx->blk_sub.argarray)
7297 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7298 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7299 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7300 ncx->blk_sub.lval = cx->blk_sub.lval;
7303 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7304 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7305 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7306 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7307 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7310 ncx->blk_loop.label = cx->blk_loop.label;
7311 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7312 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7313 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7314 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7315 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7316 ? cx->blk_loop.iterdata
7317 : gv_dup((GV*)cx->blk_loop.iterdata));
7318 ncx->blk_loop.oldcurpad
7319 = (SV**)ptr_table_fetch(PL_ptr_table,
7320 cx->blk_loop.oldcurpad);
7321 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7322 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7323 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7324 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7325 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7328 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7329 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7330 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7331 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7344 Perl_si_dup(pTHX_ PERL_SI *si)
7349 return (PERL_SI*)NULL;
7351 /* look for it in the table first */
7352 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7356 /* create anew and remember what it is */
7357 Newz(56, nsi, 1, PERL_SI);
7358 ptr_table_store(PL_ptr_table, si, nsi);
7360 nsi->si_stack = av_dup_inc(si->si_stack);
7361 nsi->si_cxix = si->si_cxix;
7362 nsi->si_cxmax = si->si_cxmax;
7363 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7364 nsi->si_type = si->si_type;
7365 nsi->si_prev = si_dup(si->si_prev);
7366 nsi->si_next = si_dup(si->si_next);
7367 nsi->si_markoff = si->si_markoff;
7372 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7373 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7374 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7375 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7376 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7377 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7378 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7379 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7380 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7381 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7382 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7383 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7386 #define pv_dup_inc(p) SAVEPV(p)
7387 #define pv_dup(p) SAVEPV(p)
7388 #define svp_dup_inc(p,pp) any_dup(p,pp)
7391 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7398 /* look for it in the table first */
7399 ret = ptr_table_fetch(PL_ptr_table, v);
7403 /* see if it is part of the interpreter structure */
7404 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7405 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7413 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7415 ANY *ss = proto_perl->Tsavestack;
7416 I32 ix = proto_perl->Tsavestack_ix;
7417 I32 max = proto_perl->Tsavestack_max;
7430 void (*dptr) (void*);
7431 void (*dxptr) (pTHXo_ void*);
7434 Newz(54, nss, max, ANY);
7440 case SAVEt_ITEM: /* normal string */
7441 sv = (SV*)POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = sv_dup_inc(sv);
7443 sv = (SV*)POPPTR(ss,ix);
7444 TOPPTR(nss,ix) = sv_dup_inc(sv);
7446 case SAVEt_SV: /* scalar reference */
7447 sv = (SV*)POPPTR(ss,ix);
7448 TOPPTR(nss,ix) = sv_dup_inc(sv);
7449 gv = (GV*)POPPTR(ss,ix);
7450 TOPPTR(nss,ix) = gv_dup_inc(gv);
7452 case SAVEt_GENERIC_PVREF: /* generic char* */
7453 c = (char*)POPPTR(ss,ix);
7454 TOPPTR(nss,ix) = pv_dup(c);
7455 ptr = POPPTR(ss,ix);
7456 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7458 case SAVEt_GENERIC_SVREF: /* generic sv */
7459 case SAVEt_SVREF: /* scalar reference */
7460 sv = (SV*)POPPTR(ss,ix);
7461 TOPPTR(nss,ix) = sv_dup_inc(sv);
7462 ptr = POPPTR(ss,ix);
7463 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7465 case SAVEt_AV: /* array reference */
7466 av = (AV*)POPPTR(ss,ix);
7467 TOPPTR(nss,ix) = av_dup_inc(av);
7468 gv = (GV*)POPPTR(ss,ix);
7469 TOPPTR(nss,ix) = gv_dup(gv);
7471 case SAVEt_HV: /* hash reference */
7472 hv = (HV*)POPPTR(ss,ix);
7473 TOPPTR(nss,ix) = hv_dup_inc(hv);
7474 gv = (GV*)POPPTR(ss,ix);
7475 TOPPTR(nss,ix) = gv_dup(gv);
7477 case SAVEt_INT: /* int reference */
7478 ptr = POPPTR(ss,ix);
7479 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7480 intval = (int)POPINT(ss,ix);
7481 TOPINT(nss,ix) = intval;
7483 case SAVEt_LONG: /* long reference */
7484 ptr = POPPTR(ss,ix);
7485 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7486 longval = (long)POPLONG(ss,ix);
7487 TOPLONG(nss,ix) = longval;
7489 case SAVEt_I32: /* I32 reference */
7490 case SAVEt_I16: /* I16 reference */
7491 case SAVEt_I8: /* I8 reference */
7492 ptr = POPPTR(ss,ix);
7493 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7497 case SAVEt_IV: /* IV reference */
7498 ptr = POPPTR(ss,ix);
7499 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7503 case SAVEt_SPTR: /* SV* reference */
7504 ptr = POPPTR(ss,ix);
7505 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7506 sv = (SV*)POPPTR(ss,ix);
7507 TOPPTR(nss,ix) = sv_dup(sv);
7509 case SAVEt_VPTR: /* random* reference */
7510 ptr = POPPTR(ss,ix);
7511 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7512 ptr = POPPTR(ss,ix);
7513 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7515 case SAVEt_PPTR: /* char* reference */
7516 ptr = POPPTR(ss,ix);
7517 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7518 c = (char*)POPPTR(ss,ix);
7519 TOPPTR(nss,ix) = pv_dup(c);
7521 case SAVEt_HPTR: /* HV* reference */
7522 ptr = POPPTR(ss,ix);
7523 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7524 hv = (HV*)POPPTR(ss,ix);
7525 TOPPTR(nss,ix) = hv_dup(hv);
7527 case SAVEt_APTR: /* AV* reference */
7528 ptr = POPPTR(ss,ix);
7529 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7530 av = (AV*)POPPTR(ss,ix);
7531 TOPPTR(nss,ix) = av_dup(av);
7534 gv = (GV*)POPPTR(ss,ix);
7535 TOPPTR(nss,ix) = gv_dup(gv);
7537 case SAVEt_GP: /* scalar reference */
7538 gp = (GP*)POPPTR(ss,ix);
7539 TOPPTR(nss,ix) = gp = gp_dup(gp);
7540 (void)GpREFCNT_inc(gp);
7541 gv = (GV*)POPPTR(ss,ix);
7542 TOPPTR(nss,ix) = gv_dup_inc(c);
7543 c = (char*)POPPTR(ss,ix);
7544 TOPPTR(nss,ix) = pv_dup(c);
7551 sv = (SV*)POPPTR(ss,ix);
7552 TOPPTR(nss,ix) = sv_dup_inc(sv);
7555 ptr = POPPTR(ss,ix);
7556 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7557 /* these are assumed to be refcounted properly */
7558 switch (((OP*)ptr)->op_type) {
7565 TOPPTR(nss,ix) = ptr;
7570 TOPPTR(nss,ix) = Nullop;
7575 TOPPTR(nss,ix) = Nullop;
7578 c = (char*)POPPTR(ss,ix);
7579 TOPPTR(nss,ix) = pv_dup_inc(c);
7582 longval = POPLONG(ss,ix);
7583 TOPLONG(nss,ix) = longval;
7586 hv = (HV*)POPPTR(ss,ix);
7587 TOPPTR(nss,ix) = hv_dup_inc(hv);
7588 c = (char*)POPPTR(ss,ix);
7589 TOPPTR(nss,ix) = pv_dup_inc(c);
7593 case SAVEt_DESTRUCTOR:
7594 ptr = POPPTR(ss,ix);
7595 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7596 dptr = POPDPTR(ss,ix);
7597 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7599 case SAVEt_DESTRUCTOR_X:
7600 ptr = POPPTR(ss,ix);
7601 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7602 dxptr = POPDXPTR(ss,ix);
7603 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7605 case SAVEt_REGCONTEXT:
7611 case SAVEt_STACK_POS: /* Position on Perl stack */
7615 case SAVEt_AELEM: /* array element */
7616 sv = (SV*)POPPTR(ss,ix);
7617 TOPPTR(nss,ix) = sv_dup_inc(sv);
7620 av = (AV*)POPPTR(ss,ix);
7621 TOPPTR(nss,ix) = av_dup_inc(av);
7623 case SAVEt_HELEM: /* hash element */
7624 sv = (SV*)POPPTR(ss,ix);
7625 TOPPTR(nss,ix) = sv_dup_inc(sv);
7626 sv = (SV*)POPPTR(ss,ix);
7627 TOPPTR(nss,ix) = sv_dup_inc(sv);
7628 hv = (HV*)POPPTR(ss,ix);
7629 TOPPTR(nss,ix) = hv_dup_inc(hv);
7632 ptr = POPPTR(ss,ix);
7633 TOPPTR(nss,ix) = ptr;
7640 av = (AV*)POPPTR(ss,ix);
7641 TOPPTR(nss,ix) = av_dup(av);
7644 longval = (long)POPLONG(ss,ix);
7645 TOPLONG(nss,ix) = longval;
7646 ptr = POPPTR(ss,ix);
7647 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7648 sv = (SV*)POPPTR(ss,ix);
7649 TOPPTR(nss,ix) = sv_dup(sv);
7652 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7664 perl_clone(PerlInterpreter *proto_perl, UV flags)
7667 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7670 #ifdef PERL_IMPLICIT_SYS
7671 return perl_clone_using(proto_perl, flags,
7673 proto_perl->IMemShared,
7674 proto_perl->IMemParse,
7684 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7685 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7686 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7687 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7688 struct IPerlDir* ipD, struct IPerlSock* ipS,
7689 struct IPerlProc* ipP)
7691 /* XXX many of the string copies here can be optimized if they're
7692 * constants; they need to be allocated as common memory and just
7693 * their pointers copied. */
7697 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7699 PERL_SET_THX(pPerl);
7700 # else /* !PERL_OBJECT */
7701 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7702 PERL_SET_THX(my_perl);
7705 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7710 # else /* !DEBUGGING */
7711 Zero(my_perl, 1, PerlInterpreter);
7712 # endif /* DEBUGGING */
7716 PL_MemShared = ipMS;
7724 # endif /* PERL_OBJECT */
7725 #else /* !PERL_IMPLICIT_SYS */
7727 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7728 PERL_SET_THX(my_perl);
7731 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7736 # else /* !DEBUGGING */
7737 Zero(my_perl, 1, PerlInterpreter);
7738 # endif /* DEBUGGING */
7739 #endif /* PERL_IMPLICIT_SYS */
7742 PL_xiv_arenaroot = NULL;
7744 PL_xnv_arenaroot = NULL;
7746 PL_xrv_arenaroot = NULL;
7748 PL_xpv_arenaroot = NULL;
7750 PL_xpviv_arenaroot = NULL;
7751 PL_xpviv_root = NULL;
7752 PL_xpvnv_arenaroot = NULL;
7753 PL_xpvnv_root = NULL;
7754 PL_xpvcv_arenaroot = NULL;
7755 PL_xpvcv_root = NULL;
7756 PL_xpvav_arenaroot = NULL;
7757 PL_xpvav_root = NULL;
7758 PL_xpvhv_arenaroot = NULL;
7759 PL_xpvhv_root = NULL;
7760 PL_xpvmg_arenaroot = NULL;
7761 PL_xpvmg_root = NULL;
7762 PL_xpvlv_arenaroot = NULL;
7763 PL_xpvlv_root = NULL;
7764 PL_xpvbm_arenaroot = NULL;
7765 PL_xpvbm_root = NULL;
7766 PL_he_arenaroot = NULL;
7768 PL_nice_chunk = NULL;
7769 PL_nice_chunk_size = 0;
7772 PL_sv_root = Nullsv;
7773 PL_sv_arenaroot = Nullsv;
7775 PL_debug = proto_perl->Idebug;
7777 /* create SV map for pointer relocation */
7778 PL_ptr_table = ptr_table_new();
7780 /* initialize these special pointers as early as possible */
7781 SvANY(&PL_sv_undef) = NULL;
7782 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7783 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7784 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7787 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7789 SvANY(&PL_sv_no) = new_XPVNV();
7791 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7792 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7793 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7794 SvCUR(&PL_sv_no) = 0;
7795 SvLEN(&PL_sv_no) = 1;
7796 SvNVX(&PL_sv_no) = 0;
7797 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7800 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7802 SvANY(&PL_sv_yes) = new_XPVNV();
7804 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7805 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7806 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7807 SvCUR(&PL_sv_yes) = 1;
7808 SvLEN(&PL_sv_yes) = 2;
7809 SvNVX(&PL_sv_yes) = 1;
7810 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7812 /* create shared string table */
7813 PL_strtab = newHV();
7814 HvSHAREKEYS_off(PL_strtab);
7815 hv_ksplit(PL_strtab, 512);
7816 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7818 PL_compiling = proto_perl->Icompiling;
7819 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7820 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7821 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7822 if (!specialWARN(PL_compiling.cop_warnings))
7823 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7824 if (!specialCopIO(PL_compiling.cop_io))
7825 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
7826 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7828 /* pseudo environmental stuff */
7829 PL_origargc = proto_perl->Iorigargc;
7831 New(0, PL_origargv, i+1, char*);
7832 PL_origargv[i] = '\0';
7834 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7836 PL_envgv = gv_dup(proto_perl->Ienvgv);
7837 PL_incgv = gv_dup(proto_perl->Iincgv);
7838 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7839 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7840 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7841 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7844 PL_minus_c = proto_perl->Iminus_c;
7845 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7846 PL_localpatches = proto_perl->Ilocalpatches;
7847 PL_splitstr = proto_perl->Isplitstr;
7848 PL_preprocess = proto_perl->Ipreprocess;
7849 PL_minus_n = proto_perl->Iminus_n;
7850 PL_minus_p = proto_perl->Iminus_p;
7851 PL_minus_l = proto_perl->Iminus_l;
7852 PL_minus_a = proto_perl->Iminus_a;
7853 PL_minus_F = proto_perl->Iminus_F;
7854 PL_doswitches = proto_perl->Idoswitches;
7855 PL_dowarn = proto_perl->Idowarn;
7856 PL_doextract = proto_perl->Idoextract;
7857 PL_sawampersand = proto_perl->Isawampersand;
7858 PL_unsafe = proto_perl->Iunsafe;
7859 PL_inplace = SAVEPV(proto_perl->Iinplace);
7860 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7861 PL_perldb = proto_perl->Iperldb;
7862 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7864 /* magical thingies */
7865 /* XXX time(&PL_basetime) when asked for? */
7866 PL_basetime = proto_perl->Ibasetime;
7867 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7869 PL_maxsysfd = proto_perl->Imaxsysfd;
7870 PL_multiline = proto_perl->Imultiline;
7871 PL_statusvalue = proto_perl->Istatusvalue;
7873 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7876 /* shortcuts to various I/O objects */
7877 PL_stdingv = gv_dup(proto_perl->Istdingv);
7878 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7879 PL_defgv = gv_dup(proto_perl->Idefgv);
7880 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7881 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7882 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7884 /* shortcuts to regexp stuff */
7885 PL_replgv = gv_dup(proto_perl->Ireplgv);
7887 /* shortcuts to misc objects */
7888 PL_errgv = gv_dup(proto_perl->Ierrgv);
7890 /* shortcuts to debugging objects */
7891 PL_DBgv = gv_dup(proto_perl->IDBgv);
7892 PL_DBline = gv_dup(proto_perl->IDBline);
7893 PL_DBsub = gv_dup(proto_perl->IDBsub);
7894 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7895 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7896 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7897 PL_lineary = av_dup(proto_perl->Ilineary);
7898 PL_dbargs = av_dup(proto_perl->Idbargs);
7901 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7902 PL_curstash = hv_dup(proto_perl->Tcurstash);
7903 PL_debstash = hv_dup(proto_perl->Idebstash);
7904 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7905 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7907 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7908 PL_endav = av_dup_inc(proto_perl->Iendav);
7909 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7910 PL_initav = av_dup_inc(proto_perl->Iinitav);
7912 PL_sub_generation = proto_perl->Isub_generation;
7914 /* funky return mechanisms */
7915 PL_forkprocess = proto_perl->Iforkprocess;
7917 /* subprocess state */
7918 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7920 /* internal state */
7921 PL_tainting = proto_perl->Itainting;
7922 PL_maxo = proto_perl->Imaxo;
7923 if (proto_perl->Iop_mask)
7924 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7926 PL_op_mask = Nullch;
7928 /* current interpreter roots */
7929 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7930 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7931 PL_main_start = proto_perl->Imain_start;
7932 PL_eval_root = proto_perl->Ieval_root;
7933 PL_eval_start = proto_perl->Ieval_start;
7935 /* runtime control stuff */
7936 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7937 PL_copline = proto_perl->Icopline;
7939 PL_filemode = proto_perl->Ifilemode;
7940 PL_lastfd = proto_perl->Ilastfd;
7941 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7944 PL_gensym = proto_perl->Igensym;
7945 PL_preambled = proto_perl->Ipreambled;
7946 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7947 PL_laststatval = proto_perl->Ilaststatval;
7948 PL_laststype = proto_perl->Ilaststype;
7949 PL_mess_sv = Nullsv;
7951 PL_orslen = proto_perl->Iorslen;
7952 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7953 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7955 /* interpreter atexit processing */
7956 PL_exitlistlen = proto_perl->Iexitlistlen;
7957 if (PL_exitlistlen) {
7958 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7959 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7962 PL_exitlist = (PerlExitListEntry*)NULL;
7963 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7965 PL_profiledata = NULL;
7966 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7967 /* PL_rsfp_filters entries have fake IoDIRP() */
7968 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7970 PL_compcv = cv_dup(proto_perl->Icompcv);
7971 PL_comppad = av_dup(proto_perl->Icomppad);
7972 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7973 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7974 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7975 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7976 proto_perl->Tcurpad);
7978 #ifdef HAVE_INTERP_INTERN
7979 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7982 /* more statics moved here */
7983 PL_generation = proto_perl->Igeneration;
7984 PL_DBcv = cv_dup(proto_perl->IDBcv);
7986 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7987 PL_in_clean_all = proto_perl->Iin_clean_all;
7989 PL_uid = proto_perl->Iuid;
7990 PL_euid = proto_perl->Ieuid;
7991 PL_gid = proto_perl->Igid;
7992 PL_egid = proto_perl->Iegid;
7993 PL_nomemok = proto_perl->Inomemok;
7994 PL_an = proto_perl->Ian;
7995 PL_cop_seqmax = proto_perl->Icop_seqmax;
7996 PL_op_seqmax = proto_perl->Iop_seqmax;
7997 PL_evalseq = proto_perl->Ievalseq;
7998 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7999 PL_origalen = proto_perl->Iorigalen;
8000 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8001 PL_osname = SAVEPV(proto_perl->Iosname);
8002 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8003 PL_sighandlerp = proto_perl->Isighandlerp;
8006 PL_runops = proto_perl->Irunops;
8008 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8011 PL_cshlen = proto_perl->Icshlen;
8012 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8015 PL_lex_state = proto_perl->Ilex_state;
8016 PL_lex_defer = proto_perl->Ilex_defer;
8017 PL_lex_expect = proto_perl->Ilex_expect;
8018 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8019 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8020 PL_lex_starts = proto_perl->Ilex_starts;
8021 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8022 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8023 PL_lex_op = proto_perl->Ilex_op;
8024 PL_lex_inpat = proto_perl->Ilex_inpat;
8025 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8026 PL_lex_brackets = proto_perl->Ilex_brackets;
8027 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8028 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8029 PL_lex_casemods = proto_perl->Ilex_casemods;
8030 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8031 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8033 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8034 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8035 PL_nexttoke = proto_perl->Inexttoke;
8037 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8038 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8039 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8040 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8041 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8042 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8043 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8044 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8045 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8046 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8047 PL_pending_ident = proto_perl->Ipending_ident;
8048 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8050 PL_expect = proto_perl->Iexpect;
8052 PL_multi_start = proto_perl->Imulti_start;
8053 PL_multi_end = proto_perl->Imulti_end;
8054 PL_multi_open = proto_perl->Imulti_open;
8055 PL_multi_close = proto_perl->Imulti_close;
8057 PL_error_count = proto_perl->Ierror_count;
8058 PL_subline = proto_perl->Isubline;
8059 PL_subname = sv_dup_inc(proto_perl->Isubname);
8061 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8062 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8063 PL_padix = proto_perl->Ipadix;
8064 PL_padix_floor = proto_perl->Ipadix_floor;
8065 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8067 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8068 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8069 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8070 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8071 PL_last_lop_op = proto_perl->Ilast_lop_op;
8072 PL_in_my = proto_perl->Iin_my;
8073 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8075 PL_cryptseen = proto_perl->Icryptseen;
8078 PL_hints = proto_perl->Ihints;
8080 PL_amagic_generation = proto_perl->Iamagic_generation;
8082 #ifdef USE_LOCALE_COLLATE
8083 PL_collation_ix = proto_perl->Icollation_ix;
8084 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8085 PL_collation_standard = proto_perl->Icollation_standard;
8086 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8087 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8088 #endif /* USE_LOCALE_COLLATE */
8090 #ifdef USE_LOCALE_NUMERIC
8091 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8092 PL_numeric_standard = proto_perl->Inumeric_standard;
8093 PL_numeric_local = proto_perl->Inumeric_local;
8094 PL_numeric_radix = proto_perl->Inumeric_radix;
8095 #endif /* !USE_LOCALE_NUMERIC */
8097 /* utf8 character classes */
8098 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8099 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8100 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8101 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8102 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8103 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8104 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8105 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8106 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8107 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8108 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8109 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8110 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8111 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8112 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8113 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8114 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8117 PL_last_swash_hv = Nullhv; /* reinits on demand */
8118 PL_last_swash_klen = 0;
8119 PL_last_swash_key[0]= '\0';
8120 PL_last_swash_tmps = (U8*)NULL;
8121 PL_last_swash_slen = 0;
8123 /* perly.c globals */
8124 PL_yydebug = proto_perl->Iyydebug;
8125 PL_yynerrs = proto_perl->Iyynerrs;
8126 PL_yyerrflag = proto_perl->Iyyerrflag;
8127 PL_yychar = proto_perl->Iyychar;
8128 PL_yyval = proto_perl->Iyyval;
8129 PL_yylval = proto_perl->Iyylval;
8131 PL_glob_index = proto_perl->Iglob_index;
8132 PL_srand_called = proto_perl->Isrand_called;
8133 PL_uudmap['M'] = 0; /* reinits on demand */
8134 PL_bitcount = Nullch; /* reinits on demand */
8136 if (proto_perl->Ipsig_ptr) {
8137 int sig_num[] = { SIG_NUM };
8138 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8139 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8140 for (i = 1; PL_sig_name[i]; i++) {
8141 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8142 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8146 PL_psig_ptr = (SV**)NULL;
8147 PL_psig_name = (SV**)NULL;
8150 /* thrdvar.h stuff */
8153 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8154 PL_tmps_ix = proto_perl->Ttmps_ix;
8155 PL_tmps_max = proto_perl->Ttmps_max;
8156 PL_tmps_floor = proto_perl->Ttmps_floor;
8157 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8159 while (i <= PL_tmps_ix) {
8160 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8164 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8165 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8166 Newz(54, PL_markstack, i, I32);
8167 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8168 - proto_perl->Tmarkstack);
8169 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8170 - proto_perl->Tmarkstack);
8171 Copy(proto_perl->Tmarkstack, PL_markstack,
8172 PL_markstack_ptr - PL_markstack + 1, I32);
8174 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8175 * NOTE: unlike the others! */
8176 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8177 PL_scopestack_max = proto_perl->Tscopestack_max;
8178 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8179 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8181 /* next push_return() sets PL_retstack[PL_retstack_ix]
8182 * NOTE: unlike the others! */
8183 PL_retstack_ix = proto_perl->Tretstack_ix;
8184 PL_retstack_max = proto_perl->Tretstack_max;
8185 Newz(54, PL_retstack, PL_retstack_max, OP*);
8186 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8188 /* NOTE: si_dup() looks at PL_markstack */
8189 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8191 /* PL_curstack = PL_curstackinfo->si_stack; */
8192 PL_curstack = av_dup(proto_perl->Tcurstack);
8193 PL_mainstack = av_dup(proto_perl->Tmainstack);
8195 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8196 PL_stack_base = AvARRAY(PL_curstack);
8197 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8198 - proto_perl->Tstack_base);
8199 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8201 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8202 * NOTE: unlike the others! */
8203 PL_savestack_ix = proto_perl->Tsavestack_ix;
8204 PL_savestack_max = proto_perl->Tsavestack_max;
8205 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8206 PL_savestack = ss_dup(proto_perl);
8210 ENTER; /* perl_destruct() wants to LEAVE; */
8213 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8214 PL_top_env = &PL_start_env;
8216 PL_op = proto_perl->Top;
8219 PL_Xpv = (XPV*)NULL;
8220 PL_na = proto_perl->Tna;
8222 PL_statbuf = proto_perl->Tstatbuf;
8223 PL_statcache = proto_perl->Tstatcache;
8224 PL_statgv = gv_dup(proto_perl->Tstatgv);
8225 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8227 PL_timesbuf = proto_perl->Ttimesbuf;
8230 PL_tainted = proto_perl->Ttainted;
8231 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8232 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8233 PL_rs = sv_dup_inc(proto_perl->Trs);
8234 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8235 PL_ofslen = proto_perl->Tofslen;
8236 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8237 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8238 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8239 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8240 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8241 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8243 PL_restartop = proto_perl->Trestartop;
8244 PL_in_eval = proto_perl->Tin_eval;
8245 PL_delaymagic = proto_perl->Tdelaymagic;
8246 PL_dirty = proto_perl->Tdirty;
8247 PL_localizing = proto_perl->Tlocalizing;
8249 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8250 PL_protect = proto_perl->Tprotect;
8252 PL_errors = sv_dup_inc(proto_perl->Terrors);
8253 PL_av_fetch_sv = Nullsv;
8254 PL_hv_fetch_sv = Nullsv;
8255 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8256 PL_modcount = proto_perl->Tmodcount;
8257 PL_lastgotoprobe = Nullop;
8258 PL_dumpindent = proto_perl->Tdumpindent;
8260 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8261 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8262 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8263 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8264 PL_sortcxix = proto_perl->Tsortcxix;
8265 PL_efloatbuf = Nullch; /* reinits on demand */
8266 PL_efloatsize = 0; /* reinits on demand */
8270 PL_screamfirst = NULL;
8271 PL_screamnext = NULL;
8272 PL_maxscream = -1; /* reinits on demand */
8273 PL_lastscream = Nullsv;
8275 PL_watchaddr = NULL;
8276 PL_watchok = Nullch;
8278 PL_regdummy = proto_perl->Tregdummy;
8279 PL_regcomp_parse = Nullch;
8280 PL_regxend = Nullch;
8281 PL_regcode = (regnode*)NULL;
8284 PL_regprecomp = Nullch;
8289 PL_seen_zerolen = 0;
8291 PL_regcomp_rx = (regexp*)NULL;
8293 PL_colorset = 0; /* reinits PL_colors[] */
8294 /*PL_colors[6] = {0,0,0,0,0,0};*/
8295 PL_reg_whilem_seen = 0;
8296 PL_reginput = Nullch;
8299 PL_regstartp = (I32*)NULL;
8300 PL_regendp = (I32*)NULL;
8301 PL_reglastparen = (U32*)NULL;
8302 PL_regtill = Nullch;
8304 PL_reg_start_tmp = (char**)NULL;
8305 PL_reg_start_tmpl = 0;
8306 PL_regdata = (struct reg_data*)NULL;
8309 PL_reg_eval_set = 0;
8311 PL_regprogram = (regnode*)NULL;
8313 PL_regcc = (CURCUR*)NULL;
8314 PL_reg_call_cc = (struct re_cc_state*)NULL;
8315 PL_reg_re = (regexp*)NULL;
8316 PL_reg_ganch = Nullch;
8318 PL_reg_magic = (MAGIC*)NULL;
8320 PL_reg_oldcurpm = (PMOP*)NULL;
8321 PL_reg_curpm = (PMOP*)NULL;
8322 PL_reg_oldsaved = Nullch;
8323 PL_reg_oldsavedlen = 0;
8325 PL_reg_leftiter = 0;
8326 PL_reg_poscache = Nullch;
8327 PL_reg_poscache_size= 0;
8329 /* RE engine - function pointers */
8330 PL_regcompp = proto_perl->Tregcompp;
8331 PL_regexecp = proto_perl->Tregexecp;
8332 PL_regint_start = proto_perl->Tregint_start;
8333 PL_regint_string = proto_perl->Tregint_string;
8334 PL_regfree = proto_perl->Tregfree;
8336 PL_reginterp_cnt = 0;
8337 PL_reg_starttry = 0;
8340 return (PerlInterpreter*)pPerl;
8346 #else /* !USE_ITHREADS */
8352 #endif /* USE_ITHREADS */
8355 do_report_used(pTHXo_ SV *sv)
8357 if (SvTYPE(sv) != SVTYPEMASK) {
8358 PerlIO_printf(Perl_debug_log, "****\n");
8364 do_clean_objs(pTHXo_ SV *sv)
8368 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8369 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8370 if (SvWEAKREF(sv)) {
8381 /* XXX Might want to check arrays, etc. */
8384 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8386 do_clean_named_objs(pTHXo_ SV *sv)
8388 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8389 if ( SvOBJECT(GvSV(sv)) ||
8390 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8391 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8392 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8393 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8395 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8403 do_clean_all(pTHXo_ SV *sv)
8405 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8406 SvFLAGS(sv) |= SVf_BREAK;