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 (SvTYPE(sv) == mt)
922 switch (SvTYPE(sv)) {
943 else if (mt < SVt_PVIV)
960 pv = (char*)SvRV(sv);
980 else if (mt == SVt_NV)
984 if (SvREADONLY(sv) && SvFAKE(sv)) {
994 del_XPVIV(SvANY(sv));
1004 del_XPVNV(SvANY(sv));
1012 magic = SvMAGIC(sv);
1013 stash = SvSTASH(sv);
1014 del_XPVMG(SvANY(sv));
1017 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1022 Perl_croak(aTHX_ "Can't upgrade to undef");
1024 SvANY(sv) = new_XIV();
1028 SvANY(sv) = new_XNV();
1032 SvANY(sv) = new_XRV();
1036 SvANY(sv) = new_XPV();
1042 SvANY(sv) = new_XPVIV();
1052 SvANY(sv) = new_XPVNV();
1060 SvANY(sv) = new_XPVMG();
1066 SvMAGIC(sv) = magic;
1067 SvSTASH(sv) = stash;
1070 SvANY(sv) = new_XPVLV();
1076 SvMAGIC(sv) = magic;
1077 SvSTASH(sv) = stash;
1084 SvANY(sv) = new_XPVAV();
1092 SvMAGIC(sv) = magic;
1093 SvSTASH(sv) = stash;
1099 SvANY(sv) = new_XPVHV();
1107 SvMAGIC(sv) = magic;
1108 SvSTASH(sv) = stash;
1115 SvANY(sv) = new_XPVCV();
1116 Zero(SvANY(sv), 1, XPVCV);
1122 SvMAGIC(sv) = magic;
1123 SvSTASH(sv) = stash;
1126 SvANY(sv) = new_XPVGV();
1132 SvMAGIC(sv) = magic;
1133 SvSTASH(sv) = stash;
1141 SvANY(sv) = new_XPVBM();
1147 SvMAGIC(sv) = magic;
1148 SvSTASH(sv) = stash;
1154 SvANY(sv) = new_XPVFM();
1155 Zero(SvANY(sv), 1, XPVFM);
1161 SvMAGIC(sv) = magic;
1162 SvSTASH(sv) = stash;
1165 SvANY(sv) = new_XPVIO();
1166 Zero(SvANY(sv), 1, XPVIO);
1172 SvMAGIC(sv) = magic;
1173 SvSTASH(sv) = stash;
1174 IoPAGE_LEN(sv) = 60;
1177 SvFLAGS(sv) &= ~SVTYPEMASK;
1183 Perl_sv_backoff(pTHX_ register SV *sv)
1187 char *s = SvPVX(sv);
1188 SvLEN(sv) += SvIVX(sv);
1189 SvPVX(sv) -= SvIVX(sv);
1191 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1193 SvFLAGS(sv) &= ~SVf_OOK;
1200 Expands the character buffer in the SV. This will use C<sv_unref> and will
1201 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1208 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1212 #ifdef HAS_64K_LIMIT
1213 if (newlen >= 0x10000) {
1214 PerlIO_printf(Perl_debug_log,
1215 "Allocation too large: %"UVxf"\n", (UV)newlen);
1218 #endif /* HAS_64K_LIMIT */
1221 if (SvTYPE(sv) < SVt_PV) {
1222 sv_upgrade(sv, SVt_PV);
1225 else if (SvOOK(sv)) { /* pv is offset? */
1228 if (newlen > SvLEN(sv))
1229 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1230 #ifdef HAS_64K_LIMIT
1231 if (newlen >= 0x10000)
1237 if (newlen > SvLEN(sv)) { /* need more room? */
1238 if (SvLEN(sv) && s) {
1239 #if defined(MYMALLOC) && !defined(LEAKTEST)
1240 STRLEN l = malloced_size((void*)SvPVX(sv));
1246 Renew(s,newlen,char);
1249 New(703,s,newlen,char);
1251 SvLEN_set(sv, newlen);
1257 =for apidoc sv_setiv
1259 Copies an integer into the given SV. Does not handle 'set' magic. See
1266 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1268 SV_CHECK_THINKFIRST(sv);
1269 switch (SvTYPE(sv)) {
1271 sv_upgrade(sv, SVt_IV);
1274 sv_upgrade(sv, SVt_PVNV);
1278 sv_upgrade(sv, SVt_PVIV);
1289 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1290 PL_op_desc[PL_op->op_type]);
1293 (void)SvIOK_only(sv); /* validate number */
1299 =for apidoc sv_setiv_mg
1301 Like C<sv_setiv>, but also handles 'set' magic.
1307 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1314 =for apidoc sv_setuv
1316 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1323 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1331 =for apidoc sv_setuv_mg
1333 Like C<sv_setuv>, but also handles 'set' magic.
1339 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1346 =for apidoc sv_setnv
1348 Copies a double into the given SV. Does not handle 'set' magic. See
1355 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1357 SV_CHECK_THINKFIRST(sv);
1358 switch (SvTYPE(sv)) {
1361 sv_upgrade(sv, SVt_NV);
1366 sv_upgrade(sv, SVt_PVNV);
1377 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1378 PL_op_name[PL_op->op_type]);
1382 (void)SvNOK_only(sv); /* validate number */
1387 =for apidoc sv_setnv_mg
1389 Like C<sv_setnv>, but also handles 'set' magic.
1395 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1402 S_not_a_number(pTHX_ SV *sv)
1408 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1409 /* each *s can expand to 4 chars + "...\0",
1410 i.e. need room for 8 chars */
1412 for (s = SvPVX(sv); *s && d < limit; s++) {
1414 if (ch & 128 && !isPRINT_LC(ch)) {
1423 else if (ch == '\r') {
1427 else if (ch == '\f') {
1431 else if (ch == '\\') {
1435 else if (isPRINT_LC(ch))
1450 Perl_warner(aTHX_ WARN_NUMERIC,
1451 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1452 PL_op_desc[PL_op->op_type]);
1454 Perl_warner(aTHX_ WARN_NUMERIC,
1455 "Argument \"%s\" isn't numeric", tmpbuf);
1458 /* the number can be converted to integer with atol() or atoll() */
1459 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1460 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1461 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1462 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1463 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1465 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1466 until proven guilty, assume that things are not that bad... */
1469 Perl_sv_2iv(pTHX_ register SV *sv)
1473 if (SvGMAGICAL(sv)) {
1478 return I_V(SvNVX(sv));
1480 if (SvPOKp(sv) && SvLEN(sv))
1483 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1485 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1491 if (SvTHINKFIRST(sv)) {
1494 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1495 (SvRV(tmpstr) != SvRV(sv)))
1496 return SvIV(tmpstr);
1497 return PTR2IV(SvRV(sv));
1499 if (SvREADONLY(sv) && !SvOK(sv)) {
1501 if (ckWARN(WARN_UNINITIALIZED))
1508 return (IV)(SvUVX(sv));
1515 /* We can cache the IV/UV value even if it not good enough
1516 * to reconstruct NV, since the conversion to PV will prefer
1520 if (SvTYPE(sv) == SVt_NV)
1521 sv_upgrade(sv, SVt_PVNV);
1524 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1525 SvIVX(sv) = I_V(SvNVX(sv));
1527 SvUVX(sv) = U_V(SvNVX(sv));
1530 DEBUG_c(PerlIO_printf(Perl_debug_log,
1531 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1535 return (IV)SvUVX(sv);
1538 else if (SvPOKp(sv) && SvLEN(sv)) {
1539 I32 numtype = looks_like_number(sv);
1541 /* We want to avoid a possible problem when we cache an IV which
1542 may be later translated to an NV, and the resulting NV is not
1543 the translation of the initial data.
1545 This means that if we cache such an IV, we need to cache the
1546 NV as well. Moreover, we trade speed for space, and do not
1547 cache the NV if not needed.
1549 if (numtype & IS_NUMBER_NOT_IV) {
1550 /* May be not an integer. Need to cache NV if we cache IV
1551 * - otherwise future conversion to NV will be wrong. */
1554 d = Atof(SvPVX(sv));
1556 if (SvTYPE(sv) < SVt_PVNV)
1557 sv_upgrade(sv, SVt_PVNV);
1561 #if defined(USE_LONG_DOUBLE)
1562 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1563 PTR2UV(sv), SvNVX(sv)));
1565 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1566 PTR2UV(sv), SvNVX(sv)));
1568 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1569 SvIVX(sv) = I_V(SvNVX(sv));
1571 SvUVX(sv) = U_V(SvNVX(sv));
1576 else { /* The NV may be reconstructed from IV - safe to cache IV,
1577 which may be calculated by atol(). */
1578 if (SvTYPE(sv) < SVt_PVIV)
1579 sv_upgrade(sv, SVt_PVIV);
1581 SvIVX(sv) = Atol(SvPVX(sv));
1582 if (! numtype && ckWARN(WARN_NUMERIC))
1588 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1590 if (SvTYPE(sv) < SVt_IV)
1591 /* Typically the caller expects that sv_any is not NULL now. */
1592 sv_upgrade(sv, SVt_IV);
1595 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1596 PTR2UV(sv),SvIVX(sv)));
1597 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1601 Perl_sv_2uv(pTHX_ register SV *sv)
1605 if (SvGMAGICAL(sv)) {
1610 return U_V(SvNVX(sv));
1611 if (SvPOKp(sv) && SvLEN(sv))
1614 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1616 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1622 if (SvTHINKFIRST(sv)) {
1625 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1626 (SvRV(tmpstr) != SvRV(sv)))
1627 return SvUV(tmpstr);
1628 return PTR2UV(SvRV(sv));
1630 if (SvREADONLY(sv) && !SvOK(sv)) {
1632 if (ckWARN(WARN_UNINITIALIZED))
1642 return (UV)SvIVX(sv);
1646 /* We can cache the IV/UV value even if it not good enough
1647 * to reconstruct NV, since the conversion to PV will prefer
1650 if (SvTYPE(sv) == SVt_NV)
1651 sv_upgrade(sv, SVt_PVNV);
1653 if (SvNVX(sv) >= -0.5) {
1655 SvUVX(sv) = U_V(SvNVX(sv));
1658 SvIVX(sv) = I_V(SvNVX(sv));
1660 DEBUG_c(PerlIO_printf(Perl_debug_log,
1661 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1664 (IV)(UV)SvIVX(sv)));
1665 return (UV)SvIVX(sv);
1668 else if (SvPOKp(sv) && SvLEN(sv)) {
1669 I32 numtype = looks_like_number(sv);
1671 /* We want to avoid a possible problem when we cache a UV which
1672 may be later translated to an NV, and the resulting NV is not
1673 the translation of the initial data.
1675 This means that if we cache such a UV, we need to cache the
1676 NV as well. Moreover, we trade speed for space, and do not
1677 cache the NV if not needed.
1679 if (numtype & IS_NUMBER_NOT_IV) {
1680 /* May be not an integer. Need to cache NV if we cache IV
1681 * - otherwise future conversion to NV will be wrong. */
1684 d = Atof(SvPVX(sv));
1686 if (SvTYPE(sv) < SVt_PVNV)
1687 sv_upgrade(sv, SVt_PVNV);
1691 #if defined(USE_LONG_DOUBLE)
1692 DEBUG_c(PerlIO_printf(Perl_debug_log,
1693 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1694 PTR2UV(sv), SvNVX(sv)));
1696 DEBUG_c(PerlIO_printf(Perl_debug_log,
1697 "0x%"UVxf" 2nv(%g)\n",
1698 PTR2UV(sv), SvNVX(sv)));
1700 if (SvNVX(sv) < -0.5) {
1701 SvIVX(sv) = I_V(SvNVX(sv));
1704 SvUVX(sv) = U_V(SvNVX(sv));
1708 else if (numtype & IS_NUMBER_NEG) {
1709 /* The NV may be reconstructed from IV - safe to cache IV,
1710 which may be calculated by atol(). */
1711 if (SvTYPE(sv) == SVt_PV)
1712 sv_upgrade(sv, SVt_PVIV);
1714 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1716 else if (numtype) { /* Non-negative */
1717 /* The NV may be reconstructed from UV - safe to cache UV,
1718 which may be calculated by strtoul()/atol. */
1719 if (SvTYPE(sv) == SVt_PV)
1720 sv_upgrade(sv, SVt_PVIV);
1722 (void)SvIsUV_on(sv);
1724 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1725 #else /* no atou(), but we know the number fits into IV... */
1726 /* The only problem may be if it is negative... */
1727 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1730 else { /* Not a number. Cache 0. */
1733 if (SvTYPE(sv) < SVt_PVIV)
1734 sv_upgrade(sv, SVt_PVIV);
1736 (void)SvIsUV_on(sv);
1737 SvUVX(sv) = 0; /* We assume that 0s have the
1738 same bitmap in IV and UV. */
1739 if (ckWARN(WARN_NUMERIC))
1744 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1746 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1749 if (SvTYPE(sv) < SVt_IV)
1750 /* Typically the caller expects that sv_any is not NULL now. */
1751 sv_upgrade(sv, SVt_IV);
1755 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1756 PTR2UV(sv),SvUVX(sv)));
1757 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1761 Perl_sv_2nv(pTHX_ register SV *sv)
1765 if (SvGMAGICAL(sv)) {
1769 if (SvPOKp(sv) && SvLEN(sv)) {
1771 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1773 return Atof(SvPVX(sv));
1777 return (NV)SvUVX(sv);
1779 return (NV)SvIVX(sv);
1782 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1784 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1790 if (SvTHINKFIRST(sv)) {
1793 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1794 (SvRV(tmpstr) != SvRV(sv)))
1795 return SvNV(tmpstr);
1796 return PTR2NV(SvRV(sv));
1798 if (SvREADONLY(sv) && !SvOK(sv)) {
1800 if (ckWARN(WARN_UNINITIALIZED))
1805 if (SvTYPE(sv) < SVt_NV) {
1806 if (SvTYPE(sv) == SVt_IV)
1807 sv_upgrade(sv, SVt_PVNV);
1809 sv_upgrade(sv, SVt_NV);
1810 #if defined(USE_LONG_DOUBLE)
1812 STORE_NUMERIC_LOCAL_SET_STANDARD();
1813 PerlIO_printf(Perl_debug_log,
1814 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1815 PTR2UV(sv), SvNVX(sv));
1816 RESTORE_NUMERIC_LOCAL();
1820 STORE_NUMERIC_LOCAL_SET_STANDARD();
1821 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1822 PTR2UV(sv), SvNVX(sv));
1823 RESTORE_NUMERIC_LOCAL();
1827 else if (SvTYPE(sv) < SVt_PVNV)
1828 sv_upgrade(sv, SVt_PVNV);
1830 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1832 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1834 else if (SvPOKp(sv) && SvLEN(sv)) {
1836 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1838 SvNVX(sv) = Atof(SvPVX(sv));
1842 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1844 if (SvTYPE(sv) < SVt_NV)
1845 /* Typically the caller expects that sv_any is not NULL now. */
1846 sv_upgrade(sv, SVt_NV);
1850 #if defined(USE_LONG_DOUBLE)
1852 STORE_NUMERIC_LOCAL_SET_STANDARD();
1853 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1854 PTR2UV(sv), SvNVX(sv));
1855 RESTORE_NUMERIC_LOCAL();
1859 STORE_NUMERIC_LOCAL_SET_STANDARD();
1860 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1861 PTR2UV(sv), SvNVX(sv));
1862 RESTORE_NUMERIC_LOCAL();
1869 S_asIV(pTHX_ SV *sv)
1871 I32 numtype = looks_like_number(sv);
1874 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1875 return Atol(SvPVX(sv));
1878 if (ckWARN(WARN_NUMERIC))
1881 d = Atof(SvPVX(sv));
1886 S_asUV(pTHX_ SV *sv)
1888 I32 numtype = looks_like_number(sv);
1891 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1892 return Strtoul(SvPVX(sv), Null(char**), 10);
1896 if (ckWARN(WARN_NUMERIC))
1899 return U_V(Atof(SvPVX(sv)));
1903 * Returns a combination of (advisory only - can get false negatives)
1904 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1906 * 0 if does not look like number.
1908 * In fact possible values are 0 and
1909 * IS_NUMBER_TO_INT_BY_ATOL 123
1910 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1911 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1912 * IS_NUMBER_INFINITY
1913 * with a possible addition of IS_NUMBER_NEG.
1917 =for apidoc looks_like_number
1919 Test if an the content of an SV looks like a number (or is a
1926 Perl_looks_like_number(pTHX_ SV *sv)
1929 register char *send;
1930 register char *sbegin;
1931 register char *nbegin;
1940 else if (SvPOKp(sv))
1941 sbegin = SvPV(sv, len);
1944 send = sbegin + len;
1951 numtype = IS_NUMBER_NEG;
1958 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1959 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1963 /* next must be digit or the radix separator or beginning of infinity */
1967 } while (isDIGIT(*s));
1969 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1970 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1972 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1975 #ifdef USE_LOCALE_NUMERIC
1976 || IS_NUMERIC_RADIX(*s)
1980 numtype |= IS_NUMBER_NOT_IV;
1981 while (isDIGIT(*s)) /* optional digits after the radix */
1986 #ifdef USE_LOCALE_NUMERIC
1987 || IS_NUMERIC_RADIX(*s)
1991 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1992 /* no digits before the radix means we need digits after it */
1996 } while (isDIGIT(*s));
2001 else if (*s == 'I' || *s == 'i') {
2002 s++; if (*s != 'N' && *s != 'n') return 0;
2003 s++; if (*s != 'F' && *s != 'f') return 0;
2004 s++; if (*s == 'I' || *s == 'i') {
2005 s++; if (*s != 'N' && *s != 'n') return 0;
2006 s++; if (*s != 'I' && *s != 'i') return 0;
2007 s++; if (*s != 'T' && *s != 't') return 0;
2008 s++; if (*s != 'Y' && *s != 'y') return 0;
2016 numtype = IS_NUMBER_INFINITY;
2018 /* we can have an optional exponent part */
2019 if (*s == 'e' || *s == 'E') {
2020 numtype &= ~IS_NUMBER_NEG;
2021 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2023 if (*s == '+' || *s == '-')
2028 } while (isDIGIT(*s));
2038 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2039 return IS_NUMBER_TO_INT_BY_ATOL;
2044 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2047 return sv_2pv(sv, &n_a);
2050 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2052 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2054 char *ptr = buf + TYPE_CHARS(UV);
2068 *--ptr = '0' + (uv % 10);
2077 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2082 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2083 char *tmpbuf = tbuf;
2089 if (SvGMAGICAL(sv)) {
2097 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2099 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2104 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2109 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2111 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2118 if (SvTHINKFIRST(sv)) {
2121 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2122 (SvRV(tmpstr) != SvRV(sv)))
2123 return SvPV(tmpstr,*lp);
2130 switch (SvTYPE(sv)) {
2132 if ( ((SvFLAGS(sv) &
2133 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2134 == (SVs_OBJECT|SVs_RMG))
2135 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2136 && (mg = mg_find(sv, 'r'))) {
2138 regexp *re = (regexp *)mg->mg_obj;
2141 char *fptr = "msix";
2146 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2148 while((ch = *fptr++)) {
2150 reflags[left++] = ch;
2153 reflags[right--] = ch;
2158 reflags[left] = '-';
2162 mg->mg_len = re->prelen + 4 + left;
2163 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2164 Copy("(?", mg->mg_ptr, 2, char);
2165 Copy(reflags, mg->mg_ptr+2, left, char);
2166 Copy(":", mg->mg_ptr+left+2, 1, char);
2167 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2168 mg->mg_ptr[mg->mg_len - 1] = ')';
2169 mg->mg_ptr[mg->mg_len] = 0;
2171 PL_reginterp_cnt += re->program[0].next_off;
2183 case SVt_PVBM: if (SvROK(sv))
2186 s = "SCALAR"; break;
2187 case SVt_PVLV: s = "LVALUE"; break;
2188 case SVt_PVAV: s = "ARRAY"; break;
2189 case SVt_PVHV: s = "HASH"; break;
2190 case SVt_PVCV: s = "CODE"; break;
2191 case SVt_PVGV: s = "GLOB"; break;
2192 case SVt_PVFM: s = "FORMAT"; break;
2193 case SVt_PVIO: s = "IO"; break;
2194 default: s = "UNKNOWN"; break;
2198 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2201 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2207 if (SvREADONLY(sv) && !SvOK(sv)) {
2209 if (ckWARN(WARN_UNINITIALIZED))
2215 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2216 /* XXXX 64-bit? IV may have better precision... */
2217 /* I tried changing this to be 64-bit-aware and
2218 * the t/op/numconvert.t became very, very, angry.
2220 if (SvTYPE(sv) < SVt_PVNV)
2221 sv_upgrade(sv, SVt_PVNV);
2222 /* The +20 is pure guesswork. Configure test needed. --jhi */
2223 SvGROW(sv, NV_DIG + 20);
2225 olderrno = errno; /* some Xenix systems wipe out errno here */
2227 if (SvNVX(sv) == 0.0)
2228 (void)strcpy(s,"0");
2232 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2235 #ifdef FIXNEGATIVEZERO
2236 if (*s == '-' && s[1] == '0' && !s[2])
2245 else if (SvIOKp(sv)) {
2246 U32 isIOK = SvIOK(sv);
2247 U32 isUIOK = SvIsUV(sv);
2248 char buf[TYPE_CHARS(UV)];
2251 if (SvTYPE(sv) < SVt_PVIV)
2252 sv_upgrade(sv, SVt_PVIV);
2254 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2256 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2257 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2258 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2259 SvCUR_set(sv, ebuf - ptr);
2272 if (ckWARN(WARN_UNINITIALIZED)
2273 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2278 if (SvTYPE(sv) < SVt_PV)
2279 /* Typically the caller expects that sv_any is not NULL now. */
2280 sv_upgrade(sv, SVt_PV);
2283 *lp = s - SvPVX(sv);
2286 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2287 PTR2UV(sv),SvPVX(sv)));
2291 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2292 /* Sneaky stuff here */
2296 tsv = newSVpv(tmpbuf, 0);
2312 len = strlen(tmpbuf);
2314 #ifdef FIXNEGATIVEZERO
2315 if (len == 2 && t[0] == '-' && t[1] == '0') {
2320 (void)SvUPGRADE(sv, SVt_PV);
2322 s = SvGROW(sv, len + 1);
2331 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2334 return sv_2pvbyte(sv, &n_a);
2338 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2340 return sv_2pv(sv,lp);
2344 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2347 return sv_2pvutf8(sv, &n_a);
2351 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2353 sv_utf8_upgrade(sv);
2354 return sv_2pv(sv,lp);
2357 /* This function is only called on magical items */
2359 Perl_sv_2bool(pTHX_ register SV *sv)
2369 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2370 (SvRV(tmpsv) != SvRV(sv)))
2371 return SvTRUE(tmpsv);
2372 return SvRV(sv) != 0;
2375 register XPV* Xpvtmp;
2376 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2377 (*Xpvtmp->xpv_pv > '0' ||
2378 Xpvtmp->xpv_cur > 1 ||
2379 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2386 return SvIVX(sv) != 0;
2389 return SvNVX(sv) != 0.0;
2397 =for apidoc sv_utf8_upgrade
2399 Convert the PV of an SV to its UTF8-encoded form.
2405 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2410 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2413 /* This function could be much more efficient if we had a FLAG in SVs
2414 * to signal if there are any hibit chars in the PV.
2416 for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2421 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2422 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2423 SvCUR(sv) = len - 1;
2424 SvLEN(sv) = len; /* No longer know the real size. */
2426 Safefree(s); /* No longer using what was there before. */
2431 =for apidoc sv_utf8_downgrade
2433 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2434 This may not be possible if the PV contains non-byte encoding characters;
2435 if this is the case, either returns false or, if C<fail_ok> is not
2442 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2444 if (SvPOK(sv) && SvUTF8(sv)) {
2445 char *c = SvPVX(sv);
2446 STRLEN len = SvCUR(sv) + 1; /* include trailing NUL */
2447 if (!utf8_to_bytes((U8*)c, &len)) {
2451 Perl_croak(aTHX_ "big byte");
2453 SvCUR(sv) = len - 1;
2460 =for apidoc sv_utf8_encode
2462 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2463 flag so that it looks like bytes again. Nothing calls this.
2469 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2471 sv_utf8_upgrade(sv);
2476 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2480 bool has_utf = FALSE;
2481 if (!sv_utf8_downgrade(sv, TRUE))
2484 /* it is actually just a matter of turning the utf8 flag on, but
2485 * we want to make sure everything inside is valid utf8 first.
2488 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
2491 while (c < SvEND(sv)) {
2502 /* Note: sv_setsv() should not be called with a source string that needs
2503 * to be reused, since it may destroy the source string if it is marked
2508 =for apidoc sv_setsv
2510 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2511 The source SV may be destroyed if it is mortal. Does not handle 'set'
2512 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2519 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2522 register U32 sflags;
2528 SV_CHECK_THINKFIRST(dstr);
2530 sstr = &PL_sv_undef;
2531 stype = SvTYPE(sstr);
2532 dtype = SvTYPE(dstr);
2536 /* There's a lot of redundancy below but we're going for speed here */
2541 if (dtype != SVt_PVGV) {
2542 (void)SvOK_off(dstr);
2550 sv_upgrade(dstr, SVt_IV);
2553 sv_upgrade(dstr, SVt_PVNV);
2557 sv_upgrade(dstr, SVt_PVIV);
2560 (void)SvIOK_only(dstr);
2561 SvIVX(dstr) = SvIVX(sstr);
2574 sv_upgrade(dstr, SVt_NV);
2579 sv_upgrade(dstr, SVt_PVNV);
2582 SvNVX(dstr) = SvNVX(sstr);
2583 (void)SvNOK_only(dstr);
2591 sv_upgrade(dstr, SVt_RV);
2592 else if (dtype == SVt_PVGV &&
2593 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2596 if (GvIMPORTED(dstr) != GVf_IMPORTED
2597 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2599 GvIMPORTED_on(dstr);
2610 sv_upgrade(dstr, SVt_PV);
2613 if (dtype < SVt_PVIV)
2614 sv_upgrade(dstr, SVt_PVIV);
2617 if (dtype < SVt_PVNV)
2618 sv_upgrade(dstr, SVt_PVNV);
2625 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2626 PL_op_name[PL_op->op_type]);
2628 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2632 if (dtype <= SVt_PVGV) {
2634 if (dtype != SVt_PVGV) {
2635 char *name = GvNAME(sstr);
2636 STRLEN len = GvNAMELEN(sstr);
2637 sv_upgrade(dstr, SVt_PVGV);
2638 sv_magic(dstr, dstr, '*', Nullch, 0);
2639 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2640 GvNAME(dstr) = savepvn(name, len);
2641 GvNAMELEN(dstr) = len;
2642 SvFAKE_on(dstr); /* can coerce to non-glob */
2644 /* ahem, death to those who redefine active sort subs */
2645 else if (PL_curstackinfo->si_type == PERLSI_SORT
2646 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2647 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2649 (void)SvOK_off(dstr);
2650 GvINTRO_off(dstr); /* one-shot flag */
2652 GvGP(dstr) = gp_ref(GvGP(sstr));
2654 if (GvIMPORTED(dstr) != GVf_IMPORTED
2655 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2657 GvIMPORTED_on(dstr);
2665 if (SvGMAGICAL(sstr)) {
2667 if (SvTYPE(sstr) != stype) {
2668 stype = SvTYPE(sstr);
2669 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2673 if (stype == SVt_PVLV)
2674 (void)SvUPGRADE(dstr, SVt_PVNV);
2676 (void)SvUPGRADE(dstr, stype);
2679 sflags = SvFLAGS(sstr);
2681 if (sflags & SVf_ROK) {
2682 if (dtype >= SVt_PV) {
2683 if (dtype == SVt_PVGV) {
2684 SV *sref = SvREFCNT_inc(SvRV(sstr));
2686 int intro = GvINTRO(dstr);
2691 GvINTRO_off(dstr); /* one-shot flag */
2692 Newz(602,gp, 1, GP);
2693 GvGP(dstr) = gp_ref(gp);
2694 GvSV(dstr) = NEWSV(72,0);
2695 GvLINE(dstr) = CopLINE(PL_curcop);
2696 GvEGV(dstr) = (GV*)dstr;
2699 switch (SvTYPE(sref)) {
2702 SAVESPTR(GvAV(dstr));
2704 dref = (SV*)GvAV(dstr);
2705 GvAV(dstr) = (AV*)sref;
2706 if (!GvIMPORTED_AV(dstr)
2707 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2709 GvIMPORTED_AV_on(dstr);
2714 SAVESPTR(GvHV(dstr));
2716 dref = (SV*)GvHV(dstr);
2717 GvHV(dstr) = (HV*)sref;
2718 if (!GvIMPORTED_HV(dstr)
2719 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2721 GvIMPORTED_HV_on(dstr);
2726 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2727 SvREFCNT_dec(GvCV(dstr));
2728 GvCV(dstr) = Nullcv;
2729 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2730 PL_sub_generation++;
2732 SAVESPTR(GvCV(dstr));
2735 dref = (SV*)GvCV(dstr);
2736 if (GvCV(dstr) != (CV*)sref) {
2737 CV* cv = GvCV(dstr);
2739 if (!GvCVGEN((GV*)dstr) &&
2740 (CvROOT(cv) || CvXSUB(cv)))
2742 SV *const_sv = cv_const_sv(cv);
2743 bool const_changed = TRUE;
2745 const_changed = sv_cmp(const_sv,
2746 op_const_sv(CvSTART((CV*)sref),
2748 /* ahem, death to those who redefine
2749 * active sort subs */
2750 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2751 PL_sortcop == CvSTART(cv))
2753 "Can't redefine active sort subroutine %s",
2754 GvENAME((GV*)dstr));
2755 if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
2756 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2757 "Constant subroutine %s redefined"
2758 : "Subroutine %s redefined",
2759 GvENAME((GV*)dstr));
2761 cv_ckproto(cv, (GV*)dstr,
2762 SvPOK(sref) ? SvPVX(sref) : Nullch);
2764 GvCV(dstr) = (CV*)sref;
2765 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2766 GvASSUMECV_on(dstr);
2767 PL_sub_generation++;
2769 if (!GvIMPORTED_CV(dstr)
2770 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2772 GvIMPORTED_CV_on(dstr);
2777 SAVESPTR(GvIOp(dstr));
2779 dref = (SV*)GvIOp(dstr);
2780 GvIOp(dstr) = (IO*)sref;
2784 SAVESPTR(GvFORM(dstr));
2786 dref = (SV*)GvFORM(dstr);
2787 GvFORM(dstr) = (CV*)sref;
2791 SAVESPTR(GvSV(dstr));
2793 dref = (SV*)GvSV(dstr);
2795 if (!GvIMPORTED_SV(dstr)
2796 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2798 GvIMPORTED_SV_on(dstr);
2810 (void)SvOOK_off(dstr); /* backoff */
2812 Safefree(SvPVX(dstr));
2813 SvLEN(dstr)=SvCUR(dstr)=0;
2816 (void)SvOK_off(dstr);
2817 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2819 if (sflags & SVp_NOK) {
2821 SvNVX(dstr) = SvNVX(sstr);
2823 if (sflags & SVp_IOK) {
2824 (void)SvIOK_on(dstr);
2825 SvIVX(dstr) = SvIVX(sstr);
2826 if (sflags & SVf_IVisUV)
2829 if (SvAMAGIC(sstr)) {
2833 else if (sflags & SVp_POK) {
2836 * Check to see if we can just swipe the string. If so, it's a
2837 * possible small lose on short strings, but a big win on long ones.
2838 * It might even be a win on short strings if SvPVX(dstr)
2839 * has to be allocated and SvPVX(sstr) has to be freed.
2842 if (SvTEMP(sstr) && /* slated for free anyway? */
2843 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2844 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
2845 SvLEN(sstr)) /* and really is a string */
2847 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2849 SvFLAGS(dstr) &= ~SVf_OOK;
2850 Safefree(SvPVX(dstr) - SvIVX(dstr));
2852 else if (SvLEN(dstr))
2853 Safefree(SvPVX(dstr));
2855 (void)SvPOK_only(dstr);
2856 SvPV_set(dstr, SvPVX(sstr));
2857 SvLEN_set(dstr, SvLEN(sstr));
2858 SvCUR_set(dstr, SvCUR(sstr));
2861 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2862 SvPV_set(sstr, Nullch);
2867 else { /* have to copy actual string */
2868 STRLEN len = SvCUR(sstr);
2870 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2871 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2872 SvCUR_set(dstr, len);
2873 *SvEND(dstr) = '\0';
2874 (void)SvPOK_only(dstr);
2876 if ((sflags & SVf_UTF8) && !IN_BYTE)
2879 if (sflags & SVp_NOK) {
2881 SvNVX(dstr) = SvNVX(sstr);
2883 if (sflags & SVp_IOK) {
2884 (void)SvIOK_on(dstr);
2885 SvIVX(dstr) = SvIVX(sstr);
2886 if (sflags & SVf_IVisUV)
2890 else if (sflags & SVp_NOK) {
2891 SvNVX(dstr) = SvNVX(sstr);
2892 (void)SvNOK_only(dstr);
2893 if (sflags & SVf_IOK) {
2894 (void)SvIOK_on(dstr);
2895 SvIVX(dstr) = SvIVX(sstr);
2896 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2897 if (sflags & SVf_IVisUV)
2901 else if (sflags & SVp_IOK) {
2902 (void)SvIOK_only(dstr);
2903 SvIVX(dstr) = SvIVX(sstr);
2904 if (sflags & SVf_IVisUV)
2908 if (dtype == SVt_PVGV) {
2909 if (ckWARN(WARN_MISC))
2910 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2913 (void)SvOK_off(dstr);
2919 =for apidoc sv_setsv_mg
2921 Like C<sv_setsv>, but also handles 'set' magic.
2927 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2929 sv_setsv(dstr,sstr);
2934 =for apidoc sv_setpvn
2936 Copies a string into an SV. The C<len> parameter indicates the number of
2937 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2943 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2945 register char *dptr;
2946 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2947 elicit a warning, but it won't hurt. */
2948 SV_CHECK_THINKFIRST(sv);
2953 (void)SvUPGRADE(sv, SVt_PV);
2955 SvGROW(sv, len + 1);
2957 Move(ptr,dptr,len,char);
2960 (void)SvPOK_only(sv); /* validate pointer */
2965 =for apidoc sv_setpvn_mg
2967 Like C<sv_setpvn>, but also handles 'set' magic.
2973 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2975 sv_setpvn(sv,ptr,len);
2980 =for apidoc sv_setpv
2982 Copies a string into an SV. The string must be null-terminated. Does not
2983 handle 'set' magic. See C<sv_setpv_mg>.
2989 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2991 register STRLEN len;
2993 SV_CHECK_THINKFIRST(sv);
2999 (void)SvUPGRADE(sv, SVt_PV);
3001 SvGROW(sv, len + 1);
3002 Move(ptr,SvPVX(sv),len+1,char);
3004 (void)SvPOK_only(sv); /* validate pointer */
3009 =for apidoc sv_setpv_mg
3011 Like C<sv_setpv>, but also handles 'set' magic.
3017 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3024 =for apidoc sv_usepvn
3026 Tells an SV to use C<ptr> to find its string value. Normally the string is
3027 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3028 The C<ptr> should point to memory that was allocated by C<malloc>. The
3029 string length, C<len>, must be supplied. This function will realloc the
3030 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3031 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3032 See C<sv_usepvn_mg>.
3038 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3040 SV_CHECK_THINKFIRST(sv);
3041 (void)SvUPGRADE(sv, SVt_PV);
3046 (void)SvOOK_off(sv);
3047 if (SvPVX(sv) && SvLEN(sv))
3048 Safefree(SvPVX(sv));
3049 Renew(ptr, len+1, char);
3052 SvLEN_set(sv, len+1);
3054 (void)SvPOK_only(sv); /* validate pointer */
3059 =for apidoc sv_usepvn_mg
3061 Like C<sv_usepvn>, but also handles 'set' magic.
3067 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3069 sv_usepvn(sv,ptr,len);
3074 Perl_sv_force_normal(pTHX_ register SV *sv)
3076 if (SvREADONLY(sv)) {
3079 char *pvx = SvPVX(sv);
3080 STRLEN len = SvCUR(sv);
3081 U32 hash = SvUVX(sv);
3082 SvGROW(sv, len + 1);
3083 Move(pvx,SvPVX(sv),len,char);
3087 unsharepvn(pvx,len,hash);
3089 else if (PL_curcop != &PL_compiling)
3090 Perl_croak(aTHX_ PL_no_modify);
3094 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3101 Efficient removal of characters from the beginning of the string buffer.
3102 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3103 the string buffer. The C<ptr> becomes the first character of the adjusted
3110 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3114 register STRLEN delta;
3116 if (!ptr || !SvPOKp(sv))
3118 SV_CHECK_THINKFIRST(sv);
3119 if (SvTYPE(sv) < SVt_PVIV)
3120 sv_upgrade(sv,SVt_PVIV);
3123 if (!SvLEN(sv)) { /* make copy of shared string */
3124 char *pvx = SvPVX(sv);
3125 STRLEN len = SvCUR(sv);
3126 SvGROW(sv, len + 1);
3127 Move(pvx,SvPVX(sv),len,char);
3131 SvFLAGS(sv) |= SVf_OOK;
3133 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3134 delta = ptr - SvPVX(sv);
3142 =for apidoc sv_catpvn
3144 Concatenates the string onto the end of the string which is in the SV. The
3145 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3146 'set' magic. See C<sv_catpvn_mg>.
3152 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3157 junk = SvPV_force(sv, tlen);
3158 SvGROW(sv, tlen + len + 1);
3161 Move(ptr,SvPVX(sv)+tlen,len,char);
3164 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3169 =for apidoc sv_catpvn_mg
3171 Like C<sv_catpvn>, but also handles 'set' magic.
3177 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3179 sv_catpvn(sv,ptr,len);
3184 =for apidoc sv_catsv
3186 Concatenates the string from SV C<ssv> onto the end of the string in SV
3187 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3193 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3199 if ((s = SvPV(sstr, len))) {
3200 if (DO_UTF8(sstr)) {
3201 sv_utf8_upgrade(dstr);
3202 sv_catpvn(dstr,s,len);
3206 sv_catpvn(dstr,s,len);
3211 =for apidoc sv_catsv_mg
3213 Like C<sv_catsv>, but also handles 'set' magic.
3219 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3221 sv_catsv(dstr,sstr);
3226 =for apidoc sv_catpv
3228 Concatenates the string onto the end of the string which is in the SV.
3229 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3235 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3237 register STRLEN len;
3243 junk = SvPV_force(sv, tlen);
3245 SvGROW(sv, tlen + len + 1);
3248 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3250 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3255 =for apidoc sv_catpv_mg
3257 Like C<sv_catpv>, but also handles 'set' magic.
3263 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3270 Perl_newSV(pTHX_ STRLEN len)
3276 sv_upgrade(sv, SVt_PV);
3277 SvGROW(sv, len + 1);
3282 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3285 =for apidoc sv_magic
3287 Adds magic to an SV.
3293 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3297 if (SvREADONLY(sv)) {
3299 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3300 Perl_croak(aTHX_ PL_no_modify);
3302 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3303 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3310 (void)SvUPGRADE(sv, SVt_PVMG);
3312 Newz(702,mg, 1, MAGIC);
3313 mg->mg_moremagic = SvMAGIC(sv);
3316 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)) {
3509 if (ckWARN(WARN_MISC))
3510 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3514 sv_add_backref(tsv, sv);
3521 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3525 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3526 av = (AV*)mg->mg_obj;
3529 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3530 SvREFCNT_dec(av); /* for sv_magic */
3536 S_sv_del_backref(pTHX_ SV *sv)
3543 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3544 Perl_croak(aTHX_ "panic: del_backref");
3545 av = (AV *)mg->mg_obj;
3550 svp[i] = &PL_sv_undef; /* XXX */
3557 =for apidoc sv_insert
3559 Inserts a string at the specified offset/length within the SV. Similar to
3560 the Perl substr() function.
3566 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3570 register char *midend;
3571 register char *bigend;
3577 Perl_croak(aTHX_ "Can't modify non-existent substring");
3578 SvPV_force(bigstr, curlen);
3579 (void)SvPOK_only_UTF8(bigstr);
3580 if (offset + len > curlen) {
3581 SvGROW(bigstr, offset+len+1);
3582 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3583 SvCUR_set(bigstr, offset+len);
3587 i = littlelen - len;
3588 if (i > 0) { /* string might grow */
3589 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3590 mid = big + offset + len;
3591 midend = bigend = big + SvCUR(bigstr);
3594 while (midend > mid) /* shove everything down */
3595 *--bigend = *--midend;
3596 Move(little,big+offset,littlelen,char);
3602 Move(little,SvPVX(bigstr)+offset,len,char);
3607 big = SvPVX(bigstr);
3610 bigend = big + SvCUR(bigstr);
3612 if (midend > bigend)
3613 Perl_croak(aTHX_ "panic: sv_insert");
3615 if (mid - big > bigend - midend) { /* faster to shorten from end */
3617 Move(little, mid, littlelen,char);
3620 i = bigend - midend;
3622 Move(midend, mid, i,char);
3626 SvCUR_set(bigstr, mid - big);
3629 else if ((i = mid - big)) { /* faster from front */
3630 midend -= littlelen;
3632 sv_chop(bigstr,midend-i);
3637 Move(little, mid, littlelen,char);
3639 else if (littlelen) {
3640 midend -= littlelen;
3641 sv_chop(bigstr,midend);
3642 Move(little,midend,littlelen,char);
3645 sv_chop(bigstr,midend);
3651 =for apidoc sv_replace
3653 Make the first argument a copy of the second, then delete the original.
3659 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3662 U32 refcnt = SvREFCNT(sv);
3663 SV_CHECK_THINKFIRST(sv);
3664 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3665 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3666 if (SvMAGICAL(sv)) {
3670 sv_upgrade(nsv, SVt_PVMG);
3671 SvMAGIC(nsv) = SvMAGIC(sv);
3672 SvFLAGS(nsv) |= SvMAGICAL(sv);
3678 assert(!SvREFCNT(sv));
3679 StructCopy(nsv,sv,SV);
3680 SvREFCNT(sv) = refcnt;
3681 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3686 =for apidoc sv_clear
3688 Clear an SV, making it empty. Does not free the memory used by the SV
3695 Perl_sv_clear(pTHX_ register SV *sv)
3699 assert(SvREFCNT(sv) == 0);
3703 if (PL_defstash) { /* Still have a symbol table? */
3708 Zero(&tmpref, 1, SV);
3709 sv_upgrade(&tmpref, SVt_RV);
3711 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3712 SvREFCNT(&tmpref) = 1;
3715 stash = SvSTASH(sv);
3716 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3719 PUSHSTACKi(PERLSI_DESTROY);
3720 SvRV(&tmpref) = SvREFCNT_inc(sv);
3725 call_sv((SV*)GvCV(destructor),
3726 G_DISCARD|G_EVAL|G_KEEPERR);
3732 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3734 del_XRV(SvANY(&tmpref));
3737 if (PL_in_clean_objs)
3738 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3740 /* DESTROY gave object new lease on life */
3746 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3747 SvOBJECT_off(sv); /* Curse the object. */
3748 if (SvTYPE(sv) != SVt_PVIO)
3749 --PL_sv_objcount; /* XXX Might want something more general */
3752 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3755 switch (SvTYPE(sv)) {
3758 IoIFP(sv) != PerlIO_stdin() &&
3759 IoIFP(sv) != PerlIO_stdout() &&
3760 IoIFP(sv) != PerlIO_stderr())
3762 io_close((IO*)sv, FALSE);
3764 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3765 PerlDir_close(IoDIRP(sv));
3766 IoDIRP(sv) = (DIR*)NULL;
3767 Safefree(IoTOP_NAME(sv));
3768 Safefree(IoFMT_NAME(sv));
3769 Safefree(IoBOTTOM_NAME(sv));
3784 SvREFCNT_dec(LvTARG(sv));
3788 Safefree(GvNAME(sv));
3789 /* cannot decrease stash refcount yet, as we might recursively delete
3790 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3791 of stash until current sv is completely gone.
3792 -- JohnPC, 27 Mar 1998 */
3793 stash = GvSTASH(sv);
3799 (void)SvOOK_off(sv);
3807 SvREFCNT_dec(SvRV(sv));
3809 else if (SvPVX(sv) && SvLEN(sv))
3810 Safefree(SvPVX(sv));
3811 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3812 unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3824 switch (SvTYPE(sv)) {
3840 del_XPVIV(SvANY(sv));
3843 del_XPVNV(SvANY(sv));
3846 del_XPVMG(SvANY(sv));
3849 del_XPVLV(SvANY(sv));
3852 del_XPVAV(SvANY(sv));
3855 del_XPVHV(SvANY(sv));
3858 del_XPVCV(SvANY(sv));
3861 del_XPVGV(SvANY(sv));
3862 /* code duplication for increased performance. */
3863 SvFLAGS(sv) &= SVf_BREAK;
3864 SvFLAGS(sv) |= SVTYPEMASK;
3865 /* decrease refcount of the stash that owns this GV, if any */
3867 SvREFCNT_dec(stash);
3868 return; /* not break, SvFLAGS reset already happened */
3870 del_XPVBM(SvANY(sv));
3873 del_XPVFM(SvANY(sv));
3876 del_XPVIO(SvANY(sv));
3879 SvFLAGS(sv) &= SVf_BREAK;
3880 SvFLAGS(sv) |= SVTYPEMASK;
3884 Perl_sv_newref(pTHX_ SV *sv)
3887 ATOMIC_INC(SvREFCNT(sv));
3894 Free the memory used by an SV.
3900 Perl_sv_free(pTHX_ SV *sv)
3903 int refcount_is_zero;
3907 if (SvREFCNT(sv) == 0) {
3908 if (SvFLAGS(sv) & SVf_BREAK)
3910 if (PL_in_clean_all) /* All is fair */
3912 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3913 /* make sure SvREFCNT(sv)==0 happens very seldom */
3914 SvREFCNT(sv) = (~(U32)0)/2;
3917 if (ckWARN_d(WARN_INTERNAL))
3918 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3921 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3922 if (!refcount_is_zero)
3926 if (ckWARN_d(WARN_DEBUGGING))
3927 Perl_warner(aTHX_ WARN_DEBUGGING,
3928 "Attempt to free temp prematurely: SV 0x%"UVxf,
3933 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3934 /* make sure SvREFCNT(sv)==0 happens very seldom */
3935 SvREFCNT(sv) = (~(U32)0)/2;
3946 Returns the length of the string in the SV. See also C<SvCUR>.
3952 Perl_sv_len(pTHX_ register SV *sv)
3961 len = mg_length(sv);
3963 junk = SvPV(sv, len);
3968 =for apidoc sv_len_utf8
3970 Returns the number of characters in the string in an SV, counting wide
3971 UTF8 bytes as a single character.
3977 Perl_sv_len_utf8(pTHX_ register SV *sv)
3988 len = mg_length(sv);
3991 s = (U8*)SvPV(sv, len);
4002 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4007 I32 uoffset = *offsetp;
4013 start = s = (U8*)SvPV(sv, len);
4015 while (s < send && uoffset--)
4019 *offsetp = s - start;
4023 while (s < send && ulen--)
4033 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4042 s = (U8*)SvPV(sv, len);
4044 Perl_croak(aTHX_ "panic: bad byte offset");
4045 send = s + *offsetp;
4053 if (ckWARN_d(WARN_UTF8))
4054 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4064 Returns a boolean indicating whether the strings in the two SVs are
4071 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4078 bool pv1tmp = FALSE;
4079 bool pv2tmp = FALSE;
4086 pv1 = SvPV(sv1, cur1);
4093 pv2 = SvPV(sv2, cur2);
4095 /* do not utf8ize the comparands as a side-effect */
4096 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
4098 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4102 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4108 eq = memEQ(pv1, pv2, cur1);
4121 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4122 string in C<sv1> is less than, equal to, or greater than the string in
4129 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4134 bool pv1tmp = FALSE;
4135 bool pv2tmp = FALSE;
4142 pv1 = SvPV(sv1, cur1);
4149 pv2 = SvPV(sv2, cur2);
4151 /* do not utf8ize the comparands as a side-effect */
4152 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4154 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4158 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4164 cmp = cur2 ? -1 : 0;
4168 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4171 cmp = retval < 0 ? -1 : 1;
4172 } else if (cur1 == cur2) {
4175 cmp = cur1 < cur2 ? -1 : 1;
4188 =for apidoc sv_cmp_locale
4190 Compares the strings in two SVs in a locale-aware manner. See
4197 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4199 #ifdef USE_LOCALE_COLLATE
4205 if (PL_collation_standard)
4209 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4211 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4213 if (!pv1 || !len1) {
4224 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4227 return retval < 0 ? -1 : 1;
4230 * When the result of collation is equality, that doesn't mean
4231 * that there are no differences -- some locales exclude some
4232 * characters from consideration. So to avoid false equalities,
4233 * we use the raw string as a tiebreaker.
4239 #endif /* USE_LOCALE_COLLATE */
4241 return sv_cmp(sv1, sv2);
4244 #ifdef USE_LOCALE_COLLATE
4246 * Any scalar variable may carry an 'o' magic that contains the
4247 * scalar data of the variable transformed to such a format that
4248 * a normal memory comparison can be used to compare the data
4249 * according to the locale settings.
4252 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4256 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4257 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4262 Safefree(mg->mg_ptr);
4264 if ((xf = mem_collxfrm(s, len, &xlen))) {
4265 if (SvREADONLY(sv)) {
4268 return xf + sizeof(PL_collation_ix);
4271 sv_magic(sv, 0, 'o', 0, 0);
4272 mg = mg_find(sv, 'o');
4285 if (mg && mg->mg_ptr) {
4287 return mg->mg_ptr + sizeof(PL_collation_ix);
4295 #endif /* USE_LOCALE_COLLATE */
4300 Get a line from the filehandle and store it into the SV, optionally
4301 appending to the currently-stored string.
4307 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4312 register STDCHAR rslast;
4313 register STDCHAR *bp;
4317 SV_CHECK_THINKFIRST(sv);
4318 (void)SvUPGRADE(sv, SVt_PV);
4322 if (RsSNARF(PL_rs)) {
4326 else if (RsRECORD(PL_rs)) {
4327 I32 recsize, bytesread;
4330 /* Grab the size of the record we're getting */
4331 recsize = SvIV(SvRV(PL_rs));
4332 (void)SvPOK_only(sv); /* Validate pointer */
4333 buffer = SvGROW(sv, recsize + 1);
4336 /* VMS wants read instead of fread, because fread doesn't respect */
4337 /* RMS record boundaries. This is not necessarily a good thing to be */
4338 /* doing, but we've got no other real choice */
4339 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4341 bytesread = PerlIO_read(fp, buffer, recsize);
4343 SvCUR_set(sv, bytesread);
4344 buffer[bytesread] = '\0';
4345 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4347 else if (RsPARA(PL_rs)) {
4352 rsptr = SvPV(PL_rs, rslen);
4353 rslast = rslen ? rsptr[rslen - 1] : '\0';
4355 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4356 do { /* to make sure file boundaries work right */
4359 i = PerlIO_getc(fp);
4363 PerlIO_ungetc(fp,i);
4369 /* See if we know enough about I/O mechanism to cheat it ! */
4371 /* This used to be #ifdef test - it is made run-time test for ease
4372 of abstracting out stdio interface. One call should be cheap
4373 enough here - and may even be a macro allowing compile
4377 if (PerlIO_fast_gets(fp)) {
4380 * We're going to steal some values from the stdio struct
4381 * and put EVERYTHING in the innermost loop into registers.
4383 register STDCHAR *ptr;
4387 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4388 /* An ungetc()d char is handled separately from the regular
4389 * buffer, so we getc() it back out and stuff it in the buffer.
4391 i = PerlIO_getc(fp);
4392 if (i == EOF) return 0;
4393 *(--((*fp)->_ptr)) = (unsigned char) i;
4397 /* Here is some breathtakingly efficient cheating */
4399 cnt = PerlIO_get_cnt(fp); /* get count into register */
4400 (void)SvPOK_only(sv); /* validate pointer */
4401 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4402 if (cnt > 80 && SvLEN(sv) > append) {
4403 shortbuffered = cnt - SvLEN(sv) + append + 1;
4404 cnt -= shortbuffered;
4408 /* remember that cnt can be negative */
4409 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4414 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4415 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4416 DEBUG_P(PerlIO_printf(Perl_debug_log,
4417 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4418 DEBUG_P(PerlIO_printf(Perl_debug_log,
4419 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4420 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4421 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4426 while (cnt > 0) { /* this | eat */
4428 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4429 goto thats_all_folks; /* screams | sed :-) */
4433 Copy(ptr, bp, cnt, char); /* this | eat */
4434 bp += cnt; /* screams | dust */
4435 ptr += cnt; /* louder | sed :-) */
4440 if (shortbuffered) { /* oh well, must extend */
4441 cnt = shortbuffered;
4443 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4445 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4446 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4450 DEBUG_P(PerlIO_printf(Perl_debug_log,
4451 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4452 PTR2UV(ptr),(long)cnt));
4453 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4454 DEBUG_P(PerlIO_printf(Perl_debug_log,
4455 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4456 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4457 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4458 /* This used to call 'filbuf' in stdio form, but as that behaves like
4459 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4460 another abstraction. */
4461 i = PerlIO_getc(fp); /* get more characters */
4462 DEBUG_P(PerlIO_printf(Perl_debug_log,
4463 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4464 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4465 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4466 cnt = PerlIO_get_cnt(fp);
4467 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4468 DEBUG_P(PerlIO_printf(Perl_debug_log,
4469 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4471 if (i == EOF) /* all done for ever? */
4472 goto thats_really_all_folks;
4474 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4476 SvGROW(sv, bpx + cnt + 2);
4477 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4479 *bp++ = i; /* store character from PerlIO_getc */
4481 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4482 goto thats_all_folks;
4486 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4487 memNE((char*)bp - rslen, rsptr, rslen))
4488 goto screamer; /* go back to the fray */
4489 thats_really_all_folks:
4491 cnt += shortbuffered;
4492 DEBUG_P(PerlIO_printf(Perl_debug_log,
4493 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4494 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4495 DEBUG_P(PerlIO_printf(Perl_debug_log,
4496 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4497 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4498 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4500 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4501 DEBUG_P(PerlIO_printf(Perl_debug_log,
4502 "Screamer: done, len=%ld, string=|%.*s|\n",
4503 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4508 /*The big, slow, and stupid way */
4511 /* Need to work around EPOC SDK features */
4512 /* On WINS: MS VC5 generates calls to _chkstk, */
4513 /* if a `large' stack frame is allocated */
4514 /* gcc on MARM does not generate calls like these */
4520 register STDCHAR *bpe = buf + sizeof(buf);
4522 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4523 ; /* keep reading */
4527 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4528 /* Accomodate broken VAXC compiler, which applies U8 cast to
4529 * both args of ?: operator, causing EOF to change into 255
4531 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4535 sv_catpvn(sv, (char *) buf, cnt);
4537 sv_setpvn(sv, (char *) buf, cnt);
4539 if (i != EOF && /* joy */
4541 SvCUR(sv) < rslen ||
4542 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4546 * If we're reading from a TTY and we get a short read,
4547 * indicating that the user hit his EOF character, we need
4548 * to notice it now, because if we try to read from the TTY
4549 * again, the EOF condition will disappear.
4551 * The comparison of cnt to sizeof(buf) is an optimization
4552 * that prevents unnecessary calls to feof().
4556 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4561 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4562 while (i != EOF) { /* to make sure file boundaries work right */
4563 i = PerlIO_getc(fp);
4565 PerlIO_ungetc(fp,i);
4571 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4578 Auto-increment of the value in the SV.
4584 Perl_sv_inc(pTHX_ register SV *sv)
4593 if (SvTHINKFIRST(sv)) {
4594 if (SvREADONLY(sv)) {
4596 if (PL_curcop != &PL_compiling)
4597 Perl_croak(aTHX_ PL_no_modify);
4601 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4603 i = PTR2IV(SvRV(sv));
4608 flags = SvFLAGS(sv);
4609 if (flags & SVp_NOK) {
4610 (void)SvNOK_only(sv);
4614 if (flags & SVp_IOK) {
4616 if (SvUVX(sv) == UV_MAX)
4617 sv_setnv(sv, (NV)UV_MAX + 1.0);
4619 (void)SvIOK_only_UV(sv);
4622 if (SvIVX(sv) == IV_MAX)
4623 sv_setnv(sv, (NV)IV_MAX + 1.0);
4625 (void)SvIOK_only(sv);
4631 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4632 if ((flags & SVTYPEMASK) < SVt_PVNV)
4633 sv_upgrade(sv, SVt_NV);
4635 (void)SvNOK_only(sv);
4639 while (isALPHA(*d)) d++;
4640 while (isDIGIT(*d)) d++;
4642 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4646 while (d >= SvPVX(sv)) {
4654 /* MKS: The original code here died if letters weren't consecutive.
4655 * at least it didn't have to worry about non-C locales. The
4656 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4657 * arranged in order (although not consecutively) and that only
4658 * [A-Za-z] are accepted by isALPHA in the C locale.
4660 if (*d != 'z' && *d != 'Z') {
4661 do { ++*d; } while (!isALPHA(*d));
4664 *(d--) -= 'z' - 'a';
4669 *(d--) -= 'z' - 'a' + 1;
4673 /* oh,oh, the number grew */
4674 SvGROW(sv, SvCUR(sv) + 2);
4676 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4687 Auto-decrement of the value in the SV.
4693 Perl_sv_dec(pTHX_ register SV *sv)
4701 if (SvTHINKFIRST(sv)) {
4702 if (SvREADONLY(sv)) {
4704 if (PL_curcop != &PL_compiling)
4705 Perl_croak(aTHX_ PL_no_modify);
4709 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4711 i = PTR2IV(SvRV(sv));
4716 flags = SvFLAGS(sv);
4717 if (flags & SVp_NOK) {
4719 (void)SvNOK_only(sv);
4722 if (flags & SVp_IOK) {
4724 if (SvUVX(sv) == 0) {
4725 (void)SvIOK_only(sv);
4729 (void)SvIOK_only_UV(sv);
4733 if (SvIVX(sv) == IV_MIN)
4734 sv_setnv(sv, (NV)IV_MIN - 1.0);
4736 (void)SvIOK_only(sv);
4742 if (!(flags & SVp_POK)) {
4743 if ((flags & SVTYPEMASK) < SVt_PVNV)
4744 sv_upgrade(sv, SVt_NV);
4746 (void)SvNOK_only(sv);
4749 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4753 =for apidoc sv_mortalcopy
4755 Creates a new SV which is a copy of the original SV. The new SV is marked
4761 /* Make a string that will exist for the duration of the expression
4762 * evaluation. Actually, it may have to last longer than that, but
4763 * hopefully we won't free it until it has been assigned to a
4764 * permanent location. */
4767 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4773 sv_setsv(sv,oldstr);
4775 PL_tmps_stack[++PL_tmps_ix] = sv;
4781 =for apidoc sv_newmortal
4783 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4789 Perl_sv_newmortal(pTHX)
4795 SvFLAGS(sv) = SVs_TEMP;
4797 PL_tmps_stack[++PL_tmps_ix] = sv;
4802 =for apidoc sv_2mortal
4804 Marks an SV as mortal. The SV will be destroyed when the current context
4810 /* same thing without the copying */
4813 Perl_sv_2mortal(pTHX_ register SV *sv)
4818 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4821 PL_tmps_stack[++PL_tmps_ix] = sv;
4829 Creates a new SV and copies a string into it. The reference count for the
4830 SV is set to 1. If C<len> is zero, Perl will compute the length using
4831 strlen(). For efficiency, consider using C<newSVpvn> instead.
4837 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4844 sv_setpvn(sv,s,len);
4849 =for apidoc newSVpvn
4851 Creates a new SV and copies a string into it. The reference count for the
4852 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4853 string. You are responsible for ensuring that the source string is at least
4860 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4865 sv_setpvn(sv,s,len);
4870 =for apidoc newSVpvn_share
4872 Creates a new SV and populates it with a string from
4873 the string table. Turns on READONLY and FAKE.
4874 The idea here is that as string table is used for shared hash
4875 keys these strings will have SvPVX == HeKEY and hash lookup
4876 will avoid string compare.
4882 Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4886 PERL_HASH(hash, src, len);
4888 sv_upgrade(sv, SVt_PVIV);
4889 SvPVX(sv) = sharepvn(src, len, hash);
4899 #if defined(PERL_IMPLICIT_CONTEXT)
4901 Perl_newSVpvf_nocontext(const char* pat, ...)
4906 va_start(args, pat);
4907 sv = vnewSVpvf(pat, &args);
4914 =for apidoc newSVpvf
4916 Creates a new SV an initialize it with the string formatted like
4923 Perl_newSVpvf(pTHX_ const char* pat, ...)
4927 va_start(args, pat);
4928 sv = vnewSVpvf(pat, &args);
4934 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4938 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4945 Creates a new SV and copies a floating point value into it.
4946 The reference count for the SV is set to 1.
4952 Perl_newSVnv(pTHX_ NV n)
4964 Creates a new SV and copies an integer into it. The reference count for the
4971 Perl_newSViv(pTHX_ IV i)
4983 Creates a new SV and copies an unsigned integer into it.
4984 The reference count for the SV is set to 1.
4990 Perl_newSVuv(pTHX_ UV u)
5000 =for apidoc newRV_noinc
5002 Creates an RV wrapper for an SV. The reference count for the original
5003 SV is B<not> incremented.
5009 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5015 sv_upgrade(sv, SVt_RV);
5022 /* newRV_inc is #defined to newRV in sv.h */
5024 Perl_newRV(pTHX_ SV *tmpRef)
5026 return newRV_noinc(SvREFCNT_inc(tmpRef));
5032 Creates a new SV which is an exact duplicate of the original SV.
5037 /* make an exact duplicate of old */
5040 Perl_newSVsv(pTHX_ register SV *old)
5047 if (SvTYPE(old) == SVTYPEMASK) {
5048 if (ckWARN_d(WARN_INTERNAL))
5049 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5064 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5072 char todo[PERL_UCHAR_MAX+1];
5077 if (!*s) { /* reset ?? searches */
5078 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5079 pm->op_pmdynflags &= ~PMdf_USED;
5084 /* reset variables */
5086 if (!HvARRAY(stash))
5089 Zero(todo, 256, char);
5091 i = (unsigned char)*s;
5095 max = (unsigned char)*s++;
5096 for ( ; i <= max; i++) {
5099 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5100 for (entry = HvARRAY(stash)[i];
5102 entry = HeNEXT(entry))
5104 if (!todo[(U8)*HeKEY(entry)])
5106 gv = (GV*)HeVAL(entry);
5108 if (SvTHINKFIRST(sv)) {
5109 if (!SvREADONLY(sv) && SvROK(sv))
5114 if (SvTYPE(sv) >= SVt_PV) {
5116 if (SvPVX(sv) != Nullch)
5123 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5125 #if !defined( VMS) && !defined(EPOC) /* VMS has no environ array */
5127 environ[0] = Nullch;
5136 Perl_sv_2io(pTHX_ SV *sv)
5142 switch (SvTYPE(sv)) {
5150 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5154 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5156 return sv_2io(SvRV(sv));
5157 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5163 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5170 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5177 return *gvp = Nullgv, Nullcv;
5178 switch (SvTYPE(sv)) {
5198 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5199 tryAMAGICunDEREF(to_cv);
5202 if (SvTYPE(sv) == SVt_PVCV) {
5211 Perl_croak(aTHX_ "Not a subroutine reference");
5216 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5222 if (lref && !GvCVu(gv)) {
5225 tmpsv = NEWSV(704,0);
5226 gv_efullname3(tmpsv, gv, Nullch);
5227 /* XXX this is probably not what they think they're getting.
5228 * It has the same effect as "sub name;", i.e. just a forward
5230 newSUB(start_subparse(FALSE, 0),
5231 newSVOP(OP_CONST, 0, tmpsv),
5236 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5245 Returns true if the SV has a true value by Perl's rules.
5251 Perl_sv_true(pTHX_ register SV *sv)
5258 if ((tXpv = (XPV*)SvANY(sv)) &&
5259 (tXpv->xpv_cur > 1 ||
5260 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5267 return SvIVX(sv) != 0;
5270 return SvNVX(sv) != 0.0;
5272 return sv_2bool(sv);
5278 Perl_sv_iv(pTHX_ register SV *sv)
5282 return (IV)SvUVX(sv);
5289 Perl_sv_uv(pTHX_ register SV *sv)
5294 return (UV)SvIVX(sv);
5300 Perl_sv_nv(pTHX_ register SV *sv)
5308 Perl_sv_pv(pTHX_ SV *sv)
5315 return sv_2pv(sv, &n_a);
5319 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5325 return sv_2pv(sv, lp);
5329 =for apidoc sv_pvn_force
5331 Get a sensible string out of the SV somehow.
5337 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5341 if (SvTHINKFIRST(sv) && !SvROK(sv))
5342 sv_force_normal(sv);
5348 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5350 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5351 PL_op_name[PL_op->op_type]);
5355 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5360 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5361 SvGROW(sv, len + 1);
5362 Move(s,SvPVX(sv),len,char);
5367 SvPOK_on(sv); /* validate pointer */
5369 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5370 PTR2UV(sv),SvPVX(sv)));
5377 Perl_sv_pvbyte(pTHX_ SV *sv)
5383 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5385 return sv_pvn(sv,lp);
5389 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5391 return sv_pvn_force(sv,lp);
5395 Perl_sv_pvutf8(pTHX_ SV *sv)
5397 sv_utf8_upgrade(sv);
5402 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5404 sv_utf8_upgrade(sv);
5405 return sv_pvn(sv,lp);
5409 =for apidoc sv_pvutf8n_force
5411 Get a sensible UTF8-encoded string out of the SV somehow. See
5418 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5420 sv_utf8_upgrade(sv);
5421 return sv_pvn_force(sv,lp);
5425 =for apidoc sv_reftype
5427 Returns a string describing what the SV is a reference to.
5433 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5435 if (ob && SvOBJECT(sv))
5436 return HvNAME(SvSTASH(sv));
5438 switch (SvTYPE(sv)) {
5452 case SVt_PVLV: return "LVALUE";
5453 case SVt_PVAV: return "ARRAY";
5454 case SVt_PVHV: return "HASH";
5455 case SVt_PVCV: return "CODE";
5456 case SVt_PVGV: return "GLOB";
5457 case SVt_PVFM: return "FORMAT";
5458 case SVt_PVIO: return "IO";
5459 default: return "UNKNOWN";
5465 =for apidoc sv_isobject
5467 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5468 object. If the SV is not an RV, or if the object is not blessed, then this
5475 Perl_sv_isobject(pTHX_ SV *sv)
5492 Returns a boolean indicating whether the SV is blessed into the specified
5493 class. This does not check for subtypes; use C<sv_derived_from> to verify
5494 an inheritance relationship.
5500 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5512 return strEQ(HvNAME(SvSTASH(sv)), name);
5518 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5519 it will be upgraded to one. If C<classname> is non-null then the new SV will
5520 be blessed in the specified package. The new SV is returned and its
5521 reference count is 1.
5527 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5534 SV_CHECK_THINKFIRST(rv);
5537 if (SvTYPE(rv) >= SVt_PVMG) {
5538 U32 refcnt = SvREFCNT(rv);
5542 SvREFCNT(rv) = refcnt;
5545 if (SvTYPE(rv) < SVt_RV)
5546 sv_upgrade(rv, SVt_RV);
5547 else if (SvTYPE(rv) > SVt_RV) {
5548 (void)SvOOK_off(rv);
5549 if (SvPVX(rv) && SvLEN(rv))
5550 Safefree(SvPVX(rv));
5560 HV* stash = gv_stashpv(classname, TRUE);
5561 (void)sv_bless(rv, stash);
5567 =for apidoc sv_setref_pv
5569 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5570 argument will be upgraded to an RV. That RV will be modified to point to
5571 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5572 into the SV. The C<classname> argument indicates the package for the
5573 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5574 will be returned and will have a reference count of 1.
5576 Do not use with other Perl types such as HV, AV, SV, CV, because those
5577 objects will become corrupted by the pointer copy process.
5579 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5585 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5588 sv_setsv(rv, &PL_sv_undef);
5592 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5597 =for apidoc sv_setref_iv
5599 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5600 argument will be upgraded to an RV. That RV will be modified to point to
5601 the new SV. The C<classname> argument indicates the package for the
5602 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5603 will be returned and will have a reference count of 1.
5609 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5611 sv_setiv(newSVrv(rv,classname), iv);
5616 =for apidoc sv_setref_nv
5618 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5619 argument will be upgraded to an RV. That RV will be modified to point to
5620 the new SV. The C<classname> argument indicates the package for the
5621 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5622 will be returned and will have a reference count of 1.
5628 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5630 sv_setnv(newSVrv(rv,classname), nv);
5635 =for apidoc sv_setref_pvn
5637 Copies a string into a new SV, optionally blessing the SV. The length of the
5638 string must be specified with C<n>. The C<rv> argument will be upgraded to
5639 an RV. That RV will be modified to point to the new SV. The C<classname>
5640 argument indicates the package for the blessing. Set C<classname> to
5641 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5642 a reference count of 1.
5644 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5650 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5652 sv_setpvn(newSVrv(rv,classname), pv, n);
5657 =for apidoc sv_bless
5659 Blesses an SV into a specified package. The SV must be an RV. The package
5660 must be designated by its stash (see C<gv_stashpv()>). The reference count
5661 of the SV is unaffected.
5667 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5672 Perl_croak(aTHX_ "Can't bless non-reference value");
5674 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5675 if (SvREADONLY(tmpRef))
5676 Perl_croak(aTHX_ PL_no_modify);
5677 if (SvOBJECT(tmpRef)) {
5678 if (SvTYPE(tmpRef) != SVt_PVIO)
5680 SvREFCNT_dec(SvSTASH(tmpRef));
5683 SvOBJECT_on(tmpRef);
5684 if (SvTYPE(tmpRef) != SVt_PVIO)
5686 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5687 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5698 S_sv_unglob(pTHX_ SV *sv)
5702 assert(SvTYPE(sv) == SVt_PVGV);
5707 SvREFCNT_dec(GvSTASH(sv));
5708 GvSTASH(sv) = Nullhv;
5710 sv_unmagic(sv, '*');
5711 Safefree(GvNAME(sv));
5714 /* need to keep SvANY(sv) in the right arena */
5715 xpvmg = new_XPVMG();
5716 StructCopy(SvANY(sv), xpvmg, XPVMG);
5717 del_XPVGV(SvANY(sv));
5720 SvFLAGS(sv) &= ~SVTYPEMASK;
5721 SvFLAGS(sv) |= SVt_PVMG;
5725 =for apidoc sv_unref
5727 Unsets the RV status of the SV, and decrements the reference count of
5728 whatever was being referenced by the RV. This can almost be thought of
5729 as a reversal of C<newSVrv>. See C<SvROK_off>.
5735 Perl_sv_unref(pTHX_ SV *sv)
5739 if (SvWEAKREF(sv)) {
5747 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5750 sv_2mortal(rv); /* Schedule for freeing later */
5754 Perl_sv_taint(pTHX_ SV *sv)
5756 sv_magic((sv), Nullsv, 't', Nullch, 0);
5760 Perl_sv_untaint(pTHX_ SV *sv)
5762 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5763 MAGIC *mg = mg_find(sv, 't');
5770 Perl_sv_tainted(pTHX_ SV *sv)
5772 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5773 MAGIC *mg = mg_find(sv, 't');
5774 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5781 =for apidoc sv_setpviv
5783 Copies an integer into the given SV, also updating its string value.
5784 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5790 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5792 char buf[TYPE_CHARS(UV)];
5794 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5796 sv_setpvn(sv, ptr, ebuf - ptr);
5801 =for apidoc sv_setpviv_mg
5803 Like C<sv_setpviv>, but also handles 'set' magic.
5809 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5811 char buf[TYPE_CHARS(UV)];
5813 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5815 sv_setpvn(sv, ptr, ebuf - ptr);
5819 #if defined(PERL_IMPLICIT_CONTEXT)
5821 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5825 va_start(args, pat);
5826 sv_vsetpvf(sv, pat, &args);
5832 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5836 va_start(args, pat);
5837 sv_vsetpvf_mg(sv, pat, &args);
5843 =for apidoc sv_setpvf
5845 Processes its arguments like C<sprintf> and sets an SV to the formatted
5846 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5852 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5855 va_start(args, pat);
5856 sv_vsetpvf(sv, pat, &args);
5861 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5863 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5867 =for apidoc sv_setpvf_mg
5869 Like C<sv_setpvf>, but also handles 'set' magic.
5875 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5878 va_start(args, pat);
5879 sv_vsetpvf_mg(sv, pat, &args);
5884 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5886 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5890 #if defined(PERL_IMPLICIT_CONTEXT)
5892 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5896 va_start(args, pat);
5897 sv_vcatpvf(sv, pat, &args);
5902 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5906 va_start(args, pat);
5907 sv_vcatpvf_mg(sv, pat, &args);
5913 =for apidoc sv_catpvf
5915 Processes its arguments like C<sprintf> and appends the formatted output
5916 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5917 typically be called after calling this function to handle 'set' magic.
5923 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5926 va_start(args, pat);
5927 sv_vcatpvf(sv, pat, &args);
5932 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5934 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5938 =for apidoc sv_catpvf_mg
5940 Like C<sv_catpvf>, but also handles 'set' magic.
5946 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5949 va_start(args, pat);
5950 sv_vcatpvf_mg(sv, pat, &args);
5955 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5957 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5962 =for apidoc sv_vsetpvfn
5964 Works like C<vcatpvfn> but copies the text into the SV instead of
5971 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5973 sv_setpvn(sv, "", 0);
5974 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5978 =for apidoc sv_vcatpvfn
5980 Processes its arguments like C<vsprintf> and appends the formatted output
5981 to an SV. Uses an array of SVs if the C style variable argument list is
5982 missing (NULL). When running with taint checks enabled, indicates via
5983 C<maybe_tainted> if results are untrustworthy (often due to the use of
5990 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5998 static char nullstr[] = "(null)";
6001 /* no matter what, this is a string now */
6002 (void)SvPV_force(sv, origlen);
6004 /* special-case "", "%s", and "%_" */
6007 if (patlen == 2 && pat[0] == '%') {
6011 char *s = va_arg(*args, char*);
6012 sv_catpv(sv, s ? s : nullstr);
6014 else if (svix < svmax) {
6015 sv_catsv(sv, *svargs);
6016 if (DO_UTF8(*svargs))
6022 argsv = va_arg(*args, SV*);
6023 sv_catsv(sv, argsv);
6028 /* See comment on '_' below */
6033 patend = (char*)pat + patlen;
6034 for (p = (char*)pat; p < patend; p = q) {
6037 bool vectorize = FALSE;
6044 bool has_precis = FALSE;
6046 bool is_utf = FALSE;
6049 U8 utf8buf[UTF8_MAXLEN];
6050 STRLEN esignlen = 0;
6052 char *eptr = Nullch;
6054 /* Times 4: a decimal digit takes more than 3 binary digits.
6055 * NV_DIG: mantissa takes than many decimal digits.
6056 * Plus 32: Playing safe. */
6057 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6058 /* large enough for "%#.#f" --chip */
6059 /* what about long double NVs? --jhi */
6062 U8 *vecstr = Null(U8*);
6074 STRLEN dotstrlen = 1;
6076 for (q = p; q < patend && *q != '%'; ++q) ;
6078 sv_catpvn(sv, p, q - p);
6107 case '*': /* printf("%*vX",":",$ipv6addr) */
6112 vecsv = va_arg(*args, SV*);
6113 else if (svix < svmax)
6114 vecsv = svargs[svix++];
6117 dotstr = SvPVx(vecsv,dotstrlen);
6136 case '1': case '2': case '3':
6137 case '4': case '5': case '6':
6138 case '7': case '8': case '9':
6141 width = width * 10 + (*q++ - '0');
6146 i = va_arg(*args, int);
6148 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6150 width = (i < 0) ? -i : i;
6161 i = va_arg(*args, int);
6163 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6164 precis = (i < 0) ? 0 : i;
6170 precis = precis * 10 + (*q++ - '0');
6177 vecsv = va_arg(*args, SV*);
6178 vecstr = (U8*)SvPVx(vecsv,veclen);
6179 utf = DO_UTF8(vecsv);
6181 else if (svix < svmax) {
6182 vecsv = svargs[svix++];
6183 vecstr = (U8*)SvPVx(vecsv,veclen);
6184 utf = DO_UTF8(vecsv);
6195 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6206 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6207 if (*(q + 1) == 'l') { /* lld, llf */
6234 uv = va_arg(*args, int);
6236 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6237 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6238 eptr = (char*)utf8buf;
6239 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6251 eptr = va_arg(*args, char*);
6253 #ifdef MACOS_TRADITIONAL
6254 /* On MacOS, %#s format is used for Pascal strings */
6259 elen = strlen(eptr);
6262 elen = sizeof nullstr - 1;
6265 else if (svix < svmax) {
6266 argsv = svargs[svix++];
6267 eptr = SvPVx(argsv, elen);
6268 if (DO_UTF8(argsv)) {
6269 if (has_precis && precis < elen) {
6271 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6274 if (width) { /* fudge width (can't fudge elen) */
6275 width += elen - sv_len_utf8(argsv);
6284 * The "%_" hack might have to be changed someday,
6285 * if ISO or ANSI decide to use '_' for something.
6286 * So we keep it hidden from users' code.
6290 argsv = va_arg(*args,SV*);
6291 eptr = SvPVx(argsv, elen);
6297 if (has_precis && elen > precis)
6307 uv = PTR2UV(va_arg(*args, void*));
6309 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6329 iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
6339 case 'h': iv = (short)va_arg(*args, int); break;
6340 default: iv = va_arg(*args, int); break;
6341 case 'l': iv = va_arg(*args, long); break;
6342 case 'V': iv = va_arg(*args, IV); break;
6344 case 'q': iv = va_arg(*args, Quad_t); break;
6349 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6351 case 'h': iv = (short)iv; break;
6353 case 'l': iv = (long)iv; break;
6356 case 'q': iv = (Quad_t)iv; break;
6363 esignbuf[esignlen++] = plus;
6367 esignbuf[esignlen++] = '-';
6411 uv = utf8_to_uv_chk(vecstr, &ulen, 0);
6421 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6422 default: uv = va_arg(*args, unsigned); break;
6423 case 'l': uv = va_arg(*args, unsigned long); break;
6424 case 'V': uv = va_arg(*args, UV); break;
6426 case 'q': uv = va_arg(*args, Quad_t); break;
6431 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6433 case 'h': uv = (unsigned short)uv; break;
6435 case 'l': uv = (unsigned long)uv; break;
6438 case 'q': uv = (Quad_t)uv; break;
6444 eptr = ebuf + sizeof ebuf;
6450 p = (char*)((c == 'X')
6451 ? "0123456789ABCDEF" : "0123456789abcdef");
6457 esignbuf[esignlen++] = '0';
6458 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6464 *--eptr = '0' + dig;
6466 if (alt && *eptr != '0')
6472 *--eptr = '0' + dig;
6475 esignbuf[esignlen++] = '0';
6476 esignbuf[esignlen++] = 'b';
6479 default: /* it had better be ten or less */
6480 #if defined(PERL_Y2KWARN)
6481 if (ckWARN(WARN_Y2K)) {
6483 char *s = SvPV(sv,n);
6484 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6485 && (n == 2 || !isDIGIT(s[n-3])))
6487 Perl_warner(aTHX_ WARN_Y2K,
6488 "Possible Y2K bug: %%%c %s",
6489 c, "format string following '19'");
6495 *--eptr = '0' + dig;
6496 } while (uv /= base);
6499 elen = (ebuf + sizeof ebuf) - eptr;
6502 zeros = precis - elen;
6503 else if (precis == 0 && elen == 1 && *eptr == '0')
6508 /* FLOATING POINT */
6511 c = 'f'; /* maybe %F isn't supported here */
6517 /* This is evil, but floating point is even more evil */
6521 nv = va_arg(*args, NV);
6523 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6526 if (c != 'e' && c != 'E') {
6528 (void)Perl_frexp(nv, &i);
6529 if (i == PERL_INT_MIN)
6530 Perl_die(aTHX_ "panic: frexp");
6532 need = BIT_DIGITS(i);
6534 need += has_precis ? precis : 6; /* known default */
6538 need += 20; /* fudge factor */
6539 if (PL_efloatsize < need) {
6540 Safefree(PL_efloatbuf);
6541 PL_efloatsize = need + 20; /* more fudge */
6542 New(906, PL_efloatbuf, PL_efloatsize, char);
6543 PL_efloatbuf[0] = '\0';
6546 eptr = ebuf + sizeof ebuf;
6549 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
6551 /* Copy the one or more characters in a long double
6552 * format before the 'base' ([efgEFG]) character to
6553 * the format string. */
6554 static char const prifldbl[] = PERL_PRIfldbl;
6555 char const *p = prifldbl + sizeof(prifldbl) - 3;
6556 while (p >= prifldbl) { *--eptr = *p--; }
6561 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6566 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6579 STORE_NUMERIC_STANDARD_SET_LOCAL();
6580 #ifdef USE_LOCALE_NUMERIC
6581 if (!was_standard && maybe_tainted)
6582 *maybe_tainted = TRUE;
6584 (void)sprintf(PL_efloatbuf, eptr, nv);
6585 RESTORE_NUMERIC_STANDARD();
6588 eptr = PL_efloatbuf;
6589 elen = strlen(PL_efloatbuf);
6596 i = SvCUR(sv) - origlen;
6599 case 'h': *(va_arg(*args, short*)) = i; break;
6600 default: *(va_arg(*args, int*)) = i; break;
6601 case 'l': *(va_arg(*args, long*)) = i; break;
6602 case 'V': *(va_arg(*args, IV*)) = i; break;
6604 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6608 else if (svix < svmax)
6609 sv_setuv_mg(svargs[svix++], (UV)i);
6610 continue; /* not "break" */
6617 if (!args && ckWARN(WARN_PRINTF) &&
6618 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6619 SV *msg = sv_newmortal();
6620 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6621 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6624 Perl_sv_catpvf(aTHX_ msg,
6625 "\"%%%c\"", c & 0xFF);
6627 Perl_sv_catpvf(aTHX_ msg,
6628 "\"%%\\%03"UVof"\"",
6631 sv_catpv(msg, "end of string");
6632 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6635 /* output mangled stuff ... */
6641 /* ... right here, because formatting flags should not apply */
6642 SvGROW(sv, SvCUR(sv) + elen + 1);
6644 memcpy(p, eptr, elen);
6647 SvCUR(sv) = p - SvPVX(sv);
6648 continue; /* not "break" */
6651 have = esignlen + zeros + elen;
6652 need = (have > width ? have : width);
6655 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6657 if (esignlen && fill == '0') {
6658 for (i = 0; i < esignlen; i++)
6662 memset(p, fill, gap);
6665 if (esignlen && fill != '0') {
6666 for (i = 0; i < esignlen; i++)
6670 for (i = zeros; i; i--)
6674 memcpy(p, eptr, elen);
6678 memset(p, ' ', gap);
6683 memcpy(p, dotstr, dotstrlen);
6687 vectorize = FALSE; /* done iterating over vecstr */
6692 SvCUR(sv) = p - SvPVX(sv);
6700 #if defined(USE_ITHREADS)
6702 #if defined(USE_THREADS)
6703 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6706 #ifndef GpREFCNT_inc
6707 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6711 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6712 #define av_dup(s) (AV*)sv_dup((SV*)s)
6713 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6714 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6715 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6716 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6717 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6718 #define io_dup(s) (IO*)sv_dup((SV*)s)
6719 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6720 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6721 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6722 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6723 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6726 Perl_re_dup(pTHX_ REGEXP *r)
6728 /* XXX fix when pmop->op_pmregexp becomes shared */
6729 return ReREFCNT_inc(r);
6733 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6737 return (PerlIO*)NULL;
6739 /* look for it in the table first */
6740 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6744 /* create anew and remember what it is */
6745 ret = PerlIO_fdupopen(fp);
6746 ptr_table_store(PL_ptr_table, fp, ret);
6751 Perl_dirp_dup(pTHX_ DIR *dp)
6760 Perl_gp_dup(pTHX_ GP *gp)
6765 /* look for it in the table first */
6766 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6770 /* create anew and remember what it is */
6771 Newz(0, ret, 1, GP);
6772 ptr_table_store(PL_ptr_table, gp, ret);
6775 ret->gp_refcnt = 0; /* must be before any other dups! */
6776 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6777 ret->gp_io = io_dup_inc(gp->gp_io);
6778 ret->gp_form = cv_dup_inc(gp->gp_form);
6779 ret->gp_av = av_dup_inc(gp->gp_av);
6780 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6781 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6782 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6783 ret->gp_cvgen = gp->gp_cvgen;
6784 ret->gp_flags = gp->gp_flags;
6785 ret->gp_line = gp->gp_line;
6786 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6791 Perl_mg_dup(pTHX_ MAGIC *mg)
6793 MAGIC *mgret = (MAGIC*)NULL;
6796 return (MAGIC*)NULL;
6797 /* look for it in the table first */
6798 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6802 for (; mg; mg = mg->mg_moremagic) {
6804 Newz(0, nmg, 1, MAGIC);
6808 mgprev->mg_moremagic = nmg;
6809 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6810 nmg->mg_private = mg->mg_private;
6811 nmg->mg_type = mg->mg_type;
6812 nmg->mg_flags = mg->mg_flags;
6813 if (mg->mg_type == 'r') {
6814 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6817 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6818 ? sv_dup_inc(mg->mg_obj)
6819 : sv_dup(mg->mg_obj);
6821 nmg->mg_len = mg->mg_len;
6822 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6823 if (mg->mg_ptr && mg->mg_type != 'g') {
6824 if (mg->mg_len >= 0) {
6825 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6826 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6827 AMT *amtp = (AMT*)mg->mg_ptr;
6828 AMT *namtp = (AMT*)nmg->mg_ptr;
6830 for (i = 1; i < NofAMmeth; i++) {
6831 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6835 else if (mg->mg_len == HEf_SVKEY)
6836 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6844 Perl_ptr_table_new(pTHX)
6847 Newz(0, tbl, 1, PTR_TBL_t);
6850 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6855 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6857 PTR_TBL_ENT_t *tblent;
6858 UV hash = PTR2UV(sv);
6860 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6861 for (; tblent; tblent = tblent->next) {
6862 if (tblent->oldval == sv)
6863 return tblent->newval;
6869 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6871 PTR_TBL_ENT_t *tblent, **otblent;
6872 /* XXX this may be pessimal on platforms where pointers aren't good
6873 * hash values e.g. if they grow faster in the most significant
6875 UV hash = PTR2UV(oldv);
6879 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6880 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6881 if (tblent->oldval == oldv) {
6882 tblent->newval = newv;
6887 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6888 tblent->oldval = oldv;
6889 tblent->newval = newv;
6890 tblent->next = *otblent;
6893 if (i && tbl->tbl_items > tbl->tbl_max)
6894 ptr_table_split(tbl);
6898 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6900 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6901 UV oldsize = tbl->tbl_max + 1;
6902 UV newsize = oldsize * 2;
6905 Renew(ary, newsize, PTR_TBL_ENT_t*);
6906 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6907 tbl->tbl_max = --newsize;
6909 for (i=0; i < oldsize; i++, ary++) {
6910 PTR_TBL_ENT_t **curentp, **entp, *ent;
6913 curentp = ary + oldsize;
6914 for (entp = ary, ent = *ary; ent; ent = *entp) {
6915 if ((newsize & PTR2UV(ent->oldval)) != i) {
6917 ent->next = *curentp;
6932 Perl_sv_dup(pTHX_ SV *sstr)
6936 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6938 /* look for it in the table first */
6939 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6943 /* create anew and remember what it is */
6945 ptr_table_store(PL_ptr_table, sstr, dstr);
6948 SvFLAGS(dstr) = SvFLAGS(sstr);
6949 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6950 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6953 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6954 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6955 PL_watch_pvx, SvPVX(sstr));
6958 switch (SvTYPE(sstr)) {
6963 SvANY(dstr) = new_XIV();
6964 SvIVX(dstr) = SvIVX(sstr);
6967 SvANY(dstr) = new_XNV();
6968 SvNVX(dstr) = SvNVX(sstr);
6971 SvANY(dstr) = new_XRV();
6972 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6975 SvANY(dstr) = new_XPV();
6976 SvCUR(dstr) = SvCUR(sstr);
6977 SvLEN(dstr) = SvLEN(sstr);
6979 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6980 else if (SvPVX(sstr) && SvLEN(sstr))
6981 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6983 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6986 SvANY(dstr) = new_XPVIV();
6987 SvCUR(dstr) = SvCUR(sstr);
6988 SvLEN(dstr) = SvLEN(sstr);
6989 SvIVX(dstr) = SvIVX(sstr);
6991 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6992 else if (SvPVX(sstr) && SvLEN(sstr))
6993 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6995 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6998 SvANY(dstr) = new_XPVNV();
6999 SvCUR(dstr) = SvCUR(sstr);
7000 SvLEN(dstr) = SvLEN(sstr);
7001 SvIVX(dstr) = SvIVX(sstr);
7002 SvNVX(dstr) = SvNVX(sstr);
7004 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7005 else if (SvPVX(sstr) && SvLEN(sstr))
7006 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7008 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7011 SvANY(dstr) = new_XPVMG();
7012 SvCUR(dstr) = SvCUR(sstr);
7013 SvLEN(dstr) = SvLEN(sstr);
7014 SvIVX(dstr) = SvIVX(sstr);
7015 SvNVX(dstr) = SvNVX(sstr);
7016 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7017 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7019 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7020 else if (SvPVX(sstr) && SvLEN(sstr))
7021 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7023 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7026 SvANY(dstr) = new_XPVBM();
7027 SvCUR(dstr) = SvCUR(sstr);
7028 SvLEN(dstr) = SvLEN(sstr);
7029 SvIVX(dstr) = SvIVX(sstr);
7030 SvNVX(dstr) = SvNVX(sstr);
7031 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7032 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7034 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7035 else if (SvPVX(sstr) && SvLEN(sstr))
7036 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7038 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7039 BmRARE(dstr) = BmRARE(sstr);
7040 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7041 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7044 SvANY(dstr) = new_XPVLV();
7045 SvCUR(dstr) = SvCUR(sstr);
7046 SvLEN(dstr) = SvLEN(sstr);
7047 SvIVX(dstr) = SvIVX(sstr);
7048 SvNVX(dstr) = SvNVX(sstr);
7049 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7050 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7052 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7053 else if (SvPVX(sstr) && SvLEN(sstr))
7054 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7056 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7057 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7058 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7059 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7060 LvTYPE(dstr) = LvTYPE(sstr);
7063 SvANY(dstr) = new_XPVGV();
7064 SvCUR(dstr) = SvCUR(sstr);
7065 SvLEN(dstr) = SvLEN(sstr);
7066 SvIVX(dstr) = SvIVX(sstr);
7067 SvNVX(dstr) = SvNVX(sstr);
7068 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7069 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7071 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7072 else if (SvPVX(sstr) && SvLEN(sstr))
7073 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7075 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7076 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7077 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7078 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7079 GvFLAGS(dstr) = GvFLAGS(sstr);
7080 GvGP(dstr) = gp_dup(GvGP(sstr));
7081 (void)GpREFCNT_inc(GvGP(dstr));
7084 SvANY(dstr) = new_XPVIO();
7085 SvCUR(dstr) = SvCUR(sstr);
7086 SvLEN(dstr) = SvLEN(sstr);
7087 SvIVX(dstr) = SvIVX(sstr);
7088 SvNVX(dstr) = SvNVX(sstr);
7089 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7090 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7092 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7093 else if (SvPVX(sstr) && SvLEN(sstr))
7094 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7096 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7097 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7098 if (IoOFP(sstr) == IoIFP(sstr))
7099 IoOFP(dstr) = IoIFP(dstr);
7101 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7102 /* PL_rsfp_filters entries have fake IoDIRP() */
7103 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7104 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7106 IoDIRP(dstr) = IoDIRP(sstr);
7107 IoLINES(dstr) = IoLINES(sstr);
7108 IoPAGE(dstr) = IoPAGE(sstr);
7109 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7110 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7111 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7112 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7113 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7114 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7115 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7116 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7117 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7118 IoTYPE(dstr) = IoTYPE(sstr);
7119 IoFLAGS(dstr) = IoFLAGS(sstr);
7122 SvANY(dstr) = new_XPVAV();
7123 SvCUR(dstr) = SvCUR(sstr);
7124 SvLEN(dstr) = SvLEN(sstr);
7125 SvIVX(dstr) = SvIVX(sstr);
7126 SvNVX(dstr) = SvNVX(sstr);
7127 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7128 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7129 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7130 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7131 if (AvARRAY((AV*)sstr)) {
7132 SV **dst_ary, **src_ary;
7133 SSize_t items = AvFILLp((AV*)sstr) + 1;
7135 src_ary = AvARRAY((AV*)sstr);
7136 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7137 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7138 SvPVX(dstr) = (char*)dst_ary;
7139 AvALLOC((AV*)dstr) = dst_ary;
7140 if (AvREAL((AV*)sstr)) {
7142 *dst_ary++ = sv_dup_inc(*src_ary++);
7146 *dst_ary++ = sv_dup(*src_ary++);
7148 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7149 while (items-- > 0) {
7150 *dst_ary++ = &PL_sv_undef;
7154 SvPVX(dstr) = Nullch;
7155 AvALLOC((AV*)dstr) = (SV**)NULL;
7159 SvANY(dstr) = new_XPVHV();
7160 SvCUR(dstr) = SvCUR(sstr);
7161 SvLEN(dstr) = SvLEN(sstr);
7162 SvIVX(dstr) = SvIVX(sstr);
7163 SvNVX(dstr) = SvNVX(sstr);
7164 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7165 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7166 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7167 if (HvARRAY((HV*)sstr)) {
7169 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7170 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7171 Newz(0, dxhv->xhv_array,
7172 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7173 while (i <= sxhv->xhv_max) {
7174 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7175 !!HvSHAREKEYS(sstr));
7178 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7181 SvPVX(dstr) = Nullch;
7182 HvEITER((HV*)dstr) = (HE*)NULL;
7184 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7185 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7188 SvANY(dstr) = new_XPVFM();
7189 FmLINES(dstr) = FmLINES(sstr);
7193 SvANY(dstr) = new_XPVCV();
7195 SvCUR(dstr) = SvCUR(sstr);
7196 SvLEN(dstr) = SvLEN(sstr);
7197 SvIVX(dstr) = SvIVX(sstr);
7198 SvNVX(dstr) = SvNVX(sstr);
7199 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7200 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7201 if (SvPVX(sstr) && SvLEN(sstr))
7202 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7204 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7205 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7206 CvSTART(dstr) = CvSTART(sstr);
7207 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7208 CvXSUB(dstr) = CvXSUB(sstr);
7209 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7210 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7211 CvDEPTH(dstr) = CvDEPTH(sstr);
7212 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7213 /* XXX padlists are real, but pretend to be not */
7214 AvREAL_on(CvPADLIST(sstr));
7215 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7216 AvREAL_off(CvPADLIST(sstr));
7217 AvREAL_off(CvPADLIST(dstr));
7220 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7221 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7222 CvFLAGS(dstr) = CvFLAGS(sstr);
7225 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7229 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7236 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7241 return (PERL_CONTEXT*)NULL;
7243 /* look for it in the table first */
7244 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7248 /* create anew and remember what it is */
7249 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7250 ptr_table_store(PL_ptr_table, cxs, ncxs);
7253 PERL_CONTEXT *cx = &cxs[ix];
7254 PERL_CONTEXT *ncx = &ncxs[ix];
7255 ncx->cx_type = cx->cx_type;
7256 if (CxTYPE(cx) == CXt_SUBST) {
7257 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7260 ncx->blk_oldsp = cx->blk_oldsp;
7261 ncx->blk_oldcop = cx->blk_oldcop;
7262 ncx->blk_oldretsp = cx->blk_oldretsp;
7263 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7264 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7265 ncx->blk_oldpm = cx->blk_oldpm;
7266 ncx->blk_gimme = cx->blk_gimme;
7267 switch (CxTYPE(cx)) {
7269 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7270 ? cv_dup_inc(cx->blk_sub.cv)
7271 : cv_dup(cx->blk_sub.cv));
7272 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7273 ? av_dup_inc(cx->blk_sub.argarray)
7275 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7276 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7277 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7278 ncx->blk_sub.lval = cx->blk_sub.lval;
7281 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7282 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7283 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7284 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7285 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7288 ncx->blk_loop.label = cx->blk_loop.label;
7289 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7290 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7291 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7292 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7293 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7294 ? cx->blk_loop.iterdata
7295 : gv_dup((GV*)cx->blk_loop.iterdata));
7296 ncx->blk_loop.oldcurpad
7297 = (SV**)ptr_table_fetch(PL_ptr_table,
7298 cx->blk_loop.oldcurpad);
7299 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7300 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7301 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7302 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7303 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7306 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7307 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7308 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7309 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7322 Perl_si_dup(pTHX_ PERL_SI *si)
7327 return (PERL_SI*)NULL;
7329 /* look for it in the table first */
7330 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7334 /* create anew and remember what it is */
7335 Newz(56, nsi, 1, PERL_SI);
7336 ptr_table_store(PL_ptr_table, si, nsi);
7338 nsi->si_stack = av_dup_inc(si->si_stack);
7339 nsi->si_cxix = si->si_cxix;
7340 nsi->si_cxmax = si->si_cxmax;
7341 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7342 nsi->si_type = si->si_type;
7343 nsi->si_prev = si_dup(si->si_prev);
7344 nsi->si_next = si_dup(si->si_next);
7345 nsi->si_markoff = si->si_markoff;
7350 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7351 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7352 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7353 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7354 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7355 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7356 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7357 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7358 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7359 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7360 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7361 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7364 #define pv_dup_inc(p) SAVEPV(p)
7365 #define pv_dup(p) SAVEPV(p)
7366 #define svp_dup_inc(p,pp) any_dup(p,pp)
7369 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7376 /* look for it in the table first */
7377 ret = ptr_table_fetch(PL_ptr_table, v);
7381 /* see if it is part of the interpreter structure */
7382 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7383 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7391 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7393 ANY *ss = proto_perl->Tsavestack;
7394 I32 ix = proto_perl->Tsavestack_ix;
7395 I32 max = proto_perl->Tsavestack_max;
7408 void (*dptr) (void*);
7409 void (*dxptr) (pTHXo_ void*);
7412 Newz(54, nss, max, ANY);
7418 case SAVEt_ITEM: /* normal string */
7419 sv = (SV*)POPPTR(ss,ix);
7420 TOPPTR(nss,ix) = sv_dup_inc(sv);
7421 sv = (SV*)POPPTR(ss,ix);
7422 TOPPTR(nss,ix) = sv_dup_inc(sv);
7424 case SAVEt_SV: /* scalar reference */
7425 sv = (SV*)POPPTR(ss,ix);
7426 TOPPTR(nss,ix) = sv_dup_inc(sv);
7427 gv = (GV*)POPPTR(ss,ix);
7428 TOPPTR(nss,ix) = gv_dup_inc(gv);
7430 case SAVEt_GENERIC_PVREF: /* generic char* */
7431 c = (char*)POPPTR(ss,ix);
7432 TOPPTR(nss,ix) = pv_dup(c);
7433 ptr = POPPTR(ss,ix);
7434 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7436 case SAVEt_GENERIC_SVREF: /* generic sv */
7437 case SAVEt_SVREF: /* scalar reference */
7438 sv = (SV*)POPPTR(ss,ix);
7439 TOPPTR(nss,ix) = sv_dup_inc(sv);
7440 ptr = POPPTR(ss,ix);
7441 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7443 case SAVEt_AV: /* array reference */
7444 av = (AV*)POPPTR(ss,ix);
7445 TOPPTR(nss,ix) = av_dup_inc(av);
7446 gv = (GV*)POPPTR(ss,ix);
7447 TOPPTR(nss,ix) = gv_dup(gv);
7449 case SAVEt_HV: /* hash reference */
7450 hv = (HV*)POPPTR(ss,ix);
7451 TOPPTR(nss,ix) = hv_dup_inc(hv);
7452 gv = (GV*)POPPTR(ss,ix);
7453 TOPPTR(nss,ix) = gv_dup(gv);
7455 case SAVEt_INT: /* int reference */
7456 ptr = POPPTR(ss,ix);
7457 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7458 intval = (int)POPINT(ss,ix);
7459 TOPINT(nss,ix) = intval;
7461 case SAVEt_LONG: /* long reference */
7462 ptr = POPPTR(ss,ix);
7463 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7464 longval = (long)POPLONG(ss,ix);
7465 TOPLONG(nss,ix) = longval;
7467 case SAVEt_I32: /* I32 reference */
7468 case SAVEt_I16: /* I16 reference */
7469 case SAVEt_I8: /* I8 reference */
7470 ptr = POPPTR(ss,ix);
7471 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7475 case SAVEt_IV: /* IV reference */
7476 ptr = POPPTR(ss,ix);
7477 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7481 case SAVEt_SPTR: /* SV* reference */
7482 ptr = POPPTR(ss,ix);
7483 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7484 sv = (SV*)POPPTR(ss,ix);
7485 TOPPTR(nss,ix) = sv_dup(sv);
7487 case SAVEt_VPTR: /* random* reference */
7488 ptr = POPPTR(ss,ix);
7489 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7490 ptr = POPPTR(ss,ix);
7491 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7493 case SAVEt_PPTR: /* char* reference */
7494 ptr = POPPTR(ss,ix);
7495 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7496 c = (char*)POPPTR(ss,ix);
7497 TOPPTR(nss,ix) = pv_dup(c);
7499 case SAVEt_HPTR: /* HV* reference */
7500 ptr = POPPTR(ss,ix);
7501 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7502 hv = (HV*)POPPTR(ss,ix);
7503 TOPPTR(nss,ix) = hv_dup(hv);
7505 case SAVEt_APTR: /* AV* reference */
7506 ptr = POPPTR(ss,ix);
7507 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7508 av = (AV*)POPPTR(ss,ix);
7509 TOPPTR(nss,ix) = av_dup(av);
7512 gv = (GV*)POPPTR(ss,ix);
7513 TOPPTR(nss,ix) = gv_dup(gv);
7515 case SAVEt_GP: /* scalar reference */
7516 gp = (GP*)POPPTR(ss,ix);
7517 TOPPTR(nss,ix) = gp = gp_dup(gp);
7518 (void)GpREFCNT_inc(gp);
7519 gv = (GV*)POPPTR(ss,ix);
7520 TOPPTR(nss,ix) = gv_dup_inc(c);
7521 c = (char*)POPPTR(ss,ix);
7522 TOPPTR(nss,ix) = pv_dup(c);
7529 sv = (SV*)POPPTR(ss,ix);
7530 TOPPTR(nss,ix) = sv_dup_inc(sv);
7533 ptr = POPPTR(ss,ix);
7534 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7535 /* these are assumed to be refcounted properly */
7536 switch (((OP*)ptr)->op_type) {
7543 TOPPTR(nss,ix) = ptr;
7548 TOPPTR(nss,ix) = Nullop;
7553 TOPPTR(nss,ix) = Nullop;
7556 c = (char*)POPPTR(ss,ix);
7557 TOPPTR(nss,ix) = pv_dup_inc(c);
7560 longval = POPLONG(ss,ix);
7561 TOPLONG(nss,ix) = longval;
7564 hv = (HV*)POPPTR(ss,ix);
7565 TOPPTR(nss,ix) = hv_dup_inc(hv);
7566 c = (char*)POPPTR(ss,ix);
7567 TOPPTR(nss,ix) = pv_dup_inc(c);
7571 case SAVEt_DESTRUCTOR:
7572 ptr = POPPTR(ss,ix);
7573 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7574 dptr = POPDPTR(ss,ix);
7575 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7577 case SAVEt_DESTRUCTOR_X:
7578 ptr = POPPTR(ss,ix);
7579 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7580 dxptr = POPDXPTR(ss,ix);
7581 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7583 case SAVEt_REGCONTEXT:
7589 case SAVEt_STACK_POS: /* Position on Perl stack */
7593 case SAVEt_AELEM: /* array element */
7594 sv = (SV*)POPPTR(ss,ix);
7595 TOPPTR(nss,ix) = sv_dup_inc(sv);
7598 av = (AV*)POPPTR(ss,ix);
7599 TOPPTR(nss,ix) = av_dup_inc(av);
7601 case SAVEt_HELEM: /* hash element */
7602 sv = (SV*)POPPTR(ss,ix);
7603 TOPPTR(nss,ix) = sv_dup_inc(sv);
7604 sv = (SV*)POPPTR(ss,ix);
7605 TOPPTR(nss,ix) = sv_dup_inc(sv);
7606 hv = (HV*)POPPTR(ss,ix);
7607 TOPPTR(nss,ix) = hv_dup_inc(hv);
7610 ptr = POPPTR(ss,ix);
7611 TOPPTR(nss,ix) = ptr;
7618 av = (AV*)POPPTR(ss,ix);
7619 TOPPTR(nss,ix) = av_dup(av);
7622 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7634 perl_clone(PerlInterpreter *proto_perl, UV flags)
7637 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7640 #ifdef PERL_IMPLICIT_SYS
7641 return perl_clone_using(proto_perl, flags,
7643 proto_perl->IMemShared,
7644 proto_perl->IMemParse,
7654 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7655 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7656 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7657 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7658 struct IPerlDir* ipD, struct IPerlSock* ipS,
7659 struct IPerlProc* ipP)
7661 /* XXX many of the string copies here can be optimized if they're
7662 * constants; they need to be allocated as common memory and just
7663 * their pointers copied. */
7667 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7669 PERL_SET_THX(pPerl);
7670 # else /* !PERL_OBJECT */
7671 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7672 PERL_SET_THX(my_perl);
7675 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7680 # else /* !DEBUGGING */
7681 Zero(my_perl, 1, PerlInterpreter);
7682 # endif /* DEBUGGING */
7686 PL_MemShared = ipMS;
7694 # endif /* PERL_OBJECT */
7695 #else /* !PERL_IMPLICIT_SYS */
7697 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7698 PERL_SET_THX(my_perl);
7701 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7706 # else /* !DEBUGGING */
7707 Zero(my_perl, 1, PerlInterpreter);
7708 # endif /* DEBUGGING */
7709 #endif /* PERL_IMPLICIT_SYS */
7712 PL_xiv_arenaroot = NULL;
7714 PL_xnv_arenaroot = NULL;
7716 PL_xrv_arenaroot = NULL;
7718 PL_xpv_arenaroot = NULL;
7720 PL_xpviv_arenaroot = NULL;
7721 PL_xpviv_root = NULL;
7722 PL_xpvnv_arenaroot = NULL;
7723 PL_xpvnv_root = NULL;
7724 PL_xpvcv_arenaroot = NULL;
7725 PL_xpvcv_root = NULL;
7726 PL_xpvav_arenaroot = NULL;
7727 PL_xpvav_root = NULL;
7728 PL_xpvhv_arenaroot = NULL;
7729 PL_xpvhv_root = NULL;
7730 PL_xpvmg_arenaroot = NULL;
7731 PL_xpvmg_root = NULL;
7732 PL_xpvlv_arenaroot = NULL;
7733 PL_xpvlv_root = NULL;
7734 PL_xpvbm_arenaroot = NULL;
7735 PL_xpvbm_root = NULL;
7736 PL_he_arenaroot = NULL;
7738 PL_nice_chunk = NULL;
7739 PL_nice_chunk_size = 0;
7742 PL_sv_root = Nullsv;
7743 PL_sv_arenaroot = Nullsv;
7745 PL_debug = proto_perl->Idebug;
7747 /* create SV map for pointer relocation */
7748 PL_ptr_table = ptr_table_new();
7750 /* initialize these special pointers as early as possible */
7751 SvANY(&PL_sv_undef) = NULL;
7752 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7753 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7754 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7757 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7759 SvANY(&PL_sv_no) = new_XPVNV();
7761 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7762 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7763 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7764 SvCUR(&PL_sv_no) = 0;
7765 SvLEN(&PL_sv_no) = 1;
7766 SvNVX(&PL_sv_no) = 0;
7767 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7770 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7772 SvANY(&PL_sv_yes) = new_XPVNV();
7774 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7775 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7776 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7777 SvCUR(&PL_sv_yes) = 1;
7778 SvLEN(&PL_sv_yes) = 2;
7779 SvNVX(&PL_sv_yes) = 1;
7780 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7782 /* create shared string table */
7783 PL_strtab = newHV();
7784 HvSHAREKEYS_off(PL_strtab);
7785 hv_ksplit(PL_strtab, 512);
7786 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7788 PL_compiling = proto_perl->Icompiling;
7789 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7790 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7791 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7792 if (!specialWARN(PL_compiling.cop_warnings))
7793 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7794 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7796 /* pseudo environmental stuff */
7797 PL_origargc = proto_perl->Iorigargc;
7799 New(0, PL_origargv, i+1, char*);
7800 PL_origargv[i] = '\0';
7802 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7804 PL_envgv = gv_dup(proto_perl->Ienvgv);
7805 PL_incgv = gv_dup(proto_perl->Iincgv);
7806 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7807 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7808 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7809 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7812 PL_minus_c = proto_perl->Iminus_c;
7813 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7814 PL_localpatches = proto_perl->Ilocalpatches;
7815 PL_splitstr = proto_perl->Isplitstr;
7816 PL_preprocess = proto_perl->Ipreprocess;
7817 PL_minus_n = proto_perl->Iminus_n;
7818 PL_minus_p = proto_perl->Iminus_p;
7819 PL_minus_l = proto_perl->Iminus_l;
7820 PL_minus_a = proto_perl->Iminus_a;
7821 PL_minus_F = proto_perl->Iminus_F;
7822 PL_doswitches = proto_perl->Idoswitches;
7823 PL_dowarn = proto_perl->Idowarn;
7824 PL_doextract = proto_perl->Idoextract;
7825 PL_sawampersand = proto_perl->Isawampersand;
7826 PL_unsafe = proto_perl->Iunsafe;
7827 PL_inplace = SAVEPV(proto_perl->Iinplace);
7828 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7829 PL_perldb = proto_perl->Iperldb;
7830 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7832 /* magical thingies */
7833 /* XXX time(&PL_basetime) when asked for? */
7834 PL_basetime = proto_perl->Ibasetime;
7835 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7837 PL_maxsysfd = proto_perl->Imaxsysfd;
7838 PL_multiline = proto_perl->Imultiline;
7839 PL_statusvalue = proto_perl->Istatusvalue;
7841 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7844 /* shortcuts to various I/O objects */
7845 PL_stdingv = gv_dup(proto_perl->Istdingv);
7846 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7847 PL_defgv = gv_dup(proto_perl->Idefgv);
7848 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7849 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7850 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7852 /* shortcuts to regexp stuff */
7853 PL_replgv = gv_dup(proto_perl->Ireplgv);
7855 /* shortcuts to misc objects */
7856 PL_errgv = gv_dup(proto_perl->Ierrgv);
7858 /* shortcuts to debugging objects */
7859 PL_DBgv = gv_dup(proto_perl->IDBgv);
7860 PL_DBline = gv_dup(proto_perl->IDBline);
7861 PL_DBsub = gv_dup(proto_perl->IDBsub);
7862 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7863 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7864 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7865 PL_lineary = av_dup(proto_perl->Ilineary);
7866 PL_dbargs = av_dup(proto_perl->Idbargs);
7869 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7870 PL_curstash = hv_dup(proto_perl->Tcurstash);
7871 PL_debstash = hv_dup(proto_perl->Idebstash);
7872 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7873 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7875 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7876 PL_endav = av_dup_inc(proto_perl->Iendav);
7877 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7878 PL_initav = av_dup_inc(proto_perl->Iinitav);
7880 PL_sub_generation = proto_perl->Isub_generation;
7882 /* funky return mechanisms */
7883 PL_forkprocess = proto_perl->Iforkprocess;
7885 /* subprocess state */
7886 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7888 /* internal state */
7889 PL_tainting = proto_perl->Itainting;
7890 PL_maxo = proto_perl->Imaxo;
7891 if (proto_perl->Iop_mask)
7892 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7894 PL_op_mask = Nullch;
7896 /* current interpreter roots */
7897 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7898 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7899 PL_main_start = proto_perl->Imain_start;
7900 PL_eval_root = proto_perl->Ieval_root;
7901 PL_eval_start = proto_perl->Ieval_start;
7903 /* runtime control stuff */
7904 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7905 PL_copline = proto_perl->Icopline;
7907 PL_filemode = proto_perl->Ifilemode;
7908 PL_lastfd = proto_perl->Ilastfd;
7909 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7912 PL_gensym = proto_perl->Igensym;
7913 PL_preambled = proto_perl->Ipreambled;
7914 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7915 PL_laststatval = proto_perl->Ilaststatval;
7916 PL_laststype = proto_perl->Ilaststype;
7917 PL_mess_sv = Nullsv;
7919 PL_orslen = proto_perl->Iorslen;
7920 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7921 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7923 /* interpreter atexit processing */
7924 PL_exitlistlen = proto_perl->Iexitlistlen;
7925 if (PL_exitlistlen) {
7926 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7927 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7930 PL_exitlist = (PerlExitListEntry*)NULL;
7931 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7933 PL_profiledata = NULL;
7934 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7935 /* PL_rsfp_filters entries have fake IoDIRP() */
7936 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7938 PL_compcv = cv_dup(proto_perl->Icompcv);
7939 PL_comppad = av_dup(proto_perl->Icomppad);
7940 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7941 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7942 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7943 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7944 proto_perl->Tcurpad);
7946 #ifdef HAVE_INTERP_INTERN
7947 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7950 /* more statics moved here */
7951 PL_generation = proto_perl->Igeneration;
7952 PL_DBcv = cv_dup(proto_perl->IDBcv);
7954 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7955 PL_in_clean_all = proto_perl->Iin_clean_all;
7957 PL_uid = proto_perl->Iuid;
7958 PL_euid = proto_perl->Ieuid;
7959 PL_gid = proto_perl->Igid;
7960 PL_egid = proto_perl->Iegid;
7961 PL_nomemok = proto_perl->Inomemok;
7962 PL_an = proto_perl->Ian;
7963 PL_cop_seqmax = proto_perl->Icop_seqmax;
7964 PL_op_seqmax = proto_perl->Iop_seqmax;
7965 PL_evalseq = proto_perl->Ievalseq;
7966 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7967 PL_origalen = proto_perl->Iorigalen;
7968 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7969 PL_osname = SAVEPV(proto_perl->Iosname);
7970 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7971 PL_sighandlerp = proto_perl->Isighandlerp;
7974 PL_runops = proto_perl->Irunops;
7976 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7979 PL_cshlen = proto_perl->Icshlen;
7980 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7983 PL_lex_state = proto_perl->Ilex_state;
7984 PL_lex_defer = proto_perl->Ilex_defer;
7985 PL_lex_expect = proto_perl->Ilex_expect;
7986 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7987 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7988 PL_lex_starts = proto_perl->Ilex_starts;
7989 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7990 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7991 PL_lex_op = proto_perl->Ilex_op;
7992 PL_lex_inpat = proto_perl->Ilex_inpat;
7993 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7994 PL_lex_brackets = proto_perl->Ilex_brackets;
7995 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7996 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7997 PL_lex_casemods = proto_perl->Ilex_casemods;
7998 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7999 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8001 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8002 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8003 PL_nexttoke = proto_perl->Inexttoke;
8005 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8006 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8007 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8008 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8009 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8010 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8011 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8012 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8013 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8014 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8015 PL_pending_ident = proto_perl->Ipending_ident;
8016 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8018 PL_expect = proto_perl->Iexpect;
8020 PL_multi_start = proto_perl->Imulti_start;
8021 PL_multi_end = proto_perl->Imulti_end;
8022 PL_multi_open = proto_perl->Imulti_open;
8023 PL_multi_close = proto_perl->Imulti_close;
8025 PL_error_count = proto_perl->Ierror_count;
8026 PL_subline = proto_perl->Isubline;
8027 PL_subname = sv_dup_inc(proto_perl->Isubname);
8029 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8030 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8031 PL_padix = proto_perl->Ipadix;
8032 PL_padix_floor = proto_perl->Ipadix_floor;
8033 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8035 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8036 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8037 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8038 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8039 PL_last_lop_op = proto_perl->Ilast_lop_op;
8040 PL_in_my = proto_perl->Iin_my;
8041 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8043 PL_cryptseen = proto_perl->Icryptseen;
8046 PL_hints = proto_perl->Ihints;
8048 PL_amagic_generation = proto_perl->Iamagic_generation;
8050 #ifdef USE_LOCALE_COLLATE
8051 PL_collation_ix = proto_perl->Icollation_ix;
8052 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8053 PL_collation_standard = proto_perl->Icollation_standard;
8054 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8055 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8056 #endif /* USE_LOCALE_COLLATE */
8058 #ifdef USE_LOCALE_NUMERIC
8059 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8060 PL_numeric_standard = proto_perl->Inumeric_standard;
8061 PL_numeric_local = proto_perl->Inumeric_local;
8062 PL_numeric_radix = proto_perl->Inumeric_radix;
8063 #endif /* !USE_LOCALE_NUMERIC */
8065 /* utf8 character classes */
8066 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8067 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8068 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8069 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8070 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8071 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8072 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8073 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8074 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8075 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8076 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8077 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8078 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8079 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8080 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8081 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8082 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8085 PL_last_swash_hv = Nullhv; /* reinits on demand */
8086 PL_last_swash_klen = 0;
8087 PL_last_swash_key[0]= '\0';
8088 PL_last_swash_tmps = (U8*)NULL;
8089 PL_last_swash_slen = 0;
8091 /* perly.c globals */
8092 PL_yydebug = proto_perl->Iyydebug;
8093 PL_yynerrs = proto_perl->Iyynerrs;
8094 PL_yyerrflag = proto_perl->Iyyerrflag;
8095 PL_yychar = proto_perl->Iyychar;
8096 PL_yyval = proto_perl->Iyyval;
8097 PL_yylval = proto_perl->Iyylval;
8099 PL_glob_index = proto_perl->Iglob_index;
8100 PL_srand_called = proto_perl->Isrand_called;
8101 PL_uudmap['M'] = 0; /* reinits on demand */
8102 PL_bitcount = Nullch; /* reinits on demand */
8104 if (proto_perl->Ipsig_ptr) {
8105 int sig_num[] = { SIG_NUM };
8106 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8107 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8108 for (i = 1; PL_sig_name[i]; i++) {
8109 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8110 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8114 PL_psig_ptr = (SV**)NULL;
8115 PL_psig_name = (SV**)NULL;
8118 /* thrdvar.h stuff */
8121 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8122 PL_tmps_ix = proto_perl->Ttmps_ix;
8123 PL_tmps_max = proto_perl->Ttmps_max;
8124 PL_tmps_floor = proto_perl->Ttmps_floor;
8125 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8127 while (i <= PL_tmps_ix) {
8128 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8132 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8133 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8134 Newz(54, PL_markstack, i, I32);
8135 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8136 - proto_perl->Tmarkstack);
8137 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8138 - proto_perl->Tmarkstack);
8139 Copy(proto_perl->Tmarkstack, PL_markstack,
8140 PL_markstack_ptr - PL_markstack + 1, I32);
8142 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8143 * NOTE: unlike the others! */
8144 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8145 PL_scopestack_max = proto_perl->Tscopestack_max;
8146 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8147 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8149 /* next push_return() sets PL_retstack[PL_retstack_ix]
8150 * NOTE: unlike the others! */
8151 PL_retstack_ix = proto_perl->Tretstack_ix;
8152 PL_retstack_max = proto_perl->Tretstack_max;
8153 Newz(54, PL_retstack, PL_retstack_max, OP*);
8154 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8156 /* NOTE: si_dup() looks at PL_markstack */
8157 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8159 /* PL_curstack = PL_curstackinfo->si_stack; */
8160 PL_curstack = av_dup(proto_perl->Tcurstack);
8161 PL_mainstack = av_dup(proto_perl->Tmainstack);
8163 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8164 PL_stack_base = AvARRAY(PL_curstack);
8165 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8166 - proto_perl->Tstack_base);
8167 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8169 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8170 * NOTE: unlike the others! */
8171 PL_savestack_ix = proto_perl->Tsavestack_ix;
8172 PL_savestack_max = proto_perl->Tsavestack_max;
8173 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8174 PL_savestack = ss_dup(proto_perl);
8178 ENTER; /* perl_destruct() wants to LEAVE; */
8181 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8182 PL_top_env = &PL_start_env;
8184 PL_op = proto_perl->Top;
8187 PL_Xpv = (XPV*)NULL;
8188 PL_na = proto_perl->Tna;
8190 PL_statbuf = proto_perl->Tstatbuf;
8191 PL_statcache = proto_perl->Tstatcache;
8192 PL_statgv = gv_dup(proto_perl->Tstatgv);
8193 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8195 PL_timesbuf = proto_perl->Ttimesbuf;
8198 PL_tainted = proto_perl->Ttainted;
8199 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8200 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8201 PL_rs = sv_dup_inc(proto_perl->Trs);
8202 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8203 PL_ofslen = proto_perl->Tofslen;
8204 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8205 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8206 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8207 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8208 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8209 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8211 PL_restartop = proto_perl->Trestartop;
8212 PL_in_eval = proto_perl->Tin_eval;
8213 PL_delaymagic = proto_perl->Tdelaymagic;
8214 PL_dirty = proto_perl->Tdirty;
8215 PL_localizing = proto_perl->Tlocalizing;
8217 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8218 PL_protect = proto_perl->Tprotect;
8220 PL_errors = sv_dup_inc(proto_perl->Terrors);
8221 PL_av_fetch_sv = Nullsv;
8222 PL_hv_fetch_sv = Nullsv;
8223 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8224 PL_modcount = proto_perl->Tmodcount;
8225 PL_lastgotoprobe = Nullop;
8226 PL_dumpindent = proto_perl->Tdumpindent;
8228 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8229 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8230 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8231 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8232 PL_sortcxix = proto_perl->Tsortcxix;
8233 PL_efloatbuf = Nullch; /* reinits on demand */
8234 PL_efloatsize = 0; /* reinits on demand */
8238 PL_screamfirst = NULL;
8239 PL_screamnext = NULL;
8240 PL_maxscream = -1; /* reinits on demand */
8241 PL_lastscream = Nullsv;
8243 PL_watchaddr = NULL;
8244 PL_watchok = Nullch;
8246 PL_regdummy = proto_perl->Tregdummy;
8247 PL_regcomp_parse = Nullch;
8248 PL_regxend = Nullch;
8249 PL_regcode = (regnode*)NULL;
8252 PL_regprecomp = Nullch;
8257 PL_seen_zerolen = 0;
8259 PL_regcomp_rx = (regexp*)NULL;
8261 PL_colorset = 0; /* reinits PL_colors[] */
8262 /*PL_colors[6] = {0,0,0,0,0,0};*/
8263 PL_reg_whilem_seen = 0;
8264 PL_reginput = Nullch;
8267 PL_regstartp = (I32*)NULL;
8268 PL_regendp = (I32*)NULL;
8269 PL_reglastparen = (U32*)NULL;
8270 PL_regtill = Nullch;
8272 PL_reg_start_tmp = (char**)NULL;
8273 PL_reg_start_tmpl = 0;
8274 PL_regdata = (struct reg_data*)NULL;
8277 PL_reg_eval_set = 0;
8279 PL_regprogram = (regnode*)NULL;
8281 PL_regcc = (CURCUR*)NULL;
8282 PL_reg_call_cc = (struct re_cc_state*)NULL;
8283 PL_reg_re = (regexp*)NULL;
8284 PL_reg_ganch = Nullch;
8286 PL_reg_magic = (MAGIC*)NULL;
8288 PL_reg_oldcurpm = (PMOP*)NULL;
8289 PL_reg_curpm = (PMOP*)NULL;
8290 PL_reg_oldsaved = Nullch;
8291 PL_reg_oldsavedlen = 0;
8293 PL_reg_leftiter = 0;
8294 PL_reg_poscache = Nullch;
8295 PL_reg_poscache_size= 0;
8297 /* RE engine - function pointers */
8298 PL_regcompp = proto_perl->Tregcompp;
8299 PL_regexecp = proto_perl->Tregexecp;
8300 PL_regint_start = proto_perl->Tregint_start;
8301 PL_regint_string = proto_perl->Tregint_string;
8302 PL_regfree = proto_perl->Tregfree;
8304 PL_reginterp_cnt = 0;
8305 PL_reg_starttry = 0;
8308 return (PerlInterpreter*)pPerl;
8314 #else /* !USE_ITHREADS */
8320 #endif /* USE_ITHREADS */
8323 do_report_used(pTHXo_ SV *sv)
8325 if (SvTYPE(sv) != SVTYPEMASK) {
8326 PerlIO_printf(Perl_debug_log, "****\n");
8332 do_clean_objs(pTHXo_ SV *sv)
8336 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8337 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8338 if (SvWEAKREF(sv)) {
8349 /* XXX Might want to check arrays, etc. */
8352 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8354 do_clean_named_objs(pTHXo_ SV *sv)
8356 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8357 if ( SvOBJECT(GvSV(sv)) ||
8358 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8359 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8360 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8361 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8363 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8371 do_clean_all(pTHXo_ SV *sv)
8373 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8374 SvFLAGS(sv) |= SVf_BREAK;