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)
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
207 Safefree((void *)sva);
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
219 Perl_report_uninit(pTHX)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
237 * See comment in more_xiv() -- RAM.
239 PL_xiv_root = *(IV**)xiv;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
245 S_del_xiv(pTHX_ XPVIV *p)
247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
249 *(IV**)xiv = PL_xiv_root;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
268 while (xiv < xivend) {
269 *(IV**)xiv = (IV *)(xiv + 1);
283 PL_xnv_root = *(NV**)xnv;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
289 S_del_xnv(pTHX_ XPVNV *p)
291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
293 *(NV**)xnv = PL_xnv_root;
303 New(711, xnv, 1008/sizeof(NV), NV);
304 xnvend = &xnv[1008 / sizeof(NV) - 1];
305 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
307 while (xnv < xnvend) {
308 *(NV**)xnv = (NV*)(xnv + 1);
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
328 S_del_xrv(pTHX_ XRV *p)
331 p->xrv_rv = (SV*)PL_xrv_root;
340 register XRV* xrvend;
341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
365 S_del_xpv(pTHX_ XPV *p)
368 p->xpv_pv = (char*)PL_xpv_root;
377 register XPV* xpvend;
378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
402 S_del_xpviv(pTHX_ XPVIV *p)
405 p->xpv_pv = (char*)PL_xpviv_root;
414 register XPVIV* xpviv;
415 register XPVIV* xpvivend;
416 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417 xpviv = PL_xpviv_root;
418 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419 while (xpviv < xpvivend) {
420 xpviv->xpv_pv = (char*)(xpviv + 1);
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
441 S_del_xpvnv(pTHX_ XPVNV *p)
444 p->xpv_pv = (char*)PL_xpvnv_root;
453 register XPVNV* xpvnv;
454 register XPVNV* xpvnvend;
455 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456 xpvnv = PL_xpvnv_root;
457 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458 while (xpvnv < xpvnvend) {
459 xpvnv->xpv_pv = (char*)(xpvnv + 1);
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
481 S_del_xpvcv(pTHX_ XPVCV *p)
484 p->xpv_pv = (char*)PL_xpvcv_root;
493 register XPVCV* xpvcv;
494 register XPVCV* xpvcvend;
495 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496 xpvcv = PL_xpvcv_root;
497 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498 while (xpvcv < xpvcvend) {
499 xpvcv->xpv_pv = (char*)(xpvcv + 1);
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
521 S_del_xpvav(pTHX_ XPVAV *p)
524 p->xav_array = (char*)PL_xpvav_root;
533 register XPVAV* xpvav;
534 register XPVAV* xpvavend;
535 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536 xpvav = PL_xpvav_root;
537 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538 while (xpvav < xpvavend) {
539 xpvav->xav_array = (char*)(xpvav + 1);
542 xpvav->xav_array = 0;
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
561 S_del_xpvhv(pTHX_ XPVHV *p)
564 p->xhv_array = (char*)PL_xpvhv_root;
573 register XPVHV* xpvhv;
574 register XPVHV* xpvhvend;
575 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576 xpvhv = PL_xpvhv_root;
577 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578 while (xpvhv < xpvhvend) {
579 xpvhv->xhv_array = (char*)(xpvhv + 1);
582 xpvhv->xhv_array = 0;
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
600 S_del_xpvmg(pTHX_ XPVMG *p)
603 p->xpv_pv = (char*)PL_xpvmg_root;
612 register XPVMG* xpvmg;
613 register XPVMG* xpvmgend;
614 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615 xpvmg = PL_xpvmg_root;
616 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617 while (xpvmg < xpvmgend) {
618 xpvmg->xpv_pv = (char*)(xpvmg + 1);
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
640 S_del_xpvlv(pTHX_ XPVLV *p)
643 p->xpv_pv = (char*)PL_xpvlv_root;
652 register XPVLV* xpvlv;
653 register XPVLV* xpvlvend;
654 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655 xpvlv = PL_xpvlv_root;
656 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657 while (xpvlv < xpvlvend) {
658 xpvlv->xpv_pv = (char*)(xpvlv + 1);
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
679 S_del_xpvbm(pTHX_ XPVBM *p)
682 p->xpv_pv = (char*)PL_xpvbm_root;
691 register XPVBM* xpvbm;
692 register XPVBM* xpvbmend;
693 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694 xpvbm = PL_xpvbm_root;
695 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696 while (xpvbm < xpvbmend) {
697 xpvbm->xpv_pv = (char*)(xpvbm + 1);
704 # define my_safemalloc(s) (void*)safexmalloc(717,s)
705 # define my_safefree(p) safexfree((char*)p)
707 # define my_safemalloc(s) (void*)safemalloc(s)
708 # define my_safefree(p) safefree((char*)p)
713 #define new_XIV() my_safemalloc(sizeof(XPVIV))
714 #define del_XIV(p) my_safefree(p)
716 #define new_XNV() my_safemalloc(sizeof(XPVNV))
717 #define del_XNV(p) my_safefree(p)
719 #define new_XRV() my_safemalloc(sizeof(XRV))
720 #define del_XRV(p) my_safefree(p)
722 #define new_XPV() my_safemalloc(sizeof(XPV))
723 #define del_XPV(p) my_safefree(p)
725 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726 #define del_XPVIV(p) my_safefree(p)
728 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729 #define del_XPVNV(p) my_safefree(p)
731 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732 #define del_XPVCV(p) my_safefree(p)
734 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735 #define del_XPVAV(p) my_safefree(p)
737 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738 #define del_XPVHV(p) my_safefree(p)
740 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741 #define del_XPVMG(p) my_safefree(p)
743 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744 #define del_XPVLV(p) my_safefree(p)
746 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747 #define del_XPVBM(p) my_safefree(p)
751 #define new_XIV() (void*)new_xiv()
752 #define del_XIV(p) del_xiv((XPVIV*) p)
754 #define new_XNV() (void*)new_xnv()
755 #define del_XNV(p) del_xnv((XPVNV*) p)
757 #define new_XRV() (void*)new_xrv()
758 #define del_XRV(p) del_xrv((XRV*) p)
760 #define new_XPV() (void*)new_xpv()
761 #define del_XPV(p) del_xpv((XPV *)p)
763 #define new_XPVIV() (void*)new_xpviv()
764 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
766 #define new_XPVNV() (void*)new_xpvnv()
767 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
769 #define new_XPVCV() (void*)new_xpvcv()
770 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
772 #define new_XPVAV() (void*)new_xpvav()
773 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
775 #define new_XPVHV() (void*)new_xpvhv()
776 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
778 #define new_XPVMG() (void*)new_xpvmg()
779 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
781 #define new_XPVLV() (void*)new_xpvlv()
782 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
784 #define new_XPVBM() (void*)new_xpvbm()
785 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
789 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790 #define del_XPVGV(p) my_safefree(p)
792 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793 #define del_XPVFM(p) my_safefree(p)
795 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796 #define del_XPVIO(p) my_safefree(p)
799 =for apidoc sv_upgrade
801 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
808 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
818 if (SvTYPE(sv) == mt)
824 switch (SvTYPE(sv)) {
845 else if (mt < SVt_PVIV)
862 pv = (char*)SvRV(sv);
882 else if (mt == SVt_NV)
893 del_XPVIV(SvANY(sv));
903 del_XPVNV(SvANY(sv));
913 del_XPVMG(SvANY(sv));
916 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
921 Perl_croak(aTHX_ "Can't upgrade to undef");
923 SvANY(sv) = new_XIV();
927 SvANY(sv) = new_XNV();
931 SvANY(sv) = new_XRV();
935 SvANY(sv) = new_XPV();
941 SvANY(sv) = new_XPVIV();
951 SvANY(sv) = new_XPVNV();
959 SvANY(sv) = new_XPVMG();
969 SvANY(sv) = new_XPVLV();
983 SvANY(sv) = new_XPVAV();
998 SvANY(sv) = new_XPVHV();
1006 SvMAGIC(sv) = magic;
1007 SvSTASH(sv) = stash;
1014 SvANY(sv) = new_XPVCV();
1015 Zero(SvANY(sv), 1, XPVCV);
1021 SvMAGIC(sv) = magic;
1022 SvSTASH(sv) = stash;
1025 SvANY(sv) = new_XPVGV();
1031 SvMAGIC(sv) = magic;
1032 SvSTASH(sv) = stash;
1040 SvANY(sv) = new_XPVBM();
1046 SvMAGIC(sv) = magic;
1047 SvSTASH(sv) = stash;
1053 SvANY(sv) = new_XPVFM();
1054 Zero(SvANY(sv), 1, XPVFM);
1060 SvMAGIC(sv) = magic;
1061 SvSTASH(sv) = stash;
1064 SvANY(sv) = new_XPVIO();
1065 Zero(SvANY(sv), 1, XPVIO);
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
1073 IoPAGE_LEN(sv) = 60;
1076 SvFLAGS(sv) &= ~SVTYPEMASK;
1082 Perl_sv_backoff(pTHX_ register SV *sv)
1086 char *s = SvPVX(sv);
1087 SvLEN(sv) += SvIVX(sv);
1088 SvPVX(sv) -= SvIVX(sv);
1090 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1092 SvFLAGS(sv) &= ~SVf_OOK;
1099 Expands the character buffer in the SV. This will use C<sv_unref> and will
1100 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1107 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1111 #ifdef HAS_64K_LIMIT
1112 if (newlen >= 0x10000) {
1113 PerlIO_printf(Perl_debug_log,
1114 "Allocation too large: %"UVxf"\n", (UV)newlen);
1117 #endif /* HAS_64K_LIMIT */
1120 if (SvTYPE(sv) < SVt_PV) {
1121 sv_upgrade(sv, SVt_PV);
1124 else if (SvOOK(sv)) { /* pv is offset? */
1127 if (newlen > SvLEN(sv))
1128 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129 #ifdef HAS_64K_LIMIT
1130 if (newlen >= 0x10000)
1136 if (newlen > SvLEN(sv)) { /* need more room? */
1137 if (SvLEN(sv) && s) {
1138 #if defined(MYMALLOC) && !defined(LEAKTEST)
1139 STRLEN l = malloced_size((void*)SvPVX(sv));
1145 Renew(s,newlen,char);
1148 New(703,s,newlen,char);
1150 SvLEN_set(sv, newlen);
1156 =for apidoc sv_setiv
1158 Copies an integer into the given SV. Does not handle 'set' magic. See
1165 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1167 SV_CHECK_THINKFIRST(sv);
1168 switch (SvTYPE(sv)) {
1170 sv_upgrade(sv, SVt_IV);
1173 sv_upgrade(sv, SVt_PVNV);
1177 sv_upgrade(sv, SVt_PVIV);
1188 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189 PL_op_desc[PL_op->op_type]);
1192 (void)SvIOK_only(sv); /* validate number */
1198 =for apidoc sv_setiv_mg
1200 Like C<sv_setiv>, but also handles 'set' magic.
1206 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1213 =for apidoc sv_setuv
1215 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1222 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1230 =for apidoc sv_setuv_mg
1232 Like C<sv_setuv>, but also handles 'set' magic.
1238 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1245 =for apidoc sv_setnv
1247 Copies a double into the given SV. Does not handle 'set' magic. See
1254 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1256 SV_CHECK_THINKFIRST(sv);
1257 switch (SvTYPE(sv)) {
1260 sv_upgrade(sv, SVt_NV);
1265 sv_upgrade(sv, SVt_PVNV);
1276 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277 PL_op_name[PL_op->op_type]);
1281 (void)SvNOK_only(sv); /* validate number */
1286 =for apidoc sv_setnv_mg
1288 Like C<sv_setnv>, but also handles 'set' magic.
1294 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1301 S_not_a_number(pTHX_ SV *sv)
1307 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308 /* each *s can expand to 4 chars + "...\0",
1309 i.e. need room for 8 chars */
1311 for (s = SvPVX(sv); *s && d < limit; s++) {
1313 if (ch & 128 && !isPRINT_LC(ch)) {
1322 else if (ch == '\r') {
1326 else if (ch == '\f') {
1330 else if (ch == '\\') {
1334 else if (isPRINT_LC(ch))
1349 Perl_warner(aTHX_ WARN_NUMERIC,
1350 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351 PL_op_desc[PL_op->op_type]);
1353 Perl_warner(aTHX_ WARN_NUMERIC,
1354 "Argument \"%s\" isn't numeric", tmpbuf);
1357 /* the number can be converted to integer with atol() or atoll() */
1358 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1363 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1364 until proven guilty, assume that things are not that bad... */
1367 Perl_sv_2iv(pTHX_ register SV *sv)
1371 if (SvGMAGICAL(sv)) {
1376 return I_V(SvNVX(sv));
1378 if (SvPOKp(sv) && SvLEN(sv))
1381 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1383 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1389 if (SvTHINKFIRST(sv)) {
1392 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1393 return SvIV(tmpstr);
1394 return PTR2IV(SvRV(sv));
1396 if (SvREADONLY(sv) && !SvOK(sv)) {
1398 if (ckWARN(WARN_UNINITIALIZED))
1405 return (IV)(SvUVX(sv));
1412 /* We can cache the IV/UV value even if it not good enough
1413 * to reconstruct NV, since the conversion to PV will prefer
1417 if (SvTYPE(sv) == SVt_NV)
1418 sv_upgrade(sv, SVt_PVNV);
1421 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1422 SvIVX(sv) = I_V(SvNVX(sv));
1424 SvUVX(sv) = U_V(SvNVX(sv));
1427 DEBUG_c(PerlIO_printf(Perl_debug_log,
1428 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1432 return (IV)SvUVX(sv);
1435 else if (SvPOKp(sv) && SvLEN(sv)) {
1436 I32 numtype = looks_like_number(sv);
1438 /* We want to avoid a possible problem when we cache an IV which
1439 may be later translated to an NV, and the resulting NV is not
1440 the translation of the initial data.
1442 This means that if we cache such an IV, we need to cache the
1443 NV as well. Moreover, we trade speed for space, and do not
1444 cache the NV if not needed.
1446 if (numtype & IS_NUMBER_NOT_IV) {
1447 /* May be not an integer. Need to cache NV if we cache IV
1448 * - otherwise future conversion to NV will be wrong. */
1451 d = Atof(SvPVX(sv));
1453 if (SvTYPE(sv) < SVt_PVNV)
1454 sv_upgrade(sv, SVt_PVNV);
1458 #if defined(USE_LONG_DOUBLE)
1459 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1460 PTR2UV(sv), SvNVX(sv)));
1462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1463 PTR2UV(sv), SvNVX(sv)));
1465 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1466 SvIVX(sv) = I_V(SvNVX(sv));
1468 SvUVX(sv) = U_V(SvNVX(sv));
1474 /* The NV may be reconstructed from IV - safe to cache IV,
1475 which may be calculated by atol(). */
1476 if (SvTYPE(sv) == SVt_PV)
1477 sv_upgrade(sv, SVt_PVIV);
1479 SvIVX(sv) = Atol(SvPVX(sv));
1481 else { /* Not a number. Cache 0. */
1484 if (SvTYPE(sv) < SVt_PVIV)
1485 sv_upgrade(sv, SVt_PVIV);
1488 if (ckWARN(WARN_NUMERIC))
1494 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1496 if (SvTYPE(sv) < SVt_IV)
1497 /* Typically the caller expects that sv_any is not NULL now. */
1498 sv_upgrade(sv, SVt_IV);
1501 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1502 PTR2UV(sv),SvIVX(sv)));
1503 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1507 Perl_sv_2uv(pTHX_ register SV *sv)
1511 if (SvGMAGICAL(sv)) {
1516 return U_V(SvNVX(sv));
1517 if (SvPOKp(sv) && SvLEN(sv))
1520 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1522 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1528 if (SvTHINKFIRST(sv)) {
1531 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1532 return SvUV(tmpstr);
1533 return PTR2UV(SvRV(sv));
1535 if (SvREADONLY(sv) && !SvOK(sv)) {
1537 if (ckWARN(WARN_UNINITIALIZED))
1547 return (UV)SvIVX(sv);
1551 /* We can cache the IV/UV value even if it not good enough
1552 * to reconstruct NV, since the conversion to PV will prefer
1555 if (SvTYPE(sv) == SVt_NV)
1556 sv_upgrade(sv, SVt_PVNV);
1558 if (SvNVX(sv) >= -0.5) {
1560 SvUVX(sv) = U_V(SvNVX(sv));
1563 SvIVX(sv) = I_V(SvNVX(sv));
1565 DEBUG_c(PerlIO_printf(Perl_debug_log,
1566 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1569 (IV)(UV)SvIVX(sv)));
1570 return (UV)SvIVX(sv);
1573 else if (SvPOKp(sv) && SvLEN(sv)) {
1574 I32 numtype = looks_like_number(sv);
1576 /* We want to avoid a possible problem when we cache a UV which
1577 may be later translated to an NV, and the resulting NV is not
1578 the translation of the initial data.
1580 This means that if we cache such a UV, we need to cache the
1581 NV as well. Moreover, we trade speed for space, and do not
1582 cache the NV if not needed.
1584 if (numtype & IS_NUMBER_NOT_IV) {
1585 /* May be not an integer. Need to cache NV if we cache IV
1586 * - otherwise future conversion to NV will be wrong. */
1589 d = Atof(SvPVX(sv));
1591 if (SvTYPE(sv) < SVt_PVNV)
1592 sv_upgrade(sv, SVt_PVNV);
1596 #if defined(USE_LONG_DOUBLE)
1597 DEBUG_c(PerlIO_printf(Perl_debug_log,
1598 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1599 PTR2UV(sv), SvNVX(sv)));
1601 DEBUG_c(PerlIO_printf(Perl_debug_log,
1602 "0x%"UVxf" 2nv(%g)\n",
1603 PTR2UV(sv), SvNVX(sv)));
1605 if (SvNVX(sv) < -0.5) {
1606 SvIVX(sv) = I_V(SvNVX(sv));
1609 SvUVX(sv) = U_V(SvNVX(sv));
1613 else if (numtype & IS_NUMBER_NEG) {
1614 /* The NV may be reconstructed from IV - safe to cache IV,
1615 which may be calculated by atol(). */
1616 if (SvTYPE(sv) == SVt_PV)
1617 sv_upgrade(sv, SVt_PVIV);
1619 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1621 else if (numtype) { /* Non-negative */
1622 /* The NV may be reconstructed from UV - safe to cache UV,
1623 which may be calculated by strtoul()/atol. */
1624 if (SvTYPE(sv) == SVt_PV)
1625 sv_upgrade(sv, SVt_PVIV);
1627 (void)SvIsUV_on(sv);
1629 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1630 #else /* no atou(), but we know the number fits into IV... */
1631 /* The only problem may be if it is negative... */
1632 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1635 else { /* Not a number. Cache 0. */
1638 if (SvTYPE(sv) < SVt_PVIV)
1639 sv_upgrade(sv, SVt_PVIV);
1641 (void)SvIsUV_on(sv);
1642 SvUVX(sv) = 0; /* We assume that 0s have the
1643 same bitmap in IV and UV. */
1644 if (ckWARN(WARN_NUMERIC))
1649 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1651 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1654 if (SvTYPE(sv) < SVt_IV)
1655 /* Typically the caller expects that sv_any is not NULL now. */
1656 sv_upgrade(sv, SVt_IV);
1660 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1661 PTR2UV(sv),SvUVX(sv)));
1662 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1666 Perl_sv_2nv(pTHX_ register SV *sv)
1670 if (SvGMAGICAL(sv)) {
1674 if (SvPOKp(sv) && SvLEN(sv)) {
1676 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1678 return Atof(SvPVX(sv));
1682 return (NV)SvUVX(sv);
1684 return (NV)SvIVX(sv);
1687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1689 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1695 if (SvTHINKFIRST(sv)) {
1698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1699 return SvNV(tmpstr);
1700 return PTR2NV(SvRV(sv));
1702 if (SvREADONLY(sv) && !SvOK(sv)) {
1704 if (ckWARN(WARN_UNINITIALIZED))
1709 if (SvTYPE(sv) < SVt_NV) {
1710 if (SvTYPE(sv) == SVt_IV)
1711 sv_upgrade(sv, SVt_PVNV);
1713 sv_upgrade(sv, SVt_NV);
1714 #if defined(USE_LONG_DOUBLE)
1716 RESTORE_NUMERIC_STANDARD();
1717 PerlIO_printf(Perl_debug_log,
1718 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1719 PTR2UV(sv), SvNVX(sv));
1720 RESTORE_NUMERIC_LOCAL();
1724 RESTORE_NUMERIC_STANDARD();
1725 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1726 PTR2UV(sv), SvNVX(sv));
1727 RESTORE_NUMERIC_LOCAL();
1731 else if (SvTYPE(sv) < SVt_PVNV)
1732 sv_upgrade(sv, SVt_PVNV);
1734 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1736 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1738 else if (SvPOKp(sv) && SvLEN(sv)) {
1740 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1742 SvNVX(sv) = Atof(SvPVX(sv));
1746 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1748 if (SvTYPE(sv) < SVt_NV)
1749 /* Typically the caller expects that sv_any is not NULL now. */
1750 sv_upgrade(sv, SVt_NV);
1754 #if defined(USE_LONG_DOUBLE)
1756 RESTORE_NUMERIC_STANDARD();
1757 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1758 PTR2UV(sv), SvNVX(sv));
1759 RESTORE_NUMERIC_LOCAL();
1763 RESTORE_NUMERIC_STANDARD();
1764 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1765 PTR2UV(sv), SvNVX(sv));
1766 RESTORE_NUMERIC_LOCAL();
1773 S_asIV(pTHX_ SV *sv)
1775 I32 numtype = looks_like_number(sv);
1778 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1779 return Atol(SvPVX(sv));
1782 if (ckWARN(WARN_NUMERIC))
1785 d = Atof(SvPVX(sv));
1790 S_asUV(pTHX_ SV *sv)
1792 I32 numtype = looks_like_number(sv);
1795 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1796 return Strtoul(SvPVX(sv), Null(char**), 10);
1800 if (ckWARN(WARN_NUMERIC))
1803 return U_V(Atof(SvPVX(sv)));
1807 * Returns a combination of (advisory only - can get false negatives)
1808 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1810 * 0 if does not look like number.
1812 * In fact possible values are 0 and
1813 * IS_NUMBER_TO_INT_BY_ATOL 123
1814 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1815 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1816 * with a possible addition of IS_NUMBER_NEG.
1820 =for apidoc looks_like_number
1822 Test if an the content of an SV looks like a number (or is a
1829 Perl_looks_like_number(pTHX_ SV *sv)
1832 register char *send;
1833 register char *sbegin;
1834 register char *nbegin;
1842 else if (SvPOKp(sv))
1843 sbegin = SvPV(sv, len);
1846 send = sbegin + len;
1853 numtype = IS_NUMBER_NEG;
1860 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1861 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1865 /* next must be digit or the radix separator */
1869 } while (isDIGIT(*s));
1871 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1872 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1874 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1877 #ifdef USE_LOCALE_NUMERIC
1878 || IS_NUMERIC_RADIX(*s)
1882 numtype |= IS_NUMBER_NOT_IV;
1883 while (isDIGIT(*s)) /* optional digits after the radix */
1888 #ifdef USE_LOCALE_NUMERIC
1889 || IS_NUMERIC_RADIX(*s)
1893 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1894 /* no digits before the radix means we need digits after it */
1898 } while (isDIGIT(*s));
1906 /* we can have an optional exponent part */
1907 if (*s == 'e' || *s == 'E') {
1908 numtype &= ~IS_NUMBER_NEG;
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1911 if (*s == '+' || *s == '-')
1916 } while (isDIGIT(*s));
1925 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1926 return IS_NUMBER_TO_INT_BY_ATOL;
1931 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1934 return sv_2pv(sv, &n_a);
1937 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1939 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1941 char *ptr = buf + TYPE_CHARS(UV);
1955 *--ptr = '0' + (uv % 10);
1964 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1969 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1970 char *tmpbuf = tbuf;
1976 if (SvGMAGICAL(sv)) {
1984 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
1986 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
1991 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1996 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1998 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2005 if (SvTHINKFIRST(sv)) {
2008 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2009 return SvPV(tmpstr,*lp);
2016 switch (SvTYPE(sv)) {
2018 if ( ((SvFLAGS(sv) &
2019 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2020 == (SVs_OBJECT|SVs_RMG))
2021 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2022 && (mg = mg_find(sv, 'r'))) {
2024 regexp *re = (regexp *)mg->mg_obj;
2027 char *fptr = "msix";
2032 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2034 while((ch = *fptr++)) {
2036 reflags[left++] = ch;
2039 reflags[right--] = ch;
2044 reflags[left] = '-';
2048 mg->mg_len = re->prelen + 4 + left;
2049 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2050 Copy("(?", mg->mg_ptr, 2, char);
2051 Copy(reflags, mg->mg_ptr+2, left, char);
2052 Copy(":", mg->mg_ptr+left+2, 1, char);
2053 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2054 mg->mg_ptr[mg->mg_len - 1] = ')';
2055 mg->mg_ptr[mg->mg_len] = 0;
2057 PL_reginterp_cnt += re->program[0].next_off;
2069 case SVt_PVBM: s = "SCALAR"; break;
2070 case SVt_PVLV: s = "LVALUE"; break;
2071 case SVt_PVAV: s = "ARRAY"; break;
2072 case SVt_PVHV: s = "HASH"; break;
2073 case SVt_PVCV: s = "CODE"; break;
2074 case SVt_PVGV: s = "GLOB"; break;
2075 case SVt_PVFM: s = "FORMAT"; break;
2076 case SVt_PVIO: s = "IO"; break;
2077 default: s = "UNKNOWN"; break;
2081 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2084 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2090 if (SvREADONLY(sv) && !SvOK(sv)) {
2092 if (ckWARN(WARN_UNINITIALIZED))
2098 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2099 /* XXXX 64-bit? IV may have better precision... */
2100 /* I tried changing this for to be 64-bit-aware and
2101 * the t/op/numconvert.t became very, very, angry.
2103 if (SvTYPE(sv) < SVt_PVNV)
2104 sv_upgrade(sv, SVt_PVNV);
2107 olderrno = errno; /* some Xenix systems wipe out errno here */
2109 if (SvNVX(sv) == 0.0)
2110 (void)strcpy(s,"0");
2114 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2117 #ifdef FIXNEGATIVEZERO
2118 if (*s == '-' && s[1] == '0' && !s[2])
2127 else if (SvIOKp(sv)) {
2128 U32 isIOK = SvIOK(sv);
2129 U32 isUIOK = SvIsUV(sv);
2130 char buf[TYPE_CHARS(UV)];
2133 if (SvTYPE(sv) < SVt_PVIV)
2134 sv_upgrade(sv, SVt_PVIV);
2136 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2138 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2139 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2140 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2141 SvCUR_set(sv, ebuf - ptr);
2154 if (ckWARN(WARN_UNINITIALIZED)
2155 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2160 if (SvTYPE(sv) < SVt_PV)
2161 /* Typically the caller expects that sv_any is not NULL now. */
2162 sv_upgrade(sv, SVt_PV);
2165 *lp = s - SvPVX(sv);
2168 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2169 PTR2UV(sv),SvPVX(sv)));
2173 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2174 /* Sneaky stuff here */
2178 tsv = newSVpv(tmpbuf, 0);
2194 len = strlen(tmpbuf);
2196 #ifdef FIXNEGATIVEZERO
2197 if (len == 2 && t[0] == '-' && t[1] == '0') {
2202 (void)SvUPGRADE(sv, SVt_PV);
2204 s = SvGROW(sv, len + 1);
2213 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2216 return sv_2pvbyte(sv, &n_a);
2220 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2222 return sv_2pv(sv,lp);
2226 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2229 return sv_2pvutf8(sv, &n_a);
2233 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2235 sv_utf8_upgrade(sv);
2236 return sv_2pv(sv,lp);
2239 /* This function is only called on magical items */
2241 Perl_sv_2bool(pTHX_ register SV *sv)
2251 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2252 return SvTRUE(tmpsv);
2253 return SvRV(sv) != 0;
2256 register XPV* Xpvtmp;
2257 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2258 (*Xpvtmp->xpv_pv > '0' ||
2259 Xpvtmp->xpv_cur > 1 ||
2260 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2267 return SvIVX(sv) != 0;
2270 return SvNVX(sv) != 0.0;
2278 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2283 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2286 /* This function could be much more efficient if we had a FLAG
2287 * to signal if there are any hibit chars in the string
2290 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2297 SvGROW(sv, SvCUR(sv) + hicount + 1);
2299 src = SvEND(sv) - 1;
2300 SvCUR_set(sv, SvCUR(sv) + hicount);
2301 dst = SvEND(sv) - 1;
2306 uv_to_utf8((U8*)dst, (U8)*src--);
2319 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2321 if (SvPOK(sv) && SvUTF8(sv)) {
2322 char *c = SvPVX(sv);
2324 /* need to figure out if this is possible at all first */
2325 while (c < SvEND(sv)) {
2328 UV uv = utf8_to_uv((U8*)c, &len);
2333 /* XXX might want to make a callback here instead */
2334 Perl_croak(aTHX_ "Big byte");
2347 char *src = first_hi;
2348 char *dst = first_hi;
2349 while (src < SvEND(sv)) {
2352 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2360 SvCUR_set(sv, dst - SvPVX(sv));
2368 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2370 sv_utf8_upgrade(sv);
2375 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2379 bool has_utf = FALSE;
2380 if (!sv_utf8_downgrade(sv, TRUE))
2383 /* it is actually just a matter of turning the utf8 flag on, but
2384 * we want to make sure everything inside is valid utf8 first.
2387 while (c < SvEND(sv)) {
2390 (void)utf8_to_uv((U8*)c, &len);
2410 /* Note: sv_setsv() should not be called with a source string that needs
2411 * to be reused, since it may destroy the source string if it is marked
2416 =for apidoc sv_setsv
2418 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2419 The source SV may be destroyed if it is mortal. Does not handle 'set'
2420 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2427 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2430 register U32 sflags;
2436 SV_CHECK_THINKFIRST(dstr);
2438 sstr = &PL_sv_undef;
2439 stype = SvTYPE(sstr);
2440 dtype = SvTYPE(dstr);
2444 /* There's a lot of redundancy below but we're going for speed here */
2449 if (dtype != SVt_PVGV) {
2450 (void)SvOK_off(dstr);
2458 sv_upgrade(dstr, SVt_IV);
2461 sv_upgrade(dstr, SVt_PVNV);
2465 sv_upgrade(dstr, SVt_PVIV);
2468 (void)SvIOK_only(dstr);
2469 SvIVX(dstr) = SvIVX(sstr);
2482 sv_upgrade(dstr, SVt_NV);
2487 sv_upgrade(dstr, SVt_PVNV);
2490 SvNVX(dstr) = SvNVX(sstr);
2491 (void)SvNOK_only(dstr);
2499 sv_upgrade(dstr, SVt_RV);
2500 else if (dtype == SVt_PVGV &&
2501 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2504 if (GvIMPORTED(dstr) != GVf_IMPORTED
2505 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2507 GvIMPORTED_on(dstr);
2518 sv_upgrade(dstr, SVt_PV);
2521 if (dtype < SVt_PVIV)
2522 sv_upgrade(dstr, SVt_PVIV);
2525 if (dtype < SVt_PVNV)
2526 sv_upgrade(dstr, SVt_PVNV);
2533 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2534 PL_op_name[PL_op->op_type]);
2536 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2540 if (dtype <= SVt_PVGV) {
2542 if (dtype != SVt_PVGV) {
2543 char *name = GvNAME(sstr);
2544 STRLEN len = GvNAMELEN(sstr);
2545 sv_upgrade(dstr, SVt_PVGV);
2546 sv_magic(dstr, dstr, '*', name, len);
2547 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2548 GvNAME(dstr) = savepvn(name, len);
2549 GvNAMELEN(dstr) = len;
2550 SvFAKE_on(dstr); /* can coerce to non-glob */
2552 /* ahem, death to those who redefine active sort subs */
2553 else if (PL_curstackinfo->si_type == PERLSI_SORT
2554 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2555 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2557 (void)SvOK_off(dstr);
2558 GvINTRO_off(dstr); /* one-shot flag */
2560 GvGP(dstr) = gp_ref(GvGP(sstr));
2562 if (GvIMPORTED(dstr) != GVf_IMPORTED
2563 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2565 GvIMPORTED_on(dstr);
2573 if (SvGMAGICAL(sstr)) {
2575 if (SvTYPE(sstr) != stype) {
2576 stype = SvTYPE(sstr);
2577 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2581 if (stype == SVt_PVLV)
2582 (void)SvUPGRADE(dstr, SVt_PVNV);
2584 (void)SvUPGRADE(dstr, stype);
2587 sflags = SvFLAGS(sstr);
2589 if (sflags & SVf_ROK) {
2590 if (dtype >= SVt_PV) {
2591 if (dtype == SVt_PVGV) {
2592 SV *sref = SvREFCNT_inc(SvRV(sstr));
2594 int intro = GvINTRO(dstr);
2599 GvINTRO_off(dstr); /* one-shot flag */
2600 Newz(602,gp, 1, GP);
2601 GvGP(dstr) = gp_ref(gp);
2602 GvSV(dstr) = NEWSV(72,0);
2603 GvLINE(dstr) = CopLINE(PL_curcop);
2604 GvEGV(dstr) = (GV*)dstr;
2607 switch (SvTYPE(sref)) {
2610 SAVESPTR(GvAV(dstr));
2612 dref = (SV*)GvAV(dstr);
2613 GvAV(dstr) = (AV*)sref;
2614 if (!GvIMPORTED_AV(dstr)
2615 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2617 GvIMPORTED_AV_on(dstr);
2622 SAVESPTR(GvHV(dstr));
2624 dref = (SV*)GvHV(dstr);
2625 GvHV(dstr) = (HV*)sref;
2626 if (!GvIMPORTED_HV(dstr)
2627 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2629 GvIMPORTED_HV_on(dstr);
2634 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2635 SvREFCNT_dec(GvCV(dstr));
2636 GvCV(dstr) = Nullcv;
2637 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2638 PL_sub_generation++;
2640 SAVESPTR(GvCV(dstr));
2643 dref = (SV*)GvCV(dstr);
2644 if (GvCV(dstr) != (CV*)sref) {
2645 CV* cv = GvCV(dstr);
2647 if (!GvCVGEN((GV*)dstr) &&
2648 (CvROOT(cv) || CvXSUB(cv)))
2650 SV *const_sv = cv_const_sv(cv);
2651 bool const_changed = TRUE;
2653 const_changed = sv_cmp(const_sv,
2654 op_const_sv(CvSTART((CV*)sref),
2656 /* ahem, death to those who redefine
2657 * active sort subs */
2658 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2659 PL_sortcop == CvSTART(cv))
2661 "Can't redefine active sort subroutine %s",
2662 GvENAME((GV*)dstr));
2663 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2664 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2665 "Constant subroutine %s redefined"
2666 : "Subroutine %s redefined",
2667 GvENAME((GV*)dstr));
2669 cv_ckproto(cv, (GV*)dstr,
2670 SvPOK(sref) ? SvPVX(sref) : Nullch);
2672 GvCV(dstr) = (CV*)sref;
2673 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2674 GvASSUMECV_on(dstr);
2675 PL_sub_generation++;
2677 if (!GvIMPORTED_CV(dstr)
2678 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2680 GvIMPORTED_CV_on(dstr);
2685 SAVESPTR(GvIOp(dstr));
2687 dref = (SV*)GvIOp(dstr);
2688 GvIOp(dstr) = (IO*)sref;
2692 SAVESPTR(GvSV(dstr));
2694 dref = (SV*)GvSV(dstr);
2696 if (!GvIMPORTED_SV(dstr)
2697 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2699 GvIMPORTED_SV_on(dstr);
2711 (void)SvOOK_off(dstr); /* backoff */
2713 Safefree(SvPVX(dstr));
2714 SvLEN(dstr)=SvCUR(dstr)=0;
2717 (void)SvOK_off(dstr);
2718 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2720 if (sflags & SVp_NOK) {
2722 SvNVX(dstr) = SvNVX(sstr);
2724 if (sflags & SVp_IOK) {
2725 (void)SvIOK_on(dstr);
2726 SvIVX(dstr) = SvIVX(sstr);
2730 if (SvAMAGIC(sstr)) {
2734 else if (sflags & SVp_POK) {
2737 * Check to see if we can just swipe the string. If so, it's a
2738 * possible small lose on short strings, but a big win on long ones.
2739 * It might even be a win on short strings if SvPVX(dstr)
2740 * has to be allocated and SvPVX(sstr) has to be freed.
2743 if (SvTEMP(sstr) && /* slated for free anyway? */
2744 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2745 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2747 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2749 SvFLAGS(dstr) &= ~SVf_OOK;
2750 Safefree(SvPVX(dstr) - SvIVX(dstr));
2752 else if (SvLEN(dstr))
2753 Safefree(SvPVX(dstr));
2755 (void)SvPOK_only(dstr);
2756 SvPV_set(dstr, SvPVX(sstr));
2757 SvLEN_set(dstr, SvLEN(sstr));
2758 SvCUR_set(dstr, SvCUR(sstr));
2765 (void)SvOK_off(sstr);
2766 SvPV_set(sstr, Nullch);
2771 else { /* have to copy actual string */
2772 STRLEN len = SvCUR(sstr);
2774 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2775 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2776 SvCUR_set(dstr, len);
2777 *SvEND(dstr) = '\0';
2778 (void)SvPOK_only(dstr);
2783 if (sflags & SVp_NOK) {
2785 SvNVX(dstr) = SvNVX(sstr);
2787 if (sflags & SVp_IOK) {
2788 (void)SvIOK_on(dstr);
2789 SvIVX(dstr) = SvIVX(sstr);
2794 else if (sflags & SVp_NOK) {
2795 SvNVX(dstr) = SvNVX(sstr);
2796 (void)SvNOK_only(dstr);
2798 (void)SvIOK_on(dstr);
2799 SvIVX(dstr) = SvIVX(sstr);
2800 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2805 else if (sflags & SVp_IOK) {
2806 (void)SvIOK_only(dstr);
2807 SvIVX(dstr) = SvIVX(sstr);
2812 if (dtype == SVt_PVGV) {
2813 if (ckWARN(WARN_MISC))
2814 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2817 (void)SvOK_off(dstr);
2823 =for apidoc sv_setsv_mg
2825 Like C<sv_setsv>, but also handles 'set' magic.
2831 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2833 sv_setsv(dstr,sstr);
2838 =for apidoc sv_setpvn
2840 Copies a string into an SV. The C<len> parameter indicates the number of
2841 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2847 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2849 register char *dptr;
2850 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2851 elicit a warning, but it won't hurt. */
2852 SV_CHECK_THINKFIRST(sv);
2857 (void)SvUPGRADE(sv, SVt_PV);
2859 SvGROW(sv, len + 1);
2861 Move(ptr,dptr,len,char);
2864 (void)SvPOK_only(sv); /* validate pointer */
2869 =for apidoc sv_setpvn_mg
2871 Like C<sv_setpvn>, but also handles 'set' magic.
2877 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2879 sv_setpvn(sv,ptr,len);
2884 =for apidoc sv_setpv
2886 Copies a string into an SV. The string must be null-terminated. Does not
2887 handle 'set' magic. See C<sv_setpv_mg>.
2893 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2895 register STRLEN len;
2897 SV_CHECK_THINKFIRST(sv);
2903 (void)SvUPGRADE(sv, SVt_PV);
2905 SvGROW(sv, len + 1);
2906 Move(ptr,SvPVX(sv),len+1,char);
2908 (void)SvPOK_only(sv); /* validate pointer */
2913 =for apidoc sv_setpv_mg
2915 Like C<sv_setpv>, but also handles 'set' magic.
2921 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2928 =for apidoc sv_usepvn
2930 Tells an SV to use C<ptr> to find its string value. Normally the string is
2931 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2932 The C<ptr> should point to memory that was allocated by C<malloc>. The
2933 string length, C<len>, must be supplied. This function will realloc the
2934 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2935 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2936 See C<sv_usepvn_mg>.
2942 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2944 SV_CHECK_THINKFIRST(sv);
2945 (void)SvUPGRADE(sv, SVt_PV);
2950 (void)SvOOK_off(sv);
2951 if (SvPVX(sv) && SvLEN(sv))
2952 Safefree(SvPVX(sv));
2953 Renew(ptr, len+1, char);
2956 SvLEN_set(sv, len+1);
2958 (void)SvPOK_only(sv); /* validate pointer */
2963 =for apidoc sv_usepvn_mg
2965 Like C<sv_usepvn>, but also handles 'set' magic.
2971 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2973 sv_usepvn(sv,ptr,len);
2978 Perl_sv_force_normal(pTHX_ register SV *sv)
2980 if (SvREADONLY(sv)) {
2982 if (PL_curcop != &PL_compiling)
2983 Perl_croak(aTHX_ PL_no_modify);
2987 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2994 Efficient removal of characters from the beginning of the string buffer.
2995 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2996 the string buffer. The C<ptr> becomes the first character of the adjusted
3003 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3007 register STRLEN delta;
3009 if (!ptr || !SvPOKp(sv))
3011 SV_CHECK_THINKFIRST(sv);
3012 if (SvTYPE(sv) < SVt_PVIV)
3013 sv_upgrade(sv,SVt_PVIV);
3016 if (!SvLEN(sv)) { /* make copy of shared string */
3017 char *pvx = SvPVX(sv);
3018 STRLEN len = SvCUR(sv);
3019 SvGROW(sv, len + 1);
3020 Move(pvx,SvPVX(sv),len,char);
3024 SvFLAGS(sv) |= SVf_OOK;
3026 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3027 delta = ptr - SvPVX(sv);
3035 =for apidoc sv_catpvn
3037 Concatenates the string onto the end of the string which is in the SV. The
3038 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3039 'set' magic. See C<sv_catpvn_mg>.
3045 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3050 junk = SvPV_force(sv, tlen);
3051 SvGROW(sv, tlen + len + 1);
3054 Move(ptr,SvPVX(sv)+tlen,len,char);
3057 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3062 =for apidoc sv_catpvn_mg
3064 Like C<sv_catpvn>, but also handles 'set' magic.
3070 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3072 sv_catpvn(sv,ptr,len);
3077 =for apidoc sv_catsv
3079 Concatenates the string from SV C<ssv> onto the end of the string in SV
3080 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3086 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3092 if ((s = SvPV(sstr, len))) {
3094 sv_utf8_upgrade(dstr);
3095 sv_catpvn(dstr,s,len);
3102 =for apidoc sv_catsv_mg
3104 Like C<sv_catsv>, but also handles 'set' magic.
3110 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3112 sv_catsv(dstr,sstr);
3117 =for apidoc sv_catpv
3119 Concatenates the string onto the end of the string which is in the SV.
3120 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3126 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3128 register STRLEN len;
3134 junk = SvPV_force(sv, tlen);
3136 SvGROW(sv, tlen + len + 1);
3139 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3141 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3146 =for apidoc sv_catpv_mg
3148 Like C<sv_catpv>, but also handles 'set' magic.
3154 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3161 Perl_newSV(pTHX_ STRLEN len)
3167 sv_upgrade(sv, SVt_PV);
3168 SvGROW(sv, len + 1);
3173 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3176 =for apidoc sv_magic
3178 Adds magic to an SV.
3184 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3188 if (SvREADONLY(sv)) {
3190 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3191 Perl_croak(aTHX_ PL_no_modify);
3193 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3194 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3201 (void)SvUPGRADE(sv, SVt_PVMG);
3203 Newz(702,mg, 1, MAGIC);
3204 mg->mg_moremagic = SvMAGIC(sv);
3207 if (!obj || obj == sv || how == '#' || how == 'r')
3211 mg->mg_obj = SvREFCNT_inc(obj);
3212 mg->mg_flags |= MGf_REFCOUNTED;
3215 mg->mg_len = namlen;
3218 mg->mg_ptr = savepvn(name, namlen);
3219 else if (namlen == HEf_SVKEY)
3220 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3224 mg->mg_virtual = &PL_vtbl_sv;
3227 mg->mg_virtual = &PL_vtbl_amagic;
3230 mg->mg_virtual = &PL_vtbl_amagicelem;
3236 mg->mg_virtual = &PL_vtbl_bm;
3239 mg->mg_virtual = &PL_vtbl_regdata;
3242 mg->mg_virtual = &PL_vtbl_regdatum;
3245 mg->mg_virtual = &PL_vtbl_env;
3248 mg->mg_virtual = &PL_vtbl_fm;
3251 mg->mg_virtual = &PL_vtbl_envelem;
3254 mg->mg_virtual = &PL_vtbl_mglob;
3257 mg->mg_virtual = &PL_vtbl_isa;
3260 mg->mg_virtual = &PL_vtbl_isaelem;
3263 mg->mg_virtual = &PL_vtbl_nkeys;
3270 mg->mg_virtual = &PL_vtbl_dbline;
3274 mg->mg_virtual = &PL_vtbl_mutex;
3276 #endif /* USE_THREADS */
3277 #ifdef USE_LOCALE_COLLATE
3279 mg->mg_virtual = &PL_vtbl_collxfrm;
3281 #endif /* USE_LOCALE_COLLATE */
3283 mg->mg_virtual = &PL_vtbl_pack;
3287 mg->mg_virtual = &PL_vtbl_packelem;
3290 mg->mg_virtual = &PL_vtbl_regexp;
3293 mg->mg_virtual = &PL_vtbl_sig;
3296 mg->mg_virtual = &PL_vtbl_sigelem;
3299 mg->mg_virtual = &PL_vtbl_taint;
3303 mg->mg_virtual = &PL_vtbl_uvar;
3306 mg->mg_virtual = &PL_vtbl_vec;
3309 mg->mg_virtual = &PL_vtbl_substr;
3312 mg->mg_virtual = &PL_vtbl_defelem;
3315 mg->mg_virtual = &PL_vtbl_glob;
3318 mg->mg_virtual = &PL_vtbl_arylen;
3321 mg->mg_virtual = &PL_vtbl_pos;
3324 mg->mg_virtual = &PL_vtbl_backref;
3326 case '~': /* Reserved for use by extensions not perl internals. */
3327 /* Useful for attaching extension internal data to perl vars. */
3328 /* Note that multiple extensions may clash if magical scalars */
3329 /* etc holding private data from one are passed to another. */
3333 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3337 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3341 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3345 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3348 for (mg = *mgp; mg; mg = *mgp) {
3349 if (mg->mg_type == type) {
3350 MGVTBL* vtbl = mg->mg_virtual;
3351 *mgp = mg->mg_moremagic;
3352 if (vtbl && vtbl->svt_free)
3353 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3354 if (mg->mg_ptr && mg->mg_type != 'g')
3355 if (mg->mg_len >= 0)
3356 Safefree(mg->mg_ptr);
3357 else if (mg->mg_len == HEf_SVKEY)
3358 SvREFCNT_dec((SV*)mg->mg_ptr);
3359 if (mg->mg_flags & MGf_REFCOUNTED)
3360 SvREFCNT_dec(mg->mg_obj);
3364 mgp = &mg->mg_moremagic;
3368 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3375 Perl_sv_rvweaken(pTHX_ SV *sv)
3378 if (!SvOK(sv)) /* let undefs pass */
3381 Perl_croak(aTHX_ "Can't weaken a nonreference");
3382 else if (SvWEAKREF(sv)) {
3384 if (ckWARN(WARN_MISC))
3385 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3389 sv_add_backref(tsv, sv);
3396 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3400 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3401 av = (AV*)mg->mg_obj;
3404 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3405 SvREFCNT_dec(av); /* for sv_magic */
3411 S_sv_del_backref(pTHX_ SV *sv)
3418 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3419 Perl_croak(aTHX_ "panic: del_backref");
3420 av = (AV *)mg->mg_obj;
3425 svp[i] = &PL_sv_undef; /* XXX */
3432 =for apidoc sv_insert
3434 Inserts a string at the specified offset/length within the SV. Similar to
3435 the Perl substr() function.
3441 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3445 register char *midend;
3446 register char *bigend;
3452 Perl_croak(aTHX_ "Can't modify non-existent substring");
3453 SvPV_force(bigstr, curlen);
3454 if (offset + len > curlen) {
3455 SvGROW(bigstr, offset+len+1);
3456 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3457 SvCUR_set(bigstr, offset+len);
3461 i = littlelen - len;
3462 if (i > 0) { /* string might grow */
3463 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3464 mid = big + offset + len;
3465 midend = bigend = big + SvCUR(bigstr);
3468 while (midend > mid) /* shove everything down */
3469 *--bigend = *--midend;
3470 Move(little,big+offset,littlelen,char);
3476 Move(little,SvPVX(bigstr)+offset,len,char);
3481 big = SvPVX(bigstr);
3484 bigend = big + SvCUR(bigstr);
3486 if (midend > bigend)
3487 Perl_croak(aTHX_ "panic: sv_insert");
3489 if (mid - big > bigend - midend) { /* faster to shorten from end */
3491 Move(little, mid, littlelen,char);
3494 i = bigend - midend;
3496 Move(midend, mid, i,char);
3500 SvCUR_set(bigstr, mid - big);
3503 else if ((i = mid - big)) { /* faster from front */
3504 midend -= littlelen;
3506 sv_chop(bigstr,midend-i);
3511 Move(little, mid, littlelen,char);
3513 else if (littlelen) {
3514 midend -= littlelen;
3515 sv_chop(bigstr,midend);
3516 Move(little,midend,littlelen,char);
3519 sv_chop(bigstr,midend);
3524 /* make sv point to what nstr did */
3527 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3530 U32 refcnt = SvREFCNT(sv);
3531 SV_CHECK_THINKFIRST(sv);
3532 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3533 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3534 if (SvMAGICAL(sv)) {
3538 sv_upgrade(nsv, SVt_PVMG);
3539 SvMAGIC(nsv) = SvMAGIC(sv);
3540 SvFLAGS(nsv) |= SvMAGICAL(sv);
3546 assert(!SvREFCNT(sv));
3547 StructCopy(nsv,sv,SV);
3548 SvREFCNT(sv) = refcnt;
3549 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3554 Perl_sv_clear(pTHX_ register SV *sv)
3558 assert(SvREFCNT(sv) == 0);
3562 if (PL_defstash) { /* Still have a symbol table? */
3567 Zero(&tmpref, 1, SV);
3568 sv_upgrade(&tmpref, SVt_RV);
3570 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3571 SvREFCNT(&tmpref) = 1;
3574 stash = SvSTASH(sv);
3575 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3578 PUSHSTACKi(PERLSI_DESTROY);
3579 SvRV(&tmpref) = SvREFCNT_inc(sv);
3584 call_sv((SV*)GvCV(destructor),
3585 G_DISCARD|G_EVAL|G_KEEPERR);
3591 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3593 del_XRV(SvANY(&tmpref));
3596 if (PL_in_clean_objs)
3597 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3599 /* DESTROY gave object new lease on life */
3605 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3606 SvOBJECT_off(sv); /* Curse the object. */
3607 if (SvTYPE(sv) != SVt_PVIO)
3608 --PL_sv_objcount; /* XXX Might want something more general */
3611 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3614 switch (SvTYPE(sv)) {
3617 IoIFP(sv) != PerlIO_stdin() &&
3618 IoIFP(sv) != PerlIO_stdout() &&
3619 IoIFP(sv) != PerlIO_stderr())
3621 io_close((IO*)sv, FALSE);
3623 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3624 PerlDir_close(IoDIRP(sv));
3625 IoDIRP(sv) = (DIR*)NULL;
3626 Safefree(IoTOP_NAME(sv));
3627 Safefree(IoFMT_NAME(sv));
3628 Safefree(IoBOTTOM_NAME(sv));
3643 SvREFCNT_dec(LvTARG(sv));
3647 Safefree(GvNAME(sv));
3648 /* cannot decrease stash refcount yet, as we might recursively delete
3649 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3650 of stash until current sv is completely gone.
3651 -- JohnPC, 27 Mar 1998 */
3652 stash = GvSTASH(sv);
3658 (void)SvOOK_off(sv);
3666 SvREFCNT_dec(SvRV(sv));
3668 else if (SvPVX(sv) && SvLEN(sv))
3669 Safefree(SvPVX(sv));
3679 switch (SvTYPE(sv)) {
3695 del_XPVIV(SvANY(sv));
3698 del_XPVNV(SvANY(sv));
3701 del_XPVMG(SvANY(sv));
3704 del_XPVLV(SvANY(sv));
3707 del_XPVAV(SvANY(sv));
3710 del_XPVHV(SvANY(sv));
3713 del_XPVCV(SvANY(sv));
3716 del_XPVGV(SvANY(sv));
3717 /* code duplication for increased performance. */
3718 SvFLAGS(sv) &= SVf_BREAK;
3719 SvFLAGS(sv) |= SVTYPEMASK;
3720 /* decrease refcount of the stash that owns this GV, if any */
3722 SvREFCNT_dec(stash);
3723 return; /* not break, SvFLAGS reset already happened */
3725 del_XPVBM(SvANY(sv));
3728 del_XPVFM(SvANY(sv));
3731 del_XPVIO(SvANY(sv));
3734 SvFLAGS(sv) &= SVf_BREAK;
3735 SvFLAGS(sv) |= SVTYPEMASK;
3739 Perl_sv_newref(pTHX_ SV *sv)
3742 ATOMIC_INC(SvREFCNT(sv));
3747 Perl_sv_free(pTHX_ SV *sv)
3750 int refcount_is_zero;
3754 if (SvREFCNT(sv) == 0) {
3755 if (SvFLAGS(sv) & SVf_BREAK)
3757 if (PL_in_clean_all) /* All is fair */
3759 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3760 /* make sure SvREFCNT(sv)==0 happens very seldom */
3761 SvREFCNT(sv) = (~(U32)0)/2;
3764 if (ckWARN_d(WARN_INTERNAL))
3765 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3768 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3769 if (!refcount_is_zero)
3773 if (ckWARN_d(WARN_DEBUGGING))
3774 Perl_warner(aTHX_ WARN_DEBUGGING,
3775 "Attempt to free temp prematurely: SV 0x%"UVxf,
3780 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3781 /* make sure SvREFCNT(sv)==0 happens very seldom */
3782 SvREFCNT(sv) = (~(U32)0)/2;
3793 Returns the length of the string in the SV. See also C<SvCUR>.
3799 Perl_sv_len(pTHX_ register SV *sv)
3808 len = mg_length(sv);
3810 junk = SvPV(sv, len);
3815 Perl_sv_len_utf8(pTHX_ register SV *sv)
3826 len = mg_length(sv);
3829 s = (U8*)SvPV(sv, len);
3840 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3845 I32 uoffset = *offsetp;
3851 start = s = (U8*)SvPV(sv, len);
3853 while (s < send && uoffset--)
3857 *offsetp = s - start;
3861 while (s < send && ulen--)
3871 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3880 s = (U8*)SvPV(sv, len);
3882 Perl_croak(aTHX_ "panic: bad byte offset");
3883 send = s + *offsetp;
3891 if (ckWARN_d(WARN_UTF8))
3892 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3902 Returns a boolean indicating whether the strings in the two SVs are
3909 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3921 pv1 = SvPV(str1, cur1);
3926 if (SvUTF8(str1) != SvUTF8(str2)) {
3928 sv_utf8_upgrade(str2);
3931 sv_utf8_upgrade(str1);
3935 pv2 = SvPV(str2, cur2);
3940 return memEQ(pv1, pv2, cur1);
3946 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3947 string in C<sv1> is less than, equal to, or greater than the string in
3954 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3961 pv1 = SvPV(str1, cur1);
3969 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3970 /* must upgrade other to UTF8 first */
3972 sv_utf8_upgrade(str2);
3975 sv_utf8_upgrade(str1);
3976 /* refresh pointer and length */
3985 pv2 = sv_2pv(str2, &cur2);
3993 return cur2 ? -1 : 0;
3998 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4001 return retval < 0 ? -1 : 1;
4006 return cur1 < cur2 ? -1 : 1;
4010 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4012 #ifdef USE_LOCALE_COLLATE
4018 if (PL_collation_standard)
4022 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4024 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4026 if (!pv1 || !len1) {
4037 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4040 return retval < 0 ? -1 : 1;
4043 * When the result of collation is equality, that doesn't mean
4044 * that there are no differences -- some locales exclude some
4045 * characters from consideration. So to avoid false equalities,
4046 * we use the raw string as a tiebreaker.
4052 #endif /* USE_LOCALE_COLLATE */
4054 return sv_cmp(sv1, sv2);
4057 #ifdef USE_LOCALE_COLLATE
4059 * Any scalar variable may carry an 'o' magic that contains the
4060 * scalar data of the variable transformed to such a format that
4061 * a normal memory comparison can be used to compare the data
4062 * according to the locale settings.
4065 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4069 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4070 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4075 Safefree(mg->mg_ptr);
4077 if ((xf = mem_collxfrm(s, len, &xlen))) {
4078 if (SvREADONLY(sv)) {
4081 return xf + sizeof(PL_collation_ix);
4084 sv_magic(sv, 0, 'o', 0, 0);
4085 mg = mg_find(sv, 'o');
4098 if (mg && mg->mg_ptr) {
4100 return mg->mg_ptr + sizeof(PL_collation_ix);
4108 #endif /* USE_LOCALE_COLLATE */
4111 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4116 register STDCHAR rslast;
4117 register STDCHAR *bp;
4121 SV_CHECK_THINKFIRST(sv);
4122 (void)SvUPGRADE(sv, SVt_PV);
4126 if (RsSNARF(PL_rs)) {
4130 else if (RsRECORD(PL_rs)) {
4131 I32 recsize, bytesread;
4134 /* Grab the size of the record we're getting */
4135 recsize = SvIV(SvRV(PL_rs));
4136 (void)SvPOK_only(sv); /* Validate pointer */
4137 buffer = SvGROW(sv, recsize + 1);
4140 /* VMS wants read instead of fread, because fread doesn't respect */
4141 /* RMS record boundaries. This is not necessarily a good thing to be */
4142 /* doing, but we've got no other real choice */
4143 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4145 bytesread = PerlIO_read(fp, buffer, recsize);
4147 SvCUR_set(sv, bytesread);
4148 buffer[bytesread] = '\0';
4149 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4151 else if (RsPARA(PL_rs)) {
4156 rsptr = SvPV(PL_rs, rslen);
4157 rslast = rslen ? rsptr[rslen - 1] : '\0';
4159 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4160 do { /* to make sure file boundaries work right */
4163 i = PerlIO_getc(fp);
4167 PerlIO_ungetc(fp,i);
4173 /* See if we know enough about I/O mechanism to cheat it ! */
4175 /* This used to be #ifdef test - it is made run-time test for ease
4176 of abstracting out stdio interface. One call should be cheap
4177 enough here - and may even be a macro allowing compile
4181 if (PerlIO_fast_gets(fp)) {
4184 * We're going to steal some values from the stdio struct
4185 * and put EVERYTHING in the innermost loop into registers.
4187 register STDCHAR *ptr;
4191 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4192 /* An ungetc()d char is handled separately from the regular
4193 * buffer, so we getc() it back out and stuff it in the buffer.
4195 i = PerlIO_getc(fp);
4196 if (i == EOF) return 0;
4197 *(--((*fp)->_ptr)) = (unsigned char) i;
4201 /* Here is some breathtakingly efficient cheating */
4203 cnt = PerlIO_get_cnt(fp); /* get count into register */
4204 (void)SvPOK_only(sv); /* validate pointer */
4205 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4206 if (cnt > 80 && SvLEN(sv) > append) {
4207 shortbuffered = cnt - SvLEN(sv) + append + 1;
4208 cnt -= shortbuffered;
4212 /* remember that cnt can be negative */
4213 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4218 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4219 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4220 DEBUG_P(PerlIO_printf(Perl_debug_log,
4221 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4222 DEBUG_P(PerlIO_printf(Perl_debug_log,
4223 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4224 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4225 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4230 while (cnt > 0) { /* this | eat */
4232 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4233 goto thats_all_folks; /* screams | sed :-) */
4237 Copy(ptr, bp, cnt, char); /* this | eat */
4238 bp += cnt; /* screams | dust */
4239 ptr += cnt; /* louder | sed :-) */
4244 if (shortbuffered) { /* oh well, must extend */
4245 cnt = shortbuffered;
4247 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4249 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4250 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4254 DEBUG_P(PerlIO_printf(Perl_debug_log,
4255 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4256 PTR2UV(ptr),(long)cnt));
4257 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4258 DEBUG_P(PerlIO_printf(Perl_debug_log,
4259 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4260 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4261 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4262 /* This used to call 'filbuf' in stdio form, but as that behaves like
4263 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4264 another abstraction. */
4265 i = PerlIO_getc(fp); /* get more characters */
4266 DEBUG_P(PerlIO_printf(Perl_debug_log,
4267 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4268 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4269 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4270 cnt = PerlIO_get_cnt(fp);
4271 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4272 DEBUG_P(PerlIO_printf(Perl_debug_log,
4273 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4275 if (i == EOF) /* all done for ever? */
4276 goto thats_really_all_folks;
4278 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4280 SvGROW(sv, bpx + cnt + 2);
4281 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4283 *bp++ = i; /* store character from PerlIO_getc */
4285 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4286 goto thats_all_folks;
4290 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4291 memNE((char*)bp - rslen, rsptr, rslen))
4292 goto screamer; /* go back to the fray */
4293 thats_really_all_folks:
4295 cnt += shortbuffered;
4296 DEBUG_P(PerlIO_printf(Perl_debug_log,
4297 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4298 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4299 DEBUG_P(PerlIO_printf(Perl_debug_log,
4300 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4301 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4302 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4304 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4305 DEBUG_P(PerlIO_printf(Perl_debug_log,
4306 "Screamer: done, len=%ld, string=|%.*s|\n",
4307 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4312 /*The big, slow, and stupid way */
4315 /* Need to work around EPOC SDK features */
4316 /* On WINS: MS VC5 generates calls to _chkstk, */
4317 /* if a `large' stack frame is allocated */
4318 /* gcc on MARM does not generate calls like these */
4324 register STDCHAR *bpe = buf + sizeof(buf);
4326 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4327 ; /* keep reading */
4331 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4332 /* Accomodate broken VAXC compiler, which applies U8 cast to
4333 * both args of ?: operator, causing EOF to change into 255
4335 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4339 sv_catpvn(sv, (char *) buf, cnt);
4341 sv_setpvn(sv, (char *) buf, cnt);
4343 if (i != EOF && /* joy */
4345 SvCUR(sv) < rslen ||
4346 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4350 * If we're reading from a TTY and we get a short read,
4351 * indicating that the user hit his EOF character, we need
4352 * to notice it now, because if we try to read from the TTY
4353 * again, the EOF condition will disappear.
4355 * The comparison of cnt to sizeof(buf) is an optimization
4356 * that prevents unnecessary calls to feof().
4360 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4365 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4366 while (i != EOF) { /* to make sure file boundaries work right */
4367 i = PerlIO_getc(fp);
4369 PerlIO_ungetc(fp,i);
4375 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4382 Auto-increment of the value in the SV.
4388 Perl_sv_inc(pTHX_ register SV *sv)
4397 if (SvTHINKFIRST(sv)) {
4398 if (SvREADONLY(sv)) {
4400 if (PL_curcop != &PL_compiling)
4401 Perl_croak(aTHX_ PL_no_modify);
4405 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4407 i = PTR2IV(SvRV(sv));
4412 flags = SvFLAGS(sv);
4413 if (flags & SVp_NOK) {
4414 (void)SvNOK_only(sv);
4418 if (flags & SVp_IOK) {
4420 if (SvUVX(sv) == UV_MAX)
4421 sv_setnv(sv, (NV)UV_MAX + 1.0);
4423 (void)SvIOK_only_UV(sv);
4426 if (SvIVX(sv) == IV_MAX)
4427 sv_setnv(sv, (NV)IV_MAX + 1.0);
4429 (void)SvIOK_only(sv);
4435 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4436 if ((flags & SVTYPEMASK) < SVt_PVNV)
4437 sv_upgrade(sv, SVt_NV);
4439 (void)SvNOK_only(sv);
4443 while (isALPHA(*d)) d++;
4444 while (isDIGIT(*d)) d++;
4446 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4450 while (d >= SvPVX(sv)) {
4458 /* MKS: The original code here died if letters weren't consecutive.
4459 * at least it didn't have to worry about non-C locales. The
4460 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4461 * arranged in order (although not consecutively) and that only
4462 * [A-Za-z] are accepted by isALPHA in the C locale.
4464 if (*d != 'z' && *d != 'Z') {
4465 do { ++*d; } while (!isALPHA(*d));
4468 *(d--) -= 'z' - 'a';
4473 *(d--) -= 'z' - 'a' + 1;
4477 /* oh,oh, the number grew */
4478 SvGROW(sv, SvCUR(sv) + 2);
4480 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4491 Auto-decrement of the value in the SV.
4497 Perl_sv_dec(pTHX_ register SV *sv)
4505 if (SvTHINKFIRST(sv)) {
4506 if (SvREADONLY(sv)) {
4508 if (PL_curcop != &PL_compiling)
4509 Perl_croak(aTHX_ PL_no_modify);
4513 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4515 i = PTR2IV(SvRV(sv));
4520 flags = SvFLAGS(sv);
4521 if (flags & SVp_NOK) {
4523 (void)SvNOK_only(sv);
4526 if (flags & SVp_IOK) {
4528 if (SvUVX(sv) == 0) {
4529 (void)SvIOK_only(sv);
4533 (void)SvIOK_only_UV(sv);
4537 if (SvIVX(sv) == IV_MIN)
4538 sv_setnv(sv, (NV)IV_MIN - 1.0);
4540 (void)SvIOK_only(sv);
4546 if (!(flags & SVp_POK)) {
4547 if ((flags & SVTYPEMASK) < SVt_PVNV)
4548 sv_upgrade(sv, SVt_NV);
4550 (void)SvNOK_only(sv);
4553 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4557 =for apidoc sv_mortalcopy
4559 Creates a new SV which is a copy of the original SV. The new SV is marked
4565 /* Make a string that will exist for the duration of the expression
4566 * evaluation. Actually, it may have to last longer than that, but
4567 * hopefully we won't free it until it has been assigned to a
4568 * permanent location. */
4571 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4577 sv_setsv(sv,oldstr);
4579 PL_tmps_stack[++PL_tmps_ix] = sv;
4585 =for apidoc sv_newmortal
4587 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4593 Perl_sv_newmortal(pTHX)
4599 SvFLAGS(sv) = SVs_TEMP;
4601 PL_tmps_stack[++PL_tmps_ix] = sv;
4606 =for apidoc sv_2mortal
4608 Marks an SV as mortal. The SV will be destroyed when the current context
4614 /* same thing without the copying */
4617 Perl_sv_2mortal(pTHX_ register SV *sv)
4622 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4625 PL_tmps_stack[++PL_tmps_ix] = sv;
4633 Creates a new SV and copies a string into it. The reference count for the
4634 SV is set to 1. If C<len> is zero, Perl will compute the length using
4635 strlen(). For efficiency, consider using C<newSVpvn> instead.
4641 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4648 sv_setpvn(sv,s,len);
4653 =for apidoc newSVpvn
4655 Creates a new SV and copies a string into it. The reference count for the
4656 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4657 string. You are responsible for ensuring that the source string is at least
4664 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4669 sv_setpvn(sv,s,len);
4673 #if defined(PERL_IMPLICIT_CONTEXT)
4675 Perl_newSVpvf_nocontext(const char* pat, ...)
4680 va_start(args, pat);
4681 sv = vnewSVpvf(pat, &args);
4688 =for apidoc newSVpvf
4690 Creates a new SV an initialize it with the string formatted like
4697 Perl_newSVpvf(pTHX_ const char* pat, ...)
4701 va_start(args, pat);
4702 sv = vnewSVpvf(pat, &args);
4708 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4712 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4719 Creates a new SV and copies a floating point value into it.
4720 The reference count for the SV is set to 1.
4726 Perl_newSVnv(pTHX_ NV n)
4738 Creates a new SV and copies an integer into it. The reference count for the
4745 Perl_newSViv(pTHX_ IV i)
4757 Creates a new SV and copies an unsigned integer into it.
4758 The reference count for the SV is set to 1.
4764 Perl_newSVuv(pTHX_ UV u)
4774 =for apidoc newRV_noinc
4776 Creates an RV wrapper for an SV. The reference count for the original
4777 SV is B<not> incremented.
4783 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4789 sv_upgrade(sv, SVt_RV);
4796 /* newRV_inc is #defined to newRV in sv.h */
4798 Perl_newRV(pTHX_ SV *tmpRef)
4800 return newRV_noinc(SvREFCNT_inc(tmpRef));
4806 Creates a new SV which is an exact duplicate of the original SV.
4811 /* make an exact duplicate of old */
4814 Perl_newSVsv(pTHX_ register SV *old)
4821 if (SvTYPE(old) == SVTYPEMASK) {
4822 if (ckWARN_d(WARN_INTERNAL))
4823 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4838 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4846 char todo[PERL_UCHAR_MAX+1];
4851 if (!*s) { /* reset ?? searches */
4852 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4853 pm->op_pmdynflags &= ~PMdf_USED;
4858 /* reset variables */
4860 if (!HvARRAY(stash))
4863 Zero(todo, 256, char);
4865 i = (unsigned char)*s;
4869 max = (unsigned char)*s++;
4870 for ( ; i <= max; i++) {
4873 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4874 for (entry = HvARRAY(stash)[i];
4876 entry = HeNEXT(entry))
4878 if (!todo[(U8)*HeKEY(entry)])
4880 gv = (GV*)HeVAL(entry);
4882 if (SvTHINKFIRST(sv)) {
4883 if (!SvREADONLY(sv) && SvROK(sv))
4888 if (SvTYPE(sv) >= SVt_PV) {
4890 if (SvPVX(sv) != Nullch)
4897 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4899 #ifndef VMS /* VMS has no environ array */
4901 environ[0] = Nullch;
4910 Perl_sv_2io(pTHX_ SV *sv)
4916 switch (SvTYPE(sv)) {
4924 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4928 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4930 return sv_2io(SvRV(sv));
4931 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4937 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4944 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4951 return *gvp = Nullgv, Nullcv;
4952 switch (SvTYPE(sv)) {
4972 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4973 tryAMAGICunDEREF(to_cv);
4976 if (SvTYPE(sv) == SVt_PVCV) {
4985 Perl_croak(aTHX_ "Not a subroutine reference");
4990 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4996 if (lref && !GvCVu(gv)) {
4999 tmpsv = NEWSV(704,0);
5000 gv_efullname3(tmpsv, gv, Nullch);
5001 /* XXX this is probably not what they think they're getting.
5002 * It has the same effect as "sub name;", i.e. just a forward
5004 newSUB(start_subparse(FALSE, 0),
5005 newSVOP(OP_CONST, 0, tmpsv),
5010 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5017 Perl_sv_true(pTHX_ register SV *sv)
5024 if ((tXpv = (XPV*)SvANY(sv)) &&
5025 (tXpv->xpv_cur > 1 ||
5026 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5033 return SvIVX(sv) != 0;
5036 return SvNVX(sv) != 0.0;
5038 return sv_2bool(sv);
5044 Perl_sv_iv(pTHX_ register SV *sv)
5048 return (IV)SvUVX(sv);
5055 Perl_sv_uv(pTHX_ register SV *sv)
5060 return (UV)SvIVX(sv);
5066 Perl_sv_nv(pTHX_ register SV *sv)
5074 Perl_sv_pv(pTHX_ SV *sv)
5081 return sv_2pv(sv, &n_a);
5085 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5091 return sv_2pv(sv, lp);
5095 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5099 if (SvTHINKFIRST(sv) && !SvROK(sv))
5100 sv_force_normal(sv);
5106 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5108 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5109 PL_op_name[PL_op->op_type]);
5113 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5118 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5119 SvGROW(sv, len + 1);
5120 Move(s,SvPVX(sv),len,char);
5125 SvPOK_on(sv); /* validate pointer */
5127 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5128 PTR2UV(sv),SvPVX(sv)));
5135 Perl_sv_pvbyte(pTHX_ SV *sv)
5141 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5143 return sv_pvn(sv,lp);
5147 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5149 return sv_pvn_force(sv,lp);
5153 Perl_sv_pvutf8(pTHX_ SV *sv)
5155 sv_utf8_upgrade(sv);
5160 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5162 sv_utf8_upgrade(sv);
5163 return sv_pvn(sv,lp);
5167 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5169 sv_utf8_upgrade(sv);
5170 return sv_pvn_force(sv,lp);
5174 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5176 if (ob && SvOBJECT(sv))
5177 return HvNAME(SvSTASH(sv));
5179 switch (SvTYPE(sv)) {
5193 case SVt_PVLV: return "LVALUE";
5194 case SVt_PVAV: return "ARRAY";
5195 case SVt_PVHV: return "HASH";
5196 case SVt_PVCV: return "CODE";
5197 case SVt_PVGV: return "GLOB";
5198 case SVt_PVFM: return "FORMAT";
5199 case SVt_PVIO: return "IO";
5200 default: return "UNKNOWN";
5206 =for apidoc sv_isobject
5208 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5209 object. If the SV is not an RV, or if the object is not blessed, then this
5216 Perl_sv_isobject(pTHX_ SV *sv)
5233 Returns a boolean indicating whether the SV is blessed into the specified
5234 class. This does not check for subtypes; use C<sv_derived_from> to verify
5235 an inheritance relationship.
5241 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5253 return strEQ(HvNAME(SvSTASH(sv)), name);
5259 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5260 it will be upgraded to one. If C<classname> is non-null then the new SV will
5261 be blessed in the specified package. The new SV is returned and its
5262 reference count is 1.
5268 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5275 SV_CHECK_THINKFIRST(rv);
5278 if (SvTYPE(rv) < SVt_RV)
5279 sv_upgrade(rv, SVt_RV);
5286 HV* stash = gv_stashpv(classname, TRUE);
5287 (void)sv_bless(rv, stash);
5293 =for apidoc sv_setref_pv
5295 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5296 argument will be upgraded to an RV. That RV will be modified to point to
5297 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5298 into the SV. The C<classname> argument indicates the package for the
5299 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5300 will be returned and will have a reference count of 1.
5302 Do not use with other Perl types such as HV, AV, SV, CV, because those
5303 objects will become corrupted by the pointer copy process.
5305 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5311 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5314 sv_setsv(rv, &PL_sv_undef);
5318 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5323 =for apidoc sv_setref_iv
5325 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5326 argument will be upgraded to an RV. That RV will be modified to point to
5327 the new SV. The C<classname> argument indicates the package for the
5328 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5329 will be returned and will have a reference count of 1.
5335 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5337 sv_setiv(newSVrv(rv,classname), iv);
5342 =for apidoc sv_setref_nv
5344 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5345 argument will be upgraded to an RV. That RV will be modified to point to
5346 the new SV. The C<classname> argument indicates the package for the
5347 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5348 will be returned and will have a reference count of 1.
5354 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5356 sv_setnv(newSVrv(rv,classname), nv);
5361 =for apidoc sv_setref_pvn
5363 Copies a string into a new SV, optionally blessing the SV. The length of the
5364 string must be specified with C<n>. The C<rv> argument will be upgraded to
5365 an RV. That RV will be modified to point to the new SV. The C<classname>
5366 argument indicates the package for the blessing. Set C<classname> to
5367 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5368 a reference count of 1.
5370 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5376 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5378 sv_setpvn(newSVrv(rv,classname), pv, n);
5383 =for apidoc sv_bless
5385 Blesses an SV into a specified package. The SV must be an RV. The package
5386 must be designated by its stash (see C<gv_stashpv()>). The reference count
5387 of the SV is unaffected.
5393 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5398 Perl_croak(aTHX_ "Can't bless non-reference value");
5400 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5401 if (SvREADONLY(tmpRef))
5402 Perl_croak(aTHX_ PL_no_modify);
5403 if (SvOBJECT(tmpRef)) {
5404 if (SvTYPE(tmpRef) != SVt_PVIO)
5406 SvREFCNT_dec(SvSTASH(tmpRef));
5409 SvOBJECT_on(tmpRef);
5410 if (SvTYPE(tmpRef) != SVt_PVIO)
5412 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5413 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5424 S_sv_unglob(pTHX_ SV *sv)
5428 assert(SvTYPE(sv) == SVt_PVGV);
5433 SvREFCNT_dec(GvSTASH(sv));
5434 GvSTASH(sv) = Nullhv;
5436 sv_unmagic(sv, '*');
5437 Safefree(GvNAME(sv));
5440 /* need to keep SvANY(sv) in the right arena */
5441 xpvmg = new_XPVMG();
5442 StructCopy(SvANY(sv), xpvmg, XPVMG);
5443 del_XPVGV(SvANY(sv));
5446 SvFLAGS(sv) &= ~SVTYPEMASK;
5447 SvFLAGS(sv) |= SVt_PVMG;
5451 =for apidoc sv_unref
5453 Unsets the RV status of the SV, and decrements the reference count of
5454 whatever was being referenced by the RV. This can almost be thought of
5455 as a reversal of C<newSVrv>. See C<SvROK_off>.
5461 Perl_sv_unref(pTHX_ SV *sv)
5465 if (SvWEAKREF(sv)) {
5473 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5476 sv_2mortal(rv); /* Schedule for freeing later */
5480 Perl_sv_taint(pTHX_ SV *sv)
5482 sv_magic((sv), Nullsv, 't', Nullch, 0);
5486 Perl_sv_untaint(pTHX_ SV *sv)
5488 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5489 MAGIC *mg = mg_find(sv, 't');
5496 Perl_sv_tainted(pTHX_ SV *sv)
5498 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5499 MAGIC *mg = mg_find(sv, 't');
5500 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5507 =for apidoc sv_setpviv
5509 Copies an integer into the given SV, also updating its string value.
5510 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5516 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5518 char buf[TYPE_CHARS(UV)];
5520 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5522 sv_setpvn(sv, ptr, ebuf - ptr);
5527 =for apidoc sv_setpviv_mg
5529 Like C<sv_setpviv>, but also handles 'set' magic.
5535 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5537 char buf[TYPE_CHARS(UV)];
5539 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5541 sv_setpvn(sv, ptr, ebuf - ptr);
5545 #if defined(PERL_IMPLICIT_CONTEXT)
5547 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5551 va_start(args, pat);
5552 sv_vsetpvf(sv, pat, &args);
5558 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5562 va_start(args, pat);
5563 sv_vsetpvf_mg(sv, pat, &args);
5569 =for apidoc sv_setpvf
5571 Processes its arguments like C<sprintf> and sets an SV to the formatted
5572 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5578 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5581 va_start(args, pat);
5582 sv_vsetpvf(sv, pat, &args);
5587 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5589 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5593 =for apidoc sv_setpvf_mg
5595 Like C<sv_setpvf>, but also handles 'set' magic.
5601 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5604 va_start(args, pat);
5605 sv_vsetpvf_mg(sv, pat, &args);
5610 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5612 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5616 #if defined(PERL_IMPLICIT_CONTEXT)
5618 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5622 va_start(args, pat);
5623 sv_vcatpvf(sv, pat, &args);
5628 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5632 va_start(args, pat);
5633 sv_vcatpvf_mg(sv, pat, &args);
5639 =for apidoc sv_catpvf
5641 Processes its arguments like C<sprintf> and appends the formatted output
5642 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5643 typically be called after calling this function to handle 'set' magic.
5649 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5652 va_start(args, pat);
5653 sv_vcatpvf(sv, pat, &args);
5658 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5660 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5664 =for apidoc sv_catpvf_mg
5666 Like C<sv_catpvf>, but also handles 'set' magic.
5672 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5675 va_start(args, pat);
5676 sv_vcatpvf_mg(sv, pat, &args);
5681 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5683 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5688 =for apidoc sv_vsetpvfn
5690 Works like C<vcatpvfn> but copies the text into the SV instead of
5697 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5699 sv_setpvn(sv, "", 0);
5700 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5704 =for apidoc sv_vcatpvfn
5706 Processes its arguments like C<vsprintf> and appends the formatted output
5707 to an SV. Uses an array of SVs if the C style variable argument list is
5708 missing (NULL). When running with taint checks enabled, indicates via
5709 C<maybe_tainted> if results are untrustworthy (often due to the use of
5716 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5724 static char nullstr[] = "(null)";
5727 /* no matter what, this is a string now */
5728 (void)SvPV_force(sv, origlen);
5730 /* special-case "", "%s", and "%_" */
5733 if (patlen == 2 && pat[0] == '%') {
5737 char *s = va_arg(*args, char*);
5738 sv_catpv(sv, s ? s : nullstr);
5740 else if (svix < svmax) {
5741 sv_catsv(sv, *svargs);
5742 if (DO_UTF8(*svargs))
5748 argsv = va_arg(*args, SV*);
5749 sv_catsv(sv, argsv);
5754 /* See comment on '_' below */
5759 patend = (char*)pat + patlen;
5760 for (p = (char*)pat; p < patend; p = q) {
5763 bool vectorize = FALSE;
5770 bool has_precis = FALSE;
5772 bool is_utf = FALSE;
5775 U8 utf8buf[UTF8_MAXLEN];
5776 STRLEN esignlen = 0;
5778 char *eptr = Nullch;
5780 /* Times 4: a decimal digit takes more than 3 binary digits.
5781 * NV_DIG: mantissa takes than many decimal digits.
5782 * Plus 32: Playing safe. */
5783 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5784 /* large enough for "%#.#f" --chip */
5785 /* what about long double NVs? --jhi */
5788 U8 *vecstr = Null(U8*);
5800 STRLEN dotstrlen = 1;
5802 for (q = p; q < patend && *q != '%'; ++q) ;
5804 sv_catpvn(sv, p, q - p);
5833 case '*': /* printf("%*vX",":",$ipv6addr) */
5838 vecsv = va_arg(*args, SV*);
5839 else if (svix < svmax)
5840 vecsv = svargs[svix++];
5843 dotstr = SvPVx(vecsv,dotstrlen);
5852 vecsv = va_arg(*args, SV*);
5853 else if (svix < svmax)
5854 vecsv = svargs[svix++];
5860 vecstr = (U8*)SvPVx(vecsv,veclen);
5861 utf = DO_UTF8(vecsv);
5873 case '1': case '2': case '3':
5874 case '4': case '5': case '6':
5875 case '7': case '8': case '9':
5878 width = width * 10 + (*q++ - '0');
5883 i = va_arg(*args, int);
5885 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5887 width = (i < 0) ? -i : i;
5898 i = va_arg(*args, int);
5900 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5901 precis = (i < 0) ? 0 : i;
5907 precis = precis * 10 + (*q++ - '0');
5924 if (*(q + 1) == 'l') { /* lld */
5938 #ifdef USE_64_BIT_INT
5956 uv = va_arg(*args, int);
5958 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5959 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5960 eptr = (char*)utf8buf;
5961 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5973 eptr = va_arg(*args, char*);
5975 #ifdef MACOS_TRADITIONAL
5976 /* On MacOS, %#s format is used for Pascal strings */
5981 elen = strlen(eptr);
5984 elen = sizeof nullstr - 1;
5987 else if (svix < svmax) {
5988 argsv = svargs[svix++];
5989 eptr = SvPVx(argsv, elen);
5990 if (DO_UTF8(argsv)) {
5991 if (has_precis && precis < elen) {
5993 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5996 if (width) { /* fudge width (can't fudge elen) */
5997 width += elen - sv_len_utf8(argsv);
6006 * The "%_" hack might have to be changed someday,
6007 * if ISO or ANSI decide to use '_' for something.
6008 * So we keep it hidden from users' code.
6012 argsv = va_arg(*args,SV*);
6013 eptr = SvPVx(argsv, elen);
6019 if (has_precis && elen > precis)
6027 uv = PTR2UV(va_arg(*args, void*));
6029 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6049 iv = (IV)utf8_to_uv(vecstr, &ulen);
6059 case 'h': iv = (short)va_arg(*args, int); break;
6060 default: iv = va_arg(*args, int); break;
6061 case 'l': iv = va_arg(*args, long); break;
6062 case 'V': iv = va_arg(*args, IV); break;
6064 case 'q': iv = va_arg(*args, Quad_t); break;
6069 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6071 case 'h': iv = (short)iv; break;
6072 default: iv = (int)iv; break;
6073 case 'l': iv = (long)iv; break;
6076 case 'q': iv = (Quad_t)iv; break;
6083 esignbuf[esignlen++] = plus;
6087 esignbuf[esignlen++] = '-';
6131 uv = utf8_to_uv(vecstr, &ulen);
6141 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6142 default: uv = va_arg(*args, unsigned); break;
6143 case 'l': uv = va_arg(*args, unsigned long); break;
6144 case 'V': uv = va_arg(*args, UV); break;
6146 case 'q': uv = va_arg(*args, Quad_t); break;
6151 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6153 case 'h': uv = (unsigned short)uv; break;
6154 default: uv = (unsigned)uv; break;
6155 case 'l': uv = (unsigned long)uv; break;
6158 case 'q': uv = (Quad_t)uv; break;
6164 eptr = ebuf + sizeof ebuf;
6170 p = (char*)((c == 'X')
6171 ? "0123456789ABCDEF" : "0123456789abcdef");
6177 esignbuf[esignlen++] = '0';
6178 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6184 *--eptr = '0' + dig;
6186 if (alt && *eptr != '0')
6192 *--eptr = '0' + dig;
6195 esignbuf[esignlen++] = '0';
6196 esignbuf[esignlen++] = 'b';
6199 default: /* it had better be ten or less */
6200 #if defined(PERL_Y2KWARN)
6201 if (ckWARN(WARN_Y2K)) {
6203 char *s = SvPV(sv,n);
6204 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6205 && (n == 2 || !isDIGIT(s[n-3])))
6207 Perl_warner(aTHX_ WARN_Y2K,
6208 "Possible Y2K bug: %%%c %s",
6209 c, "format string following '19'");
6215 *--eptr = '0' + dig;
6216 } while (uv /= base);
6219 elen = (ebuf + sizeof ebuf) - eptr;
6222 zeros = precis - elen;
6223 else if (precis == 0 && elen == 1 && *eptr == '0')
6228 /* FLOATING POINT */
6231 c = 'f'; /* maybe %F isn't supported here */
6237 /* This is evil, but floating point is even more evil */
6241 nv = va_arg(*args, NV);
6243 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6246 if (c != 'e' && c != 'E') {
6248 (void)Perl_frexp(nv, &i);
6249 if (i == PERL_INT_MIN)
6250 Perl_die(aTHX_ "panic: frexp");
6252 need = BIT_DIGITS(i);
6254 need += has_precis ? precis : 6; /* known default */
6258 need += 20; /* fudge factor */
6259 if (PL_efloatsize < need) {
6260 Safefree(PL_efloatbuf);
6261 PL_efloatsize = need + 20; /* more fudge */
6262 New(906, PL_efloatbuf, PL_efloatsize, char);
6263 PL_efloatbuf[0] = '\0';
6266 eptr = ebuf + sizeof ebuf;
6269 #ifdef USE_LONG_DOUBLE
6271 static char const my_prifldbl[] = PERL_PRIfldbl;
6272 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6273 while (p >= my_prifldbl) { *--eptr = *p--; }
6278 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6283 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6296 RESTORE_NUMERIC_STANDARD();
6297 (void)sprintf(PL_efloatbuf, eptr, nv);
6298 RESTORE_NUMERIC_LOCAL();
6301 eptr = PL_efloatbuf;
6302 elen = strlen(PL_efloatbuf);
6309 i = SvCUR(sv) - origlen;
6312 case 'h': *(va_arg(*args, short*)) = i; break;
6313 default: *(va_arg(*args, int*)) = i; break;
6314 case 'l': *(va_arg(*args, long*)) = i; break;
6315 case 'V': *(va_arg(*args, IV*)) = i; break;
6317 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6321 else if (svix < svmax)
6322 sv_setuv(svargs[svix++], (UV)i);
6323 continue; /* not "break" */
6330 if (!args && ckWARN(WARN_PRINTF) &&
6331 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6332 SV *msg = sv_newmortal();
6333 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6334 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6337 Perl_sv_catpvf(aTHX_ msg,
6338 "\"%%%c\"", c & 0xFF);
6340 Perl_sv_catpvf(aTHX_ msg,
6341 "\"%%\\%03"UVof"\"",
6344 sv_catpv(msg, "end of string");
6345 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6348 /* output mangled stuff ... */
6354 /* ... right here, because formatting flags should not apply */
6355 SvGROW(sv, SvCUR(sv) + elen + 1);
6357 memcpy(p, eptr, elen);
6360 SvCUR(sv) = p - SvPVX(sv);
6361 continue; /* not "break" */
6364 have = esignlen + zeros + elen;
6365 need = (have > width ? have : width);
6368 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6370 if (esignlen && fill == '0') {
6371 for (i = 0; i < esignlen; i++)
6375 memset(p, fill, gap);
6378 if (esignlen && fill != '0') {
6379 for (i = 0; i < esignlen; i++)
6383 for (i = zeros; i; i--)
6387 memcpy(p, eptr, elen);
6391 memset(p, ' ', gap);
6396 memcpy(p, dotstr, dotstrlen);
6400 vectorize = FALSE; /* done iterating over vecstr */
6405 SvCUR(sv) = p - SvPVX(sv);
6413 #if defined(USE_ITHREADS)
6415 #if defined(USE_THREADS)
6416 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6419 #ifndef GpREFCNT_inc
6420 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6424 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6425 #define av_dup(s) (AV*)sv_dup((SV*)s)
6426 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6427 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6428 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6429 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6430 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6431 #define io_dup(s) (IO*)sv_dup((SV*)s)
6432 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6433 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6434 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6435 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6436 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6439 Perl_re_dup(pTHX_ REGEXP *r)
6441 /* XXX fix when pmop->op_pmregexp becomes shared */
6442 return ReREFCNT_inc(r);
6446 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6450 return (PerlIO*)NULL;
6452 /* look for it in the table first */
6453 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6457 /* create anew and remember what it is */
6458 ret = PerlIO_fdupopen(fp);
6459 ptr_table_store(PL_ptr_table, fp, ret);
6464 Perl_dirp_dup(pTHX_ DIR *dp)
6473 Perl_gp_dup(pTHX_ GP *gp)
6478 /* look for it in the table first */
6479 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6483 /* create anew and remember what it is */
6484 Newz(0, ret, 1, GP);
6485 ptr_table_store(PL_ptr_table, gp, ret);
6488 ret->gp_refcnt = 0; /* must be before any other dups! */
6489 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6490 ret->gp_io = io_dup_inc(gp->gp_io);
6491 ret->gp_form = cv_dup_inc(gp->gp_form);
6492 ret->gp_av = av_dup_inc(gp->gp_av);
6493 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6494 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6495 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6496 ret->gp_cvgen = gp->gp_cvgen;
6497 ret->gp_flags = gp->gp_flags;
6498 ret->gp_line = gp->gp_line;
6499 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6504 Perl_mg_dup(pTHX_ MAGIC *mg)
6506 MAGIC *mgret = (MAGIC*)NULL;
6509 return (MAGIC*)NULL;
6510 /* look for it in the table first */
6511 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6515 for (; mg; mg = mg->mg_moremagic) {
6517 Newz(0, nmg, 1, MAGIC);
6521 mgprev->mg_moremagic = nmg;
6522 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6523 nmg->mg_private = mg->mg_private;
6524 nmg->mg_type = mg->mg_type;
6525 nmg->mg_flags = mg->mg_flags;
6526 if (mg->mg_type == 'r') {
6527 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6530 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6531 ? sv_dup_inc(mg->mg_obj)
6532 : sv_dup(mg->mg_obj);
6534 nmg->mg_len = mg->mg_len;
6535 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6536 if (mg->mg_ptr && mg->mg_type != 'g') {
6537 if (mg->mg_len >= 0) {
6538 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6539 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6540 AMT *amtp = (AMT*)mg->mg_ptr;
6541 AMT *namtp = (AMT*)nmg->mg_ptr;
6543 for (i = 1; i < NofAMmeth; i++) {
6544 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6548 else if (mg->mg_len == HEf_SVKEY)
6549 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6557 Perl_ptr_table_new(pTHX)
6560 Newz(0, tbl, 1, PTR_TBL_t);
6563 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6568 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6570 PTR_TBL_ENT_t *tblent;
6571 UV hash = PTR2UV(sv);
6573 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6574 for (; tblent; tblent = tblent->next) {
6575 if (tblent->oldval == sv)
6576 return tblent->newval;
6582 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6584 PTR_TBL_ENT_t *tblent, **otblent;
6585 /* XXX this may be pessimal on platforms where pointers aren't good
6586 * hash values e.g. if they grow faster in the most significant
6588 UV hash = PTR2UV(oldv);
6592 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6593 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6594 if (tblent->oldval == oldv) {
6595 tblent->newval = newv;
6600 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6601 tblent->oldval = oldv;
6602 tblent->newval = newv;
6603 tblent->next = *otblent;
6606 if (i && tbl->tbl_items > tbl->tbl_max)
6607 ptr_table_split(tbl);
6611 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6613 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6614 UV oldsize = tbl->tbl_max + 1;
6615 UV newsize = oldsize * 2;
6618 Renew(ary, newsize, PTR_TBL_ENT_t*);
6619 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6620 tbl->tbl_max = --newsize;
6622 for (i=0; i < oldsize; i++, ary++) {
6623 PTR_TBL_ENT_t **curentp, **entp, *ent;
6626 curentp = ary + oldsize;
6627 for (entp = ary, ent = *ary; ent; ent = *entp) {
6628 if ((newsize & PTR2UV(ent->oldval)) != i) {
6630 ent->next = *curentp;
6645 Perl_sv_dup(pTHX_ SV *sstr)
6649 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6651 /* look for it in the table first */
6652 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6656 /* create anew and remember what it is */
6658 ptr_table_store(PL_ptr_table, sstr, dstr);
6661 SvFLAGS(dstr) = SvFLAGS(sstr);
6662 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6663 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6666 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6667 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6668 PL_watch_pvx, SvPVX(sstr));
6671 switch (SvTYPE(sstr)) {
6676 SvANY(dstr) = new_XIV();
6677 SvIVX(dstr) = SvIVX(sstr);
6680 SvANY(dstr) = new_XNV();
6681 SvNVX(dstr) = SvNVX(sstr);
6684 SvANY(dstr) = new_XRV();
6685 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6688 SvANY(dstr) = new_XPV();
6689 SvCUR(dstr) = SvCUR(sstr);
6690 SvLEN(dstr) = SvLEN(sstr);
6692 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6693 else if (SvPVX(sstr) && SvLEN(sstr))
6694 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6696 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6699 SvANY(dstr) = new_XPVIV();
6700 SvCUR(dstr) = SvCUR(sstr);
6701 SvLEN(dstr) = SvLEN(sstr);
6702 SvIVX(dstr) = SvIVX(sstr);
6704 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6705 else if (SvPVX(sstr) && SvLEN(sstr))
6706 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6708 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6711 SvANY(dstr) = new_XPVNV();
6712 SvCUR(dstr) = SvCUR(sstr);
6713 SvLEN(dstr) = SvLEN(sstr);
6714 SvIVX(dstr) = SvIVX(sstr);
6715 SvNVX(dstr) = SvNVX(sstr);
6717 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6718 else if (SvPVX(sstr) && SvLEN(sstr))
6719 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6721 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6724 SvANY(dstr) = new_XPVMG();
6725 SvCUR(dstr) = SvCUR(sstr);
6726 SvLEN(dstr) = SvLEN(sstr);
6727 SvIVX(dstr) = SvIVX(sstr);
6728 SvNVX(dstr) = SvNVX(sstr);
6729 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6730 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6732 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6733 else if (SvPVX(sstr) && SvLEN(sstr))
6734 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6736 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6739 SvANY(dstr) = new_XPVBM();
6740 SvCUR(dstr) = SvCUR(sstr);
6741 SvLEN(dstr) = SvLEN(sstr);
6742 SvIVX(dstr) = SvIVX(sstr);
6743 SvNVX(dstr) = SvNVX(sstr);
6744 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6745 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6747 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6748 else if (SvPVX(sstr) && SvLEN(sstr))
6749 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6751 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6752 BmRARE(dstr) = BmRARE(sstr);
6753 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6754 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6757 SvANY(dstr) = new_XPVLV();
6758 SvCUR(dstr) = SvCUR(sstr);
6759 SvLEN(dstr) = SvLEN(sstr);
6760 SvIVX(dstr) = SvIVX(sstr);
6761 SvNVX(dstr) = SvNVX(sstr);
6762 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6763 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6765 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6766 else if (SvPVX(sstr) && SvLEN(sstr))
6767 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6769 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6770 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6771 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6772 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6773 LvTYPE(dstr) = LvTYPE(sstr);
6776 SvANY(dstr) = new_XPVGV();
6777 SvCUR(dstr) = SvCUR(sstr);
6778 SvLEN(dstr) = SvLEN(sstr);
6779 SvIVX(dstr) = SvIVX(sstr);
6780 SvNVX(dstr) = SvNVX(sstr);
6781 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6782 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6784 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6785 else if (SvPVX(sstr) && SvLEN(sstr))
6786 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6788 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6789 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6790 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6791 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6792 GvFLAGS(dstr) = GvFLAGS(sstr);
6793 GvGP(dstr) = gp_dup(GvGP(sstr));
6794 (void)GpREFCNT_inc(GvGP(dstr));
6797 SvANY(dstr) = new_XPVIO();
6798 SvCUR(dstr) = SvCUR(sstr);
6799 SvLEN(dstr) = SvLEN(sstr);
6800 SvIVX(dstr) = SvIVX(sstr);
6801 SvNVX(dstr) = SvNVX(sstr);
6802 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6803 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6805 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6806 else if (SvPVX(sstr) && SvLEN(sstr))
6807 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6809 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6810 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6811 if (IoOFP(sstr) == IoIFP(sstr))
6812 IoOFP(dstr) = IoIFP(dstr);
6814 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6815 /* PL_rsfp_filters entries have fake IoDIRP() */
6816 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6817 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6819 IoDIRP(dstr) = IoDIRP(sstr);
6820 IoLINES(dstr) = IoLINES(sstr);
6821 IoPAGE(dstr) = IoPAGE(sstr);
6822 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6823 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6824 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6825 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6826 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6827 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6828 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6829 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6830 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6831 IoTYPE(dstr) = IoTYPE(sstr);
6832 IoFLAGS(dstr) = IoFLAGS(sstr);
6835 SvANY(dstr) = new_XPVAV();
6836 SvCUR(dstr) = SvCUR(sstr);
6837 SvLEN(dstr) = SvLEN(sstr);
6838 SvIVX(dstr) = SvIVX(sstr);
6839 SvNVX(dstr) = SvNVX(sstr);
6840 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6841 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6842 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6843 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6844 if (AvARRAY((AV*)sstr)) {
6845 SV **dst_ary, **src_ary;
6846 SSize_t items = AvFILLp((AV*)sstr) + 1;
6848 src_ary = AvARRAY((AV*)sstr);
6849 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6850 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6851 SvPVX(dstr) = (char*)dst_ary;
6852 AvALLOC((AV*)dstr) = dst_ary;
6853 if (AvREAL((AV*)sstr)) {
6855 *dst_ary++ = sv_dup_inc(*src_ary++);
6859 *dst_ary++ = sv_dup(*src_ary++);
6861 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6862 while (items-- > 0) {
6863 *dst_ary++ = &PL_sv_undef;
6867 SvPVX(dstr) = Nullch;
6868 AvALLOC((AV*)dstr) = (SV**)NULL;
6872 SvANY(dstr) = new_XPVHV();
6873 SvCUR(dstr) = SvCUR(sstr);
6874 SvLEN(dstr) = SvLEN(sstr);
6875 SvIVX(dstr) = SvIVX(sstr);
6876 SvNVX(dstr) = SvNVX(sstr);
6877 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6878 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6879 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6880 if (HvARRAY((HV*)sstr)) {
6882 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6883 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6884 Newz(0, dxhv->xhv_array,
6885 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6886 while (i <= sxhv->xhv_max) {
6887 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6888 !!HvSHAREKEYS(sstr));
6891 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6894 SvPVX(dstr) = Nullch;
6895 HvEITER((HV*)dstr) = (HE*)NULL;
6897 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6898 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6901 SvANY(dstr) = new_XPVFM();
6902 FmLINES(dstr) = FmLINES(sstr);
6906 SvANY(dstr) = new_XPVCV();
6908 SvCUR(dstr) = SvCUR(sstr);
6909 SvLEN(dstr) = SvLEN(sstr);
6910 SvIVX(dstr) = SvIVX(sstr);
6911 SvNVX(dstr) = SvNVX(sstr);
6912 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6913 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6914 if (SvPVX(sstr) && SvLEN(sstr))
6915 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6917 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6918 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6919 CvSTART(dstr) = CvSTART(sstr);
6920 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6921 CvXSUB(dstr) = CvXSUB(sstr);
6922 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6923 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6924 CvDEPTH(dstr) = CvDEPTH(sstr);
6925 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6926 /* XXX padlists are real, but pretend to be not */
6927 AvREAL_on(CvPADLIST(sstr));
6928 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6929 AvREAL_off(CvPADLIST(sstr));
6930 AvREAL_off(CvPADLIST(dstr));
6933 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6934 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6935 CvFLAGS(dstr) = CvFLAGS(sstr);
6938 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6942 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6949 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6954 return (PERL_CONTEXT*)NULL;
6956 /* look for it in the table first */
6957 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6961 /* create anew and remember what it is */
6962 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6963 ptr_table_store(PL_ptr_table, cxs, ncxs);
6966 PERL_CONTEXT *cx = &cxs[ix];
6967 PERL_CONTEXT *ncx = &ncxs[ix];
6968 ncx->cx_type = cx->cx_type;
6969 if (CxTYPE(cx) == CXt_SUBST) {
6970 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6973 ncx->blk_oldsp = cx->blk_oldsp;
6974 ncx->blk_oldcop = cx->blk_oldcop;
6975 ncx->blk_oldretsp = cx->blk_oldretsp;
6976 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6977 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6978 ncx->blk_oldpm = cx->blk_oldpm;
6979 ncx->blk_gimme = cx->blk_gimme;
6980 switch (CxTYPE(cx)) {
6982 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6983 ? cv_dup_inc(cx->blk_sub.cv)
6984 : cv_dup(cx->blk_sub.cv));
6985 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6986 ? av_dup_inc(cx->blk_sub.argarray)
6988 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6989 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6990 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6991 ncx->blk_sub.lval = cx->blk_sub.lval;
6994 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6995 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6996 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6997 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6998 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7001 ncx->blk_loop.label = cx->blk_loop.label;
7002 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7003 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7004 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7005 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7006 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7007 ? cx->blk_loop.iterdata
7008 : gv_dup((GV*)cx->blk_loop.iterdata));
7009 ncx->blk_loop.oldcurpad
7010 = (SV**)ptr_table_fetch(PL_ptr_table,
7011 cx->blk_loop.oldcurpad);
7012 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7013 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7014 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7015 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7016 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7019 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7020 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7021 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7022 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7035 Perl_si_dup(pTHX_ PERL_SI *si)
7040 return (PERL_SI*)NULL;
7042 /* look for it in the table first */
7043 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7047 /* create anew and remember what it is */
7048 Newz(56, nsi, 1, PERL_SI);
7049 ptr_table_store(PL_ptr_table, si, nsi);
7051 nsi->si_stack = av_dup_inc(si->si_stack);
7052 nsi->si_cxix = si->si_cxix;
7053 nsi->si_cxmax = si->si_cxmax;
7054 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7055 nsi->si_type = si->si_type;
7056 nsi->si_prev = si_dup(si->si_prev);
7057 nsi->si_next = si_dup(si->si_next);
7058 nsi->si_markoff = si->si_markoff;
7063 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7064 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7065 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7066 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7067 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7068 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7069 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7070 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7071 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7072 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7073 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7074 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7077 #define pv_dup_inc(p) SAVEPV(p)
7078 #define pv_dup(p) SAVEPV(p)
7079 #define svp_dup_inc(p,pp) any_dup(p,pp)
7082 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7089 /* look for it in the table first */
7090 ret = ptr_table_fetch(PL_ptr_table, v);
7094 /* see if it is part of the interpreter structure */
7095 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7096 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7104 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7106 ANY *ss = proto_perl->Tsavestack;
7107 I32 ix = proto_perl->Tsavestack_ix;
7108 I32 max = proto_perl->Tsavestack_max;
7121 void (*dptr) (void*);
7122 void (*dxptr) (pTHXo_ void*);
7125 Newz(54, nss, max, ANY);
7131 case SAVEt_ITEM: /* normal string */
7132 sv = (SV*)POPPTR(ss,ix);
7133 TOPPTR(nss,ix) = sv_dup_inc(sv);
7134 sv = (SV*)POPPTR(ss,ix);
7135 TOPPTR(nss,ix) = sv_dup_inc(sv);
7137 case SAVEt_SV: /* scalar reference */
7138 sv = (SV*)POPPTR(ss,ix);
7139 TOPPTR(nss,ix) = sv_dup_inc(sv);
7140 gv = (GV*)POPPTR(ss,ix);
7141 TOPPTR(nss,ix) = gv_dup_inc(gv);
7143 case SAVEt_GENERIC_SVREF: /* generic sv */
7144 case SAVEt_SVREF: /* scalar reference */
7145 sv = (SV*)POPPTR(ss,ix);
7146 TOPPTR(nss,ix) = sv_dup_inc(sv);
7147 ptr = POPPTR(ss,ix);
7148 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7150 case SAVEt_AV: /* array reference */
7151 av = (AV*)POPPTR(ss,ix);
7152 TOPPTR(nss,ix) = av_dup_inc(av);
7153 gv = (GV*)POPPTR(ss,ix);
7154 TOPPTR(nss,ix) = gv_dup(gv);
7156 case SAVEt_HV: /* hash reference */
7157 hv = (HV*)POPPTR(ss,ix);
7158 TOPPTR(nss,ix) = hv_dup_inc(hv);
7159 gv = (GV*)POPPTR(ss,ix);
7160 TOPPTR(nss,ix) = gv_dup(gv);
7162 case SAVEt_INT: /* int reference */
7163 ptr = POPPTR(ss,ix);
7164 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7165 intval = (int)POPINT(ss,ix);
7166 TOPINT(nss,ix) = intval;
7168 case SAVEt_LONG: /* long reference */
7169 ptr = POPPTR(ss,ix);
7170 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7171 longval = (long)POPLONG(ss,ix);
7172 TOPLONG(nss,ix) = longval;
7174 case SAVEt_I32: /* I32 reference */
7175 case SAVEt_I16: /* I16 reference */
7176 case SAVEt_I8: /* I8 reference */
7177 ptr = POPPTR(ss,ix);
7178 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7182 case SAVEt_IV: /* IV reference */
7183 ptr = POPPTR(ss,ix);
7184 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7188 case SAVEt_SPTR: /* SV* reference */
7189 ptr = POPPTR(ss,ix);
7190 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7191 sv = (SV*)POPPTR(ss,ix);
7192 TOPPTR(nss,ix) = sv_dup(sv);
7194 case SAVEt_VPTR: /* random* reference */
7195 ptr = POPPTR(ss,ix);
7196 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7197 ptr = POPPTR(ss,ix);
7198 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7200 case SAVEt_PPTR: /* char* reference */
7201 ptr = POPPTR(ss,ix);
7202 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7203 c = (char*)POPPTR(ss,ix);
7204 TOPPTR(nss,ix) = pv_dup(c);
7206 case SAVEt_HPTR: /* HV* reference */
7207 ptr = POPPTR(ss,ix);
7208 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7209 hv = (HV*)POPPTR(ss,ix);
7210 TOPPTR(nss,ix) = hv_dup(hv);
7212 case SAVEt_APTR: /* AV* reference */
7213 ptr = POPPTR(ss,ix);
7214 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7215 av = (AV*)POPPTR(ss,ix);
7216 TOPPTR(nss,ix) = av_dup(av);
7219 gv = (GV*)POPPTR(ss,ix);
7220 TOPPTR(nss,ix) = gv_dup(gv);
7222 case SAVEt_GP: /* scalar reference */
7223 gp = (GP*)POPPTR(ss,ix);
7224 TOPPTR(nss,ix) = gp = gp_dup(gp);
7225 (void)GpREFCNT_inc(gp);
7226 gv = (GV*)POPPTR(ss,ix);
7227 TOPPTR(nss,ix) = gv_dup_inc(c);
7228 c = (char*)POPPTR(ss,ix);
7229 TOPPTR(nss,ix) = pv_dup(c);
7236 sv = (SV*)POPPTR(ss,ix);
7237 TOPPTR(nss,ix) = sv_dup_inc(sv);
7240 ptr = POPPTR(ss,ix);
7241 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7242 /* these are assumed to be refcounted properly */
7243 switch (((OP*)ptr)->op_type) {
7250 TOPPTR(nss,ix) = ptr;
7255 TOPPTR(nss,ix) = Nullop;
7260 TOPPTR(nss,ix) = Nullop;
7263 c = (char*)POPPTR(ss,ix);
7264 TOPPTR(nss,ix) = pv_dup_inc(c);
7267 longval = POPLONG(ss,ix);
7268 TOPLONG(nss,ix) = longval;
7271 hv = (HV*)POPPTR(ss,ix);
7272 TOPPTR(nss,ix) = hv_dup_inc(hv);
7273 c = (char*)POPPTR(ss,ix);
7274 TOPPTR(nss,ix) = pv_dup_inc(c);
7278 case SAVEt_DESTRUCTOR:
7279 ptr = POPPTR(ss,ix);
7280 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7281 dptr = POPDPTR(ss,ix);
7282 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7284 case SAVEt_DESTRUCTOR_X:
7285 ptr = POPPTR(ss,ix);
7286 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7287 dxptr = POPDXPTR(ss,ix);
7288 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7290 case SAVEt_REGCONTEXT:
7296 case SAVEt_STACK_POS: /* Position on Perl stack */
7300 case SAVEt_AELEM: /* array element */
7301 sv = (SV*)POPPTR(ss,ix);
7302 TOPPTR(nss,ix) = sv_dup_inc(sv);
7305 av = (AV*)POPPTR(ss,ix);
7306 TOPPTR(nss,ix) = av_dup_inc(av);
7308 case SAVEt_HELEM: /* hash element */
7309 sv = (SV*)POPPTR(ss,ix);
7310 TOPPTR(nss,ix) = sv_dup_inc(sv);
7311 sv = (SV*)POPPTR(ss,ix);
7312 TOPPTR(nss,ix) = sv_dup_inc(sv);
7313 hv = (HV*)POPPTR(ss,ix);
7314 TOPPTR(nss,ix) = hv_dup_inc(hv);
7317 ptr = POPPTR(ss,ix);
7318 TOPPTR(nss,ix) = ptr;
7325 av = (AV*)POPPTR(ss,ix);
7326 TOPPTR(nss,ix) = av_dup(av);
7329 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7341 perl_clone(PerlInterpreter *proto_perl, UV flags)
7344 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7347 #ifdef PERL_IMPLICIT_SYS
7348 return perl_clone_using(proto_perl, flags,
7350 proto_perl->IMemShared,
7351 proto_perl->IMemParse,
7361 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7362 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7363 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7364 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7365 struct IPerlDir* ipD, struct IPerlSock* ipS,
7366 struct IPerlProc* ipP)
7368 /* XXX many of the string copies here can be optimized if they're
7369 * constants; they need to be allocated as common memory and just
7370 * their pointers copied. */
7374 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7376 PERL_SET_THX(pPerl);
7377 # else /* !PERL_OBJECT */
7378 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7379 PERL_SET_THX(my_perl);
7382 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7387 # else /* !DEBUGGING */
7388 Zero(my_perl, 1, PerlInterpreter);
7389 # endif /* DEBUGGING */
7393 PL_MemShared = ipMS;
7401 # endif /* PERL_OBJECT */
7402 #else /* !PERL_IMPLICIT_SYS */
7404 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7405 PERL_SET_THX(my_perl);
7408 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7413 # else /* !DEBUGGING */
7414 Zero(my_perl, 1, PerlInterpreter);
7415 # endif /* DEBUGGING */
7416 #endif /* PERL_IMPLICIT_SYS */
7419 PL_xiv_arenaroot = NULL;
7424 PL_xpviv_root = NULL;
7425 PL_xpvnv_root = NULL;
7426 PL_xpvcv_root = NULL;
7427 PL_xpvav_root = NULL;
7428 PL_xpvhv_root = NULL;
7429 PL_xpvmg_root = NULL;
7430 PL_xpvlv_root = NULL;
7431 PL_xpvbm_root = NULL;
7433 PL_nice_chunk = NULL;
7434 PL_nice_chunk_size = 0;
7437 PL_sv_root = Nullsv;
7438 PL_sv_arenaroot = Nullsv;
7440 PL_debug = proto_perl->Idebug;
7442 /* create SV map for pointer relocation */
7443 PL_ptr_table = ptr_table_new();
7445 /* initialize these special pointers as early as possible */
7446 SvANY(&PL_sv_undef) = NULL;
7447 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7448 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7449 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7452 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7454 SvANY(&PL_sv_no) = new_XPVNV();
7456 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7457 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7458 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7459 SvCUR(&PL_sv_no) = 0;
7460 SvLEN(&PL_sv_no) = 1;
7461 SvNVX(&PL_sv_no) = 0;
7462 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7465 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7467 SvANY(&PL_sv_yes) = new_XPVNV();
7469 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7470 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7471 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7472 SvCUR(&PL_sv_yes) = 1;
7473 SvLEN(&PL_sv_yes) = 2;
7474 SvNVX(&PL_sv_yes) = 1;
7475 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7477 /* create shared string table */
7478 PL_strtab = newHV();
7479 HvSHAREKEYS_off(PL_strtab);
7480 hv_ksplit(PL_strtab, 512);
7481 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7483 PL_compiling = proto_perl->Icompiling;
7484 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7485 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7486 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7487 if (!specialWARN(PL_compiling.cop_warnings))
7488 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7489 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7491 /* pseudo environmental stuff */
7492 PL_origargc = proto_perl->Iorigargc;
7494 New(0, PL_origargv, i+1, char*);
7495 PL_origargv[i] = '\0';
7497 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7499 PL_envgv = gv_dup(proto_perl->Ienvgv);
7500 PL_incgv = gv_dup(proto_perl->Iincgv);
7501 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7502 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7503 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7504 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7507 PL_minus_c = proto_perl->Iminus_c;
7508 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7509 PL_localpatches = proto_perl->Ilocalpatches;
7510 PL_splitstr = proto_perl->Isplitstr;
7511 PL_preprocess = proto_perl->Ipreprocess;
7512 PL_minus_n = proto_perl->Iminus_n;
7513 PL_minus_p = proto_perl->Iminus_p;
7514 PL_minus_l = proto_perl->Iminus_l;
7515 PL_minus_a = proto_perl->Iminus_a;
7516 PL_minus_F = proto_perl->Iminus_F;
7517 PL_doswitches = proto_perl->Idoswitches;
7518 PL_dowarn = proto_perl->Idowarn;
7519 PL_doextract = proto_perl->Idoextract;
7520 PL_sawampersand = proto_perl->Isawampersand;
7521 PL_unsafe = proto_perl->Iunsafe;
7522 PL_inplace = SAVEPV(proto_perl->Iinplace);
7523 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7524 PL_perldb = proto_perl->Iperldb;
7525 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7527 /* magical thingies */
7528 /* XXX time(&PL_basetime) when asked for? */
7529 PL_basetime = proto_perl->Ibasetime;
7530 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7532 PL_maxsysfd = proto_perl->Imaxsysfd;
7533 PL_multiline = proto_perl->Imultiline;
7534 PL_statusvalue = proto_perl->Istatusvalue;
7536 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7539 /* shortcuts to various I/O objects */
7540 PL_stdingv = gv_dup(proto_perl->Istdingv);
7541 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7542 PL_defgv = gv_dup(proto_perl->Idefgv);
7543 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7544 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7545 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7547 /* shortcuts to regexp stuff */
7548 PL_replgv = gv_dup(proto_perl->Ireplgv);
7550 /* shortcuts to misc objects */
7551 PL_errgv = gv_dup(proto_perl->Ierrgv);
7553 /* shortcuts to debugging objects */
7554 PL_DBgv = gv_dup(proto_perl->IDBgv);
7555 PL_DBline = gv_dup(proto_perl->IDBline);
7556 PL_DBsub = gv_dup(proto_perl->IDBsub);
7557 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7558 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7559 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7560 PL_lineary = av_dup(proto_perl->Ilineary);
7561 PL_dbargs = av_dup(proto_perl->Idbargs);
7564 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7565 PL_curstash = hv_dup(proto_perl->Tcurstash);
7566 PL_debstash = hv_dup(proto_perl->Idebstash);
7567 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7568 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7570 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7571 PL_endav = av_dup_inc(proto_perl->Iendav);
7572 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7573 PL_initav = av_dup_inc(proto_perl->Iinitav);
7575 PL_sub_generation = proto_perl->Isub_generation;
7577 /* funky return mechanisms */
7578 PL_forkprocess = proto_perl->Iforkprocess;
7580 /* subprocess state */
7581 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7583 /* internal state */
7584 PL_tainting = proto_perl->Itainting;
7585 PL_maxo = proto_perl->Imaxo;
7586 if (proto_perl->Iop_mask)
7587 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7589 PL_op_mask = Nullch;
7591 /* current interpreter roots */
7592 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7593 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7594 PL_main_start = proto_perl->Imain_start;
7595 PL_eval_root = proto_perl->Ieval_root;
7596 PL_eval_start = proto_perl->Ieval_start;
7598 /* runtime control stuff */
7599 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7600 PL_copline = proto_perl->Icopline;
7602 PL_filemode = proto_perl->Ifilemode;
7603 PL_lastfd = proto_perl->Ilastfd;
7604 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7607 PL_gensym = proto_perl->Igensym;
7608 PL_preambled = proto_perl->Ipreambled;
7609 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7610 PL_laststatval = proto_perl->Ilaststatval;
7611 PL_laststype = proto_perl->Ilaststype;
7612 PL_mess_sv = Nullsv;
7614 PL_orslen = proto_perl->Iorslen;
7615 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7616 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7618 /* interpreter atexit processing */
7619 PL_exitlistlen = proto_perl->Iexitlistlen;
7620 if (PL_exitlistlen) {
7621 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7622 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7625 PL_exitlist = (PerlExitListEntry*)NULL;
7626 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7628 PL_profiledata = NULL;
7629 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7630 /* PL_rsfp_filters entries have fake IoDIRP() */
7631 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7633 PL_compcv = cv_dup(proto_perl->Icompcv);
7634 PL_comppad = av_dup(proto_perl->Icomppad);
7635 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7636 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7637 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7638 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7639 proto_perl->Tcurpad);
7641 #ifdef HAVE_INTERP_INTERN
7642 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7645 /* more statics moved here */
7646 PL_generation = proto_perl->Igeneration;
7647 PL_DBcv = cv_dup(proto_perl->IDBcv);
7649 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7650 PL_in_clean_all = proto_perl->Iin_clean_all;
7652 PL_uid = proto_perl->Iuid;
7653 PL_euid = proto_perl->Ieuid;
7654 PL_gid = proto_perl->Igid;
7655 PL_egid = proto_perl->Iegid;
7656 PL_nomemok = proto_perl->Inomemok;
7657 PL_an = proto_perl->Ian;
7658 PL_cop_seqmax = proto_perl->Icop_seqmax;
7659 PL_op_seqmax = proto_perl->Iop_seqmax;
7660 PL_evalseq = proto_perl->Ievalseq;
7661 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7662 PL_origalen = proto_perl->Iorigalen;
7663 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7664 PL_osname = SAVEPV(proto_perl->Iosname);
7665 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7666 PL_sighandlerp = proto_perl->Isighandlerp;
7669 PL_runops = proto_perl->Irunops;
7671 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7674 PL_cshlen = proto_perl->Icshlen;
7675 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7678 PL_lex_state = proto_perl->Ilex_state;
7679 PL_lex_defer = proto_perl->Ilex_defer;
7680 PL_lex_expect = proto_perl->Ilex_expect;
7681 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7682 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7683 PL_lex_starts = proto_perl->Ilex_starts;
7684 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7685 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7686 PL_lex_op = proto_perl->Ilex_op;
7687 PL_lex_inpat = proto_perl->Ilex_inpat;
7688 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7689 PL_lex_brackets = proto_perl->Ilex_brackets;
7690 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7691 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7692 PL_lex_casemods = proto_perl->Ilex_casemods;
7693 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7694 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7696 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7697 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7698 PL_nexttoke = proto_perl->Inexttoke;
7700 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7701 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7702 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7703 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7704 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7705 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7706 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7707 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7708 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7709 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7710 PL_pending_ident = proto_perl->Ipending_ident;
7711 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7713 PL_expect = proto_perl->Iexpect;
7715 PL_multi_start = proto_perl->Imulti_start;
7716 PL_multi_end = proto_perl->Imulti_end;
7717 PL_multi_open = proto_perl->Imulti_open;
7718 PL_multi_close = proto_perl->Imulti_close;
7720 PL_error_count = proto_perl->Ierror_count;
7721 PL_subline = proto_perl->Isubline;
7722 PL_subname = sv_dup_inc(proto_perl->Isubname);
7724 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7725 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7726 PL_padix = proto_perl->Ipadix;
7727 PL_padix_floor = proto_perl->Ipadix_floor;
7728 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7730 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7731 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7732 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7733 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7734 PL_last_lop_op = proto_perl->Ilast_lop_op;
7735 PL_in_my = proto_perl->Iin_my;
7736 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7738 PL_cryptseen = proto_perl->Icryptseen;
7741 PL_hints = proto_perl->Ihints;
7743 PL_amagic_generation = proto_perl->Iamagic_generation;
7745 #ifdef USE_LOCALE_COLLATE
7746 PL_collation_ix = proto_perl->Icollation_ix;
7747 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7748 PL_collation_standard = proto_perl->Icollation_standard;
7749 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7750 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7751 #endif /* USE_LOCALE_COLLATE */
7753 #ifdef USE_LOCALE_NUMERIC
7754 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7755 PL_numeric_standard = proto_perl->Inumeric_standard;
7756 PL_numeric_local = proto_perl->Inumeric_local;
7757 PL_numeric_radix = proto_perl->Inumeric_radix;
7758 #endif /* !USE_LOCALE_NUMERIC */
7760 /* utf8 character classes */
7761 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7762 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7763 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7764 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7765 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7766 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7767 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7768 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7769 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7770 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7771 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7772 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7773 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7774 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7775 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7776 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7777 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7780 PL_last_swash_hv = Nullhv; /* reinits on demand */
7781 PL_last_swash_klen = 0;
7782 PL_last_swash_key[0]= '\0';
7783 PL_last_swash_tmps = (U8*)NULL;
7784 PL_last_swash_slen = 0;
7786 /* perly.c globals */
7787 PL_yydebug = proto_perl->Iyydebug;
7788 PL_yynerrs = proto_perl->Iyynerrs;
7789 PL_yyerrflag = proto_perl->Iyyerrflag;
7790 PL_yychar = proto_perl->Iyychar;
7791 PL_yyval = proto_perl->Iyyval;
7792 PL_yylval = proto_perl->Iyylval;
7794 PL_glob_index = proto_perl->Iglob_index;
7795 PL_srand_called = proto_perl->Isrand_called;
7796 PL_uudmap['M'] = 0; /* reinits on demand */
7797 PL_bitcount = Nullch; /* reinits on demand */
7799 if (proto_perl->Ipsig_ptr) {
7800 int sig_num[] = { SIG_NUM };
7801 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7802 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7803 for (i = 1; PL_sig_name[i]; i++) {
7804 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7805 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7809 PL_psig_ptr = (SV**)NULL;
7810 PL_psig_name = (SV**)NULL;
7813 /* thrdvar.h stuff */
7816 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7817 PL_tmps_ix = proto_perl->Ttmps_ix;
7818 PL_tmps_max = proto_perl->Ttmps_max;
7819 PL_tmps_floor = proto_perl->Ttmps_floor;
7820 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7822 while (i <= PL_tmps_ix) {
7823 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7827 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7828 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7829 Newz(54, PL_markstack, i, I32);
7830 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7831 - proto_perl->Tmarkstack);
7832 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7833 - proto_perl->Tmarkstack);
7834 Copy(proto_perl->Tmarkstack, PL_markstack,
7835 PL_markstack_ptr - PL_markstack + 1, I32);
7837 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7838 * NOTE: unlike the others! */
7839 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7840 PL_scopestack_max = proto_perl->Tscopestack_max;
7841 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7842 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7844 /* next push_return() sets PL_retstack[PL_retstack_ix]
7845 * NOTE: unlike the others! */
7846 PL_retstack_ix = proto_perl->Tretstack_ix;
7847 PL_retstack_max = proto_perl->Tretstack_max;
7848 Newz(54, PL_retstack, PL_retstack_max, OP*);
7849 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7851 /* NOTE: si_dup() looks at PL_markstack */
7852 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7854 /* PL_curstack = PL_curstackinfo->si_stack; */
7855 PL_curstack = av_dup(proto_perl->Tcurstack);
7856 PL_mainstack = av_dup(proto_perl->Tmainstack);
7858 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7859 PL_stack_base = AvARRAY(PL_curstack);
7860 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7861 - proto_perl->Tstack_base);
7862 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7864 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7865 * NOTE: unlike the others! */
7866 PL_savestack_ix = proto_perl->Tsavestack_ix;
7867 PL_savestack_max = proto_perl->Tsavestack_max;
7868 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7869 PL_savestack = ss_dup(proto_perl);
7875 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7876 PL_top_env = &PL_start_env;
7878 PL_op = proto_perl->Top;
7881 PL_Xpv = (XPV*)NULL;
7882 PL_na = proto_perl->Tna;
7884 PL_statbuf = proto_perl->Tstatbuf;
7885 PL_statcache = proto_perl->Tstatcache;
7886 PL_statgv = gv_dup(proto_perl->Tstatgv);
7887 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7889 PL_timesbuf = proto_perl->Ttimesbuf;
7892 PL_tainted = proto_perl->Ttainted;
7893 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7894 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7895 PL_rs = sv_dup_inc(proto_perl->Trs);
7896 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7897 PL_ofslen = proto_perl->Tofslen;
7898 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7899 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7900 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7901 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7902 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7903 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7905 PL_restartop = proto_perl->Trestartop;
7906 PL_in_eval = proto_perl->Tin_eval;
7907 PL_delaymagic = proto_perl->Tdelaymagic;
7908 PL_dirty = proto_perl->Tdirty;
7909 PL_localizing = proto_perl->Tlocalizing;
7911 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7912 PL_protect = proto_perl->Tprotect;
7914 PL_errors = sv_dup_inc(proto_perl->Terrors);
7915 PL_av_fetch_sv = Nullsv;
7916 PL_hv_fetch_sv = Nullsv;
7917 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7918 PL_modcount = proto_perl->Tmodcount;
7919 PL_lastgotoprobe = Nullop;
7920 PL_dumpindent = proto_perl->Tdumpindent;
7922 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7923 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7924 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7925 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7926 PL_sortcxix = proto_perl->Tsortcxix;
7927 PL_efloatbuf = Nullch; /* reinits on demand */
7928 PL_efloatsize = 0; /* reinits on demand */
7932 PL_screamfirst = NULL;
7933 PL_screamnext = NULL;
7934 PL_maxscream = -1; /* reinits on demand */
7935 PL_lastscream = Nullsv;
7937 PL_watchaddr = NULL;
7938 PL_watchok = Nullch;
7940 PL_regdummy = proto_perl->Tregdummy;
7941 PL_regcomp_parse = Nullch;
7942 PL_regxend = Nullch;
7943 PL_regcode = (regnode*)NULL;
7946 PL_regprecomp = Nullch;
7951 PL_seen_zerolen = 0;
7953 PL_regcomp_rx = (regexp*)NULL;
7955 PL_colorset = 0; /* reinits PL_colors[] */
7956 /*PL_colors[6] = {0,0,0,0,0,0};*/
7957 PL_reg_whilem_seen = 0;
7958 PL_reginput = Nullch;
7961 PL_regstartp = (I32*)NULL;
7962 PL_regendp = (I32*)NULL;
7963 PL_reglastparen = (U32*)NULL;
7964 PL_regtill = Nullch;
7966 PL_reg_start_tmp = (char**)NULL;
7967 PL_reg_start_tmpl = 0;
7968 PL_regdata = (struct reg_data*)NULL;
7971 PL_reg_eval_set = 0;
7973 PL_regprogram = (regnode*)NULL;
7975 PL_regcc = (CURCUR*)NULL;
7976 PL_reg_call_cc = (struct re_cc_state*)NULL;
7977 PL_reg_re = (regexp*)NULL;
7978 PL_reg_ganch = Nullch;
7980 PL_reg_magic = (MAGIC*)NULL;
7982 PL_reg_oldcurpm = (PMOP*)NULL;
7983 PL_reg_curpm = (PMOP*)NULL;
7984 PL_reg_oldsaved = Nullch;
7985 PL_reg_oldsavedlen = 0;
7987 PL_reg_leftiter = 0;
7988 PL_reg_poscache = Nullch;
7989 PL_reg_poscache_size= 0;
7991 /* RE engine - function pointers */
7992 PL_regcompp = proto_perl->Tregcompp;
7993 PL_regexecp = proto_perl->Tregexecp;
7994 PL_regint_start = proto_perl->Tregint_start;
7995 PL_regint_string = proto_perl->Tregint_string;
7996 PL_regfree = proto_perl->Tregfree;
7998 PL_reginterp_cnt = 0;
7999 PL_reg_starttry = 0;
8002 return (PerlInterpreter*)pPerl;
8008 #else /* !USE_ITHREADS */
8014 #endif /* USE_ITHREADS */
8017 do_report_used(pTHXo_ SV *sv)
8019 if (SvTYPE(sv) != SVTYPEMASK) {
8020 PerlIO_printf(Perl_debug_log, "****\n");
8026 do_clean_objs(pTHXo_ SV *sv)
8030 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8031 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8037 /* XXX Might want to check arrays, etc. */
8040 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8042 do_clean_named_objs(pTHXo_ SV *sv)
8044 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8045 if ( SvOBJECT(GvSV(sv)) ||
8046 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8047 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8048 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8049 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8051 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8059 do_clean_all(pTHXo_ SV *sv)
8061 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8062 SvFLAGS(sv) |= SVf_BREAK;