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 */
1362 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1364 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1365 until proven guilty, assume that things are not that bad... */
1368 Perl_sv_2iv(pTHX_ register SV *sv)
1372 if (SvGMAGICAL(sv)) {
1377 return I_V(SvNVX(sv));
1379 if (SvPOKp(sv) && SvLEN(sv))
1382 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1384 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1390 if (SvTHINKFIRST(sv)) {
1393 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1394 return SvIV(tmpstr);
1395 return PTR2IV(SvRV(sv));
1397 if (SvREADONLY(sv) && !SvOK(sv)) {
1399 if (ckWARN(WARN_UNINITIALIZED))
1406 return (IV)(SvUVX(sv));
1413 /* We can cache the IV/UV value even if it not good enough
1414 * to reconstruct NV, since the conversion to PV will prefer
1418 if (SvTYPE(sv) == SVt_NV)
1419 sv_upgrade(sv, SVt_PVNV);
1422 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1423 SvIVX(sv) = I_V(SvNVX(sv));
1425 SvUVX(sv) = U_V(SvNVX(sv));
1428 DEBUG_c(PerlIO_printf(Perl_debug_log,
1429 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1433 return (IV)SvUVX(sv);
1436 else if (SvPOKp(sv) && SvLEN(sv)) {
1437 I32 numtype = looks_like_number(sv);
1439 /* We want to avoid a possible problem when we cache an IV which
1440 may be later translated to an NV, and the resulting NV is not
1441 the translation of the initial data.
1443 This means that if we cache such an IV, we need to cache the
1444 NV as well. Moreover, we trade speed for space, and do not
1445 cache the NV if not needed.
1447 if (numtype & IS_NUMBER_NOT_IV) {
1448 /* May be not an integer. Need to cache NV if we cache IV
1449 * - otherwise future conversion to NV will be wrong. */
1452 d = Atof(SvPVX(sv));
1454 if (SvTYPE(sv) < SVt_PVNV)
1455 sv_upgrade(sv, SVt_PVNV);
1459 #if defined(USE_LONG_DOUBLE)
1460 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1461 PTR2UV(sv), SvNVX(sv)));
1463 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1464 PTR2UV(sv), SvNVX(sv)));
1466 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1467 SvIVX(sv) = I_V(SvNVX(sv));
1469 SvUVX(sv) = U_V(SvNVX(sv));
1475 /* The NV may be reconstructed from IV - safe to cache IV,
1476 which may be calculated by atol(). */
1477 if (SvTYPE(sv) == SVt_PV)
1478 sv_upgrade(sv, SVt_PVIV);
1480 SvIVX(sv) = Atol(SvPVX(sv));
1482 else { /* Not a number. Cache 0. */
1485 if (SvTYPE(sv) < SVt_PVIV)
1486 sv_upgrade(sv, SVt_PVIV);
1489 if (ckWARN(WARN_NUMERIC))
1495 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1497 if (SvTYPE(sv) < SVt_IV)
1498 /* Typically the caller expects that sv_any is not NULL now. */
1499 sv_upgrade(sv, SVt_IV);
1502 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1503 PTR2UV(sv),SvIVX(sv)));
1504 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1508 Perl_sv_2uv(pTHX_ register SV *sv)
1512 if (SvGMAGICAL(sv)) {
1517 return U_V(SvNVX(sv));
1518 if (SvPOKp(sv) && SvLEN(sv))
1521 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1523 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1529 if (SvTHINKFIRST(sv)) {
1532 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1533 return SvUV(tmpstr);
1534 return PTR2UV(SvRV(sv));
1536 if (SvREADONLY(sv) && !SvOK(sv)) {
1538 if (ckWARN(WARN_UNINITIALIZED))
1548 return (UV)SvIVX(sv);
1552 /* We can cache the IV/UV value even if it not good enough
1553 * to reconstruct NV, since the conversion to PV will prefer
1556 if (SvTYPE(sv) == SVt_NV)
1557 sv_upgrade(sv, SVt_PVNV);
1559 if (SvNVX(sv) >= -0.5) {
1561 SvUVX(sv) = U_V(SvNVX(sv));
1564 SvIVX(sv) = I_V(SvNVX(sv));
1566 DEBUG_c(PerlIO_printf(Perl_debug_log,
1567 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1570 (IV)(UV)SvIVX(sv)));
1571 return (UV)SvIVX(sv);
1574 else if (SvPOKp(sv) && SvLEN(sv)) {
1575 I32 numtype = looks_like_number(sv);
1577 /* We want to avoid a possible problem when we cache a UV which
1578 may be later translated to an NV, and the resulting NV is not
1579 the translation of the initial data.
1581 This means that if we cache such a UV, we need to cache the
1582 NV as well. Moreover, we trade speed for space, and do not
1583 cache the NV if not needed.
1585 if (numtype & IS_NUMBER_NOT_IV) {
1586 /* May be not an integer. Need to cache NV if we cache IV
1587 * - otherwise future conversion to NV will be wrong. */
1590 d = Atof(SvPVX(sv));
1592 if (SvTYPE(sv) < SVt_PVNV)
1593 sv_upgrade(sv, SVt_PVNV);
1597 #if defined(USE_LONG_DOUBLE)
1598 DEBUG_c(PerlIO_printf(Perl_debug_log,
1599 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1600 PTR2UV(sv), SvNVX(sv)));
1602 DEBUG_c(PerlIO_printf(Perl_debug_log,
1603 "0x%"UVxf" 2nv(%g)\n",
1604 PTR2UV(sv), SvNVX(sv)));
1606 if (SvNVX(sv) < -0.5) {
1607 SvIVX(sv) = I_V(SvNVX(sv));
1610 SvUVX(sv) = U_V(SvNVX(sv));
1614 else if (numtype & IS_NUMBER_NEG) {
1615 /* The NV may be reconstructed from IV - safe to cache IV,
1616 which may be calculated by atol(). */
1617 if (SvTYPE(sv) == SVt_PV)
1618 sv_upgrade(sv, SVt_PVIV);
1620 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1622 else if (numtype) { /* Non-negative */
1623 /* The NV may be reconstructed from UV - safe to cache UV,
1624 which may be calculated by strtoul()/atol. */
1625 if (SvTYPE(sv) == SVt_PV)
1626 sv_upgrade(sv, SVt_PVIV);
1628 (void)SvIsUV_on(sv);
1630 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1631 #else /* no atou(), but we know the number fits into IV... */
1632 /* The only problem may be if it is negative... */
1633 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1636 else { /* Not a number. Cache 0. */
1639 if (SvTYPE(sv) < SVt_PVIV)
1640 sv_upgrade(sv, SVt_PVIV);
1642 (void)SvIsUV_on(sv);
1643 SvUVX(sv) = 0; /* We assume that 0s have the
1644 same bitmap in IV and UV. */
1645 if (ckWARN(WARN_NUMERIC))
1650 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1652 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1655 if (SvTYPE(sv) < SVt_IV)
1656 /* Typically the caller expects that sv_any is not NULL now. */
1657 sv_upgrade(sv, SVt_IV);
1661 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1662 PTR2UV(sv),SvUVX(sv)));
1663 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1667 Perl_sv_2nv(pTHX_ register SV *sv)
1671 if (SvGMAGICAL(sv)) {
1675 if (SvPOKp(sv) && SvLEN(sv)) {
1677 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1679 return Atof(SvPVX(sv));
1683 return (NV)SvUVX(sv);
1685 return (NV)SvIVX(sv);
1688 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1690 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1696 if (SvTHINKFIRST(sv)) {
1699 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1700 return SvNV(tmpstr);
1701 return PTR2NV(SvRV(sv));
1703 if (SvREADONLY(sv) && !SvOK(sv)) {
1705 if (ckWARN(WARN_UNINITIALIZED))
1710 if (SvTYPE(sv) < SVt_NV) {
1711 if (SvTYPE(sv) == SVt_IV)
1712 sv_upgrade(sv, SVt_PVNV);
1714 sv_upgrade(sv, SVt_NV);
1715 #if defined(USE_LONG_DOUBLE)
1717 RESTORE_NUMERIC_STANDARD();
1718 PerlIO_printf(Perl_debug_log,
1719 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1720 PTR2UV(sv), SvNVX(sv));
1721 RESTORE_NUMERIC_LOCAL();
1725 RESTORE_NUMERIC_STANDARD();
1726 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1727 PTR2UV(sv), SvNVX(sv));
1728 RESTORE_NUMERIC_LOCAL();
1732 else if (SvTYPE(sv) < SVt_PVNV)
1733 sv_upgrade(sv, SVt_PVNV);
1735 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1737 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1739 else if (SvPOKp(sv) && SvLEN(sv)) {
1741 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1743 SvNVX(sv) = Atof(SvPVX(sv));
1747 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1749 if (SvTYPE(sv) < SVt_NV)
1750 /* Typically the caller expects that sv_any is not NULL now. */
1751 sv_upgrade(sv, SVt_NV);
1755 #if defined(USE_LONG_DOUBLE)
1757 RESTORE_NUMERIC_STANDARD();
1758 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1759 PTR2UV(sv), SvNVX(sv));
1760 RESTORE_NUMERIC_LOCAL();
1764 RESTORE_NUMERIC_STANDARD();
1765 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1766 PTR2UV(sv), SvNVX(sv));
1767 RESTORE_NUMERIC_LOCAL();
1774 S_asIV(pTHX_ SV *sv)
1776 I32 numtype = looks_like_number(sv);
1779 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1780 return Atol(SvPVX(sv));
1783 if (ckWARN(WARN_NUMERIC))
1786 d = Atof(SvPVX(sv));
1791 S_asUV(pTHX_ SV *sv)
1793 I32 numtype = looks_like_number(sv);
1796 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1797 return Strtoul(SvPVX(sv), Null(char**), 10);
1801 if (ckWARN(WARN_NUMERIC))
1804 return U_V(Atof(SvPVX(sv)));
1808 * Returns a combination of (advisory only - can get false negatives)
1809 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1811 * 0 if does not look like number.
1813 * In fact possible values are 0 and
1814 * IS_NUMBER_TO_INT_BY_ATOL 123
1815 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1816 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1817 * IS_NUMBER_INFINITY
1818 * with a possible addition of IS_NUMBER_NEG.
1822 =for apidoc looks_like_number
1824 Test if an the content of an SV looks like a number (or is a
1831 Perl_looks_like_number(pTHX_ SV *sv)
1834 register char *send;
1835 register char *sbegin;
1836 register char *nbegin;
1845 else if (SvPOKp(sv))
1846 sbegin = SvPV(sv, len);
1849 send = sbegin + len;
1856 numtype = IS_NUMBER_NEG;
1863 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1864 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1868 /* next must be digit or the radix separator or beginning of infinity */
1872 } while (isDIGIT(*s));
1874 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1875 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1877 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1880 #ifdef USE_LOCALE_NUMERIC
1881 || IS_NUMERIC_RADIX(*s)
1885 numtype |= IS_NUMBER_NOT_IV;
1886 while (isDIGIT(*s)) /* optional digits after the radix */
1891 #ifdef USE_LOCALE_NUMERIC
1892 || IS_NUMERIC_RADIX(*s)
1896 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1897 /* no digits before the radix means we need digits after it */
1901 } while (isDIGIT(*s));
1906 else if (*s == 'I' || *s == 'i') {
1907 s++; if (*s != 'N' && *s != 'n') return 0;
1908 s++; if (*s != 'F' && *s != 'f') return 0;
1909 s++; if (*s == 'I' || *s == 'i') {
1910 s++; if (*s != 'N' && *s != 'n') return 0;
1911 s++; if (*s != 'I' && *s != 'i') return 0;
1912 s++; if (*s != 'T' && *s != 't') return 0;
1913 s++; if (*s != 'Y' && *s != 'y') return 0;
1921 numtype = IS_NUMBER_INFINITY;
1923 /* we can have an optional exponent part */
1924 if (*s == 'e' || *s == 'E') {
1925 numtype &= ~IS_NUMBER_NEG;
1926 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1928 if (*s == '+' || *s == '-')
1933 } while (isDIGIT(*s));
1943 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1944 return IS_NUMBER_TO_INT_BY_ATOL;
1949 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1952 return sv_2pv(sv, &n_a);
1955 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1957 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1959 char *ptr = buf + TYPE_CHARS(UV);
1973 *--ptr = '0' + (uv % 10);
1982 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1987 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1988 char *tmpbuf = tbuf;
1994 if (SvGMAGICAL(sv)) {
2002 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2004 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2009 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2014 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2016 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2023 if (SvTHINKFIRST(sv)) {
2026 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2027 return SvPV(tmpstr,*lp);
2034 switch (SvTYPE(sv)) {
2036 if ( ((SvFLAGS(sv) &
2037 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2038 == (SVs_OBJECT|SVs_RMG))
2039 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2040 && (mg = mg_find(sv, 'r'))) {
2042 regexp *re = (regexp *)mg->mg_obj;
2045 char *fptr = "msix";
2050 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2052 while((ch = *fptr++)) {
2054 reflags[left++] = ch;
2057 reflags[right--] = ch;
2062 reflags[left] = '-';
2066 mg->mg_len = re->prelen + 4 + left;
2067 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2068 Copy("(?", mg->mg_ptr, 2, char);
2069 Copy(reflags, mg->mg_ptr+2, left, char);
2070 Copy(":", mg->mg_ptr+left+2, 1, char);
2071 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2072 mg->mg_ptr[mg->mg_len - 1] = ')';
2073 mg->mg_ptr[mg->mg_len] = 0;
2075 PL_reginterp_cnt += re->program[0].next_off;
2087 case SVt_PVBM: s = "SCALAR"; break;
2088 case SVt_PVLV: s = "LVALUE"; break;
2089 case SVt_PVAV: s = "ARRAY"; break;
2090 case SVt_PVHV: s = "HASH"; break;
2091 case SVt_PVCV: s = "CODE"; break;
2092 case SVt_PVGV: s = "GLOB"; break;
2093 case SVt_PVFM: s = "FORMAT"; break;
2094 case SVt_PVIO: s = "IO"; break;
2095 default: s = "UNKNOWN"; break;
2099 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2102 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2108 if (SvREADONLY(sv) && !SvOK(sv)) {
2110 if (ckWARN(WARN_UNINITIALIZED))
2116 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2117 /* XXXX 64-bit? IV may have better precision... */
2118 /* I tried changing this for to be 64-bit-aware and
2119 * the t/op/numconvert.t became very, very, angry.
2121 if (SvTYPE(sv) < SVt_PVNV)
2122 sv_upgrade(sv, SVt_PVNV);
2125 olderrno = errno; /* some Xenix systems wipe out errno here */
2127 if (SvNVX(sv) == 0.0)
2128 (void)strcpy(s,"0");
2132 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2135 #ifdef FIXNEGATIVEZERO
2136 if (*s == '-' && s[1] == '0' && !s[2])
2145 else if (SvIOKp(sv)) {
2146 U32 isIOK = SvIOK(sv);
2147 U32 isUIOK = SvIsUV(sv);
2148 char buf[TYPE_CHARS(UV)];
2151 if (SvTYPE(sv) < SVt_PVIV)
2152 sv_upgrade(sv, SVt_PVIV);
2154 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2156 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2157 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2158 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2159 SvCUR_set(sv, ebuf - ptr);
2172 if (ckWARN(WARN_UNINITIALIZED)
2173 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2178 if (SvTYPE(sv) < SVt_PV)
2179 /* Typically the caller expects that sv_any is not NULL now. */
2180 sv_upgrade(sv, SVt_PV);
2183 *lp = s - SvPVX(sv);
2186 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2187 PTR2UV(sv),SvPVX(sv)));
2191 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2192 /* Sneaky stuff here */
2196 tsv = newSVpv(tmpbuf, 0);
2212 len = strlen(tmpbuf);
2214 #ifdef FIXNEGATIVEZERO
2215 if (len == 2 && t[0] == '-' && t[1] == '0') {
2220 (void)SvUPGRADE(sv, SVt_PV);
2222 s = SvGROW(sv, len + 1);
2231 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2234 return sv_2pvbyte(sv, &n_a);
2238 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2240 return sv_2pv(sv,lp);
2244 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2247 return sv_2pvutf8(sv, &n_a);
2251 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2253 sv_utf8_upgrade(sv);
2254 return sv_2pv(sv,lp);
2257 /* This function is only called on magical items */
2259 Perl_sv_2bool(pTHX_ register SV *sv)
2269 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2270 return SvTRUE(tmpsv);
2271 return SvRV(sv) != 0;
2274 register XPV* Xpvtmp;
2275 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2276 (*Xpvtmp->xpv_pv > '0' ||
2277 Xpvtmp->xpv_cur > 1 ||
2278 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2285 return SvIVX(sv) != 0;
2288 return SvNVX(sv) != 0.0;
2296 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2301 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2304 /* This function could be much more efficient if we had a FLAG
2305 * to signal if there are any hibit chars in the string
2308 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2315 SvGROW(sv, SvCUR(sv) + hicount + 1);
2317 src = SvEND(sv) - 1;
2318 SvCUR_set(sv, SvCUR(sv) + hicount);
2319 dst = SvEND(sv) - 1;
2324 uv_to_utf8((U8*)dst, (U8)*src--);
2337 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2339 if (SvPOK(sv) && SvUTF8(sv)) {
2340 char *c = SvPVX(sv);
2342 /* need to figure out if this is possible at all first */
2343 while (c < SvEND(sv)) {
2346 UV uv = utf8_to_uv((U8*)c, &len);
2351 /* XXX might want to make a callback here instead */
2352 Perl_croak(aTHX_ "Big byte");
2365 char *src = first_hi;
2366 char *dst = first_hi;
2367 while (src < SvEND(sv)) {
2370 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2378 SvCUR_set(sv, dst - SvPVX(sv));
2386 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2388 sv_utf8_upgrade(sv);
2393 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2397 bool has_utf = FALSE;
2398 if (!sv_utf8_downgrade(sv, TRUE))
2401 /* it is actually just a matter of turning the utf8 flag on, but
2402 * we want to make sure everything inside is valid utf8 first.
2405 while (c < SvEND(sv)) {
2408 (void)utf8_to_uv((U8*)c, &len);
2428 /* Note: sv_setsv() should not be called with a source string that needs
2429 * to be reused, since it may destroy the source string if it is marked
2434 =for apidoc sv_setsv
2436 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2437 The source SV may be destroyed if it is mortal. Does not handle 'set'
2438 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2445 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2448 register U32 sflags;
2454 SV_CHECK_THINKFIRST(dstr);
2456 sstr = &PL_sv_undef;
2457 stype = SvTYPE(sstr);
2458 dtype = SvTYPE(dstr);
2462 /* There's a lot of redundancy below but we're going for speed here */
2467 if (dtype != SVt_PVGV) {
2468 (void)SvOK_off(dstr);
2476 sv_upgrade(dstr, SVt_IV);
2479 sv_upgrade(dstr, SVt_PVNV);
2483 sv_upgrade(dstr, SVt_PVIV);
2486 (void)SvIOK_only(dstr);
2487 SvIVX(dstr) = SvIVX(sstr);
2500 sv_upgrade(dstr, SVt_NV);
2505 sv_upgrade(dstr, SVt_PVNV);
2508 SvNVX(dstr) = SvNVX(sstr);
2509 (void)SvNOK_only(dstr);
2517 sv_upgrade(dstr, SVt_RV);
2518 else if (dtype == SVt_PVGV &&
2519 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2522 if (GvIMPORTED(dstr) != GVf_IMPORTED
2523 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2525 GvIMPORTED_on(dstr);
2536 sv_upgrade(dstr, SVt_PV);
2539 if (dtype < SVt_PVIV)
2540 sv_upgrade(dstr, SVt_PVIV);
2543 if (dtype < SVt_PVNV)
2544 sv_upgrade(dstr, SVt_PVNV);
2551 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2552 PL_op_name[PL_op->op_type]);
2554 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2558 if (dtype <= SVt_PVGV) {
2560 if (dtype != SVt_PVGV) {
2561 char *name = GvNAME(sstr);
2562 STRLEN len = GvNAMELEN(sstr);
2563 sv_upgrade(dstr, SVt_PVGV);
2564 sv_magic(dstr, dstr, '*', name, len);
2565 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2566 GvNAME(dstr) = savepvn(name, len);
2567 GvNAMELEN(dstr) = len;
2568 SvFAKE_on(dstr); /* can coerce to non-glob */
2570 /* ahem, death to those who redefine active sort subs */
2571 else if (PL_curstackinfo->si_type == PERLSI_SORT
2572 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2573 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2575 (void)SvOK_off(dstr);
2576 GvINTRO_off(dstr); /* one-shot flag */
2578 GvGP(dstr) = gp_ref(GvGP(sstr));
2580 if (GvIMPORTED(dstr) != GVf_IMPORTED
2581 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2583 GvIMPORTED_on(dstr);
2591 if (SvGMAGICAL(sstr)) {
2593 if (SvTYPE(sstr) != stype) {
2594 stype = SvTYPE(sstr);
2595 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2599 if (stype == SVt_PVLV)
2600 (void)SvUPGRADE(dstr, SVt_PVNV);
2602 (void)SvUPGRADE(dstr, stype);
2605 sflags = SvFLAGS(sstr);
2607 if (sflags & SVf_ROK) {
2608 if (dtype >= SVt_PV) {
2609 if (dtype == SVt_PVGV) {
2610 SV *sref = SvREFCNT_inc(SvRV(sstr));
2612 int intro = GvINTRO(dstr);
2617 GvINTRO_off(dstr); /* one-shot flag */
2618 Newz(602,gp, 1, GP);
2619 GvGP(dstr) = gp_ref(gp);
2620 GvSV(dstr) = NEWSV(72,0);
2621 GvLINE(dstr) = CopLINE(PL_curcop);
2622 GvEGV(dstr) = (GV*)dstr;
2625 switch (SvTYPE(sref)) {
2628 SAVESPTR(GvAV(dstr));
2630 dref = (SV*)GvAV(dstr);
2631 GvAV(dstr) = (AV*)sref;
2632 if (!GvIMPORTED_AV(dstr)
2633 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2635 GvIMPORTED_AV_on(dstr);
2640 SAVESPTR(GvHV(dstr));
2642 dref = (SV*)GvHV(dstr);
2643 GvHV(dstr) = (HV*)sref;
2644 if (!GvIMPORTED_HV(dstr)
2645 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2647 GvIMPORTED_HV_on(dstr);
2652 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2653 SvREFCNT_dec(GvCV(dstr));
2654 GvCV(dstr) = Nullcv;
2655 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2656 PL_sub_generation++;
2658 SAVESPTR(GvCV(dstr));
2661 dref = (SV*)GvCV(dstr);
2662 if (GvCV(dstr) != (CV*)sref) {
2663 CV* cv = GvCV(dstr);
2665 if (!GvCVGEN((GV*)dstr) &&
2666 (CvROOT(cv) || CvXSUB(cv)))
2668 SV *const_sv = cv_const_sv(cv);
2669 bool const_changed = TRUE;
2671 const_changed = sv_cmp(const_sv,
2672 op_const_sv(CvSTART((CV*)sref),
2674 /* ahem, death to those who redefine
2675 * active sort subs */
2676 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2677 PL_sortcop == CvSTART(cv))
2679 "Can't redefine active sort subroutine %s",
2680 GvENAME((GV*)dstr));
2681 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2682 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2683 "Constant subroutine %s redefined"
2684 : "Subroutine %s redefined",
2685 GvENAME((GV*)dstr));
2687 cv_ckproto(cv, (GV*)dstr,
2688 SvPOK(sref) ? SvPVX(sref) : Nullch);
2690 GvCV(dstr) = (CV*)sref;
2691 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2692 GvASSUMECV_on(dstr);
2693 PL_sub_generation++;
2695 if (!GvIMPORTED_CV(dstr)
2696 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2698 GvIMPORTED_CV_on(dstr);
2703 SAVESPTR(GvIOp(dstr));
2705 dref = (SV*)GvIOp(dstr);
2706 GvIOp(dstr) = (IO*)sref;
2710 SAVESPTR(GvSV(dstr));
2712 dref = (SV*)GvSV(dstr);
2714 if (!GvIMPORTED_SV(dstr)
2715 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2717 GvIMPORTED_SV_on(dstr);
2729 (void)SvOOK_off(dstr); /* backoff */
2731 Safefree(SvPVX(dstr));
2732 SvLEN(dstr)=SvCUR(dstr)=0;
2735 (void)SvOK_off(dstr);
2736 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2738 if (sflags & SVp_NOK) {
2740 SvNVX(dstr) = SvNVX(sstr);
2742 if (sflags & SVp_IOK) {
2743 (void)SvIOK_on(dstr);
2744 SvIVX(dstr) = SvIVX(sstr);
2745 if (sflags & SVf_IVisUV)
2748 if (SvAMAGIC(sstr)) {
2752 else if (sflags & SVp_POK) {
2755 * Check to see if we can just swipe the string. If so, it's a
2756 * possible small lose on short strings, but a big win on long ones.
2757 * It might even be a win on short strings if SvPVX(dstr)
2758 * has to be allocated and SvPVX(sstr) has to be freed.
2761 if (SvTEMP(sstr) && /* slated for free anyway? */
2762 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2763 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2765 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2767 SvFLAGS(dstr) &= ~SVf_OOK;
2768 Safefree(SvPVX(dstr) - SvIVX(dstr));
2770 else if (SvLEN(dstr))
2771 Safefree(SvPVX(dstr));
2773 (void)SvPOK_only(dstr);
2774 SvPV_set(dstr, SvPVX(sstr));
2775 SvLEN_set(dstr, SvLEN(sstr));
2776 SvCUR_set(dstr, SvCUR(sstr));
2783 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2784 SvPV_set(sstr, Nullch);
2789 else { /* have to copy actual string */
2790 STRLEN len = SvCUR(sstr);
2792 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2793 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2794 SvCUR_set(dstr, len);
2795 *SvEND(dstr) = '\0';
2796 (void)SvPOK_only(dstr);
2801 if (sflags & SVp_NOK) {
2803 SvNVX(dstr) = SvNVX(sstr);
2805 if (sflags & SVp_IOK) {
2806 (void)SvIOK_on(dstr);
2807 SvIVX(dstr) = SvIVX(sstr);
2808 if (sflags & SVf_IVisUV)
2812 else if (sflags & SVp_NOK) {
2813 SvNVX(dstr) = SvNVX(sstr);
2814 (void)SvNOK_only(dstr);
2815 if (sflags & SVf_IOK) {
2816 (void)SvIOK_on(dstr);
2817 SvIVX(dstr) = SvIVX(sstr);
2818 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2819 if (sflags & SVf_IVisUV)
2823 else if (sflags & SVp_IOK) {
2824 (void)SvIOK_only(dstr);
2825 SvIVX(dstr) = SvIVX(sstr);
2826 if (sflags & SVf_IVisUV)
2830 if (dtype == SVt_PVGV) {
2831 if (ckWARN(WARN_MISC))
2832 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2835 (void)SvOK_off(dstr);
2841 =for apidoc sv_setsv_mg
2843 Like C<sv_setsv>, but also handles 'set' magic.
2849 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2851 sv_setsv(dstr,sstr);
2856 =for apidoc sv_setpvn
2858 Copies a string into an SV. The C<len> parameter indicates the number of
2859 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2865 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2867 register char *dptr;
2868 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2869 elicit a warning, but it won't hurt. */
2870 SV_CHECK_THINKFIRST(sv);
2875 (void)SvUPGRADE(sv, SVt_PV);
2877 SvGROW(sv, len + 1);
2879 Move(ptr,dptr,len,char);
2882 (void)SvPOK_only(sv); /* validate pointer */
2887 =for apidoc sv_setpvn_mg
2889 Like C<sv_setpvn>, but also handles 'set' magic.
2895 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2897 sv_setpvn(sv,ptr,len);
2902 =for apidoc sv_setpv
2904 Copies a string into an SV. The string must be null-terminated. Does not
2905 handle 'set' magic. See C<sv_setpv_mg>.
2911 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2913 register STRLEN len;
2915 SV_CHECK_THINKFIRST(sv);
2921 (void)SvUPGRADE(sv, SVt_PV);
2923 SvGROW(sv, len + 1);
2924 Move(ptr,SvPVX(sv),len+1,char);
2926 (void)SvPOK_only(sv); /* validate pointer */
2931 =for apidoc sv_setpv_mg
2933 Like C<sv_setpv>, but also handles 'set' magic.
2939 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2946 =for apidoc sv_usepvn
2948 Tells an SV to use C<ptr> to find its string value. Normally the string is
2949 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2950 The C<ptr> should point to memory that was allocated by C<malloc>. The
2951 string length, C<len>, must be supplied. This function will realloc the
2952 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2953 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2954 See C<sv_usepvn_mg>.
2960 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2962 SV_CHECK_THINKFIRST(sv);
2963 (void)SvUPGRADE(sv, SVt_PV);
2968 (void)SvOOK_off(sv);
2969 if (SvPVX(sv) && SvLEN(sv))
2970 Safefree(SvPVX(sv));
2971 Renew(ptr, len+1, char);
2974 SvLEN_set(sv, len+1);
2976 (void)SvPOK_only(sv); /* validate pointer */
2981 =for apidoc sv_usepvn_mg
2983 Like C<sv_usepvn>, but also handles 'set' magic.
2989 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2991 sv_usepvn(sv,ptr,len);
2996 Perl_sv_force_normal(pTHX_ register SV *sv)
2998 if (SvREADONLY(sv)) {
3000 if (PL_curcop != &PL_compiling)
3001 Perl_croak(aTHX_ PL_no_modify);
3005 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3012 Efficient removal of characters from the beginning of the string buffer.
3013 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3014 the string buffer. The C<ptr> becomes the first character of the adjusted
3021 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3025 register STRLEN delta;
3027 if (!ptr || !SvPOKp(sv))
3029 SV_CHECK_THINKFIRST(sv);
3030 if (SvTYPE(sv) < SVt_PVIV)
3031 sv_upgrade(sv,SVt_PVIV);
3034 if (!SvLEN(sv)) { /* make copy of shared string */
3035 char *pvx = SvPVX(sv);
3036 STRLEN len = SvCUR(sv);
3037 SvGROW(sv, len + 1);
3038 Move(pvx,SvPVX(sv),len,char);
3042 SvFLAGS(sv) |= SVf_OOK;
3044 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3045 delta = ptr - SvPVX(sv);
3053 =for apidoc sv_catpvn
3055 Concatenates the string onto the end of the string which is in the SV. The
3056 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3057 'set' magic. See C<sv_catpvn_mg>.
3063 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3068 junk = SvPV_force(sv, tlen);
3069 SvGROW(sv, tlen + len + 1);
3072 Move(ptr,SvPVX(sv)+tlen,len,char);
3075 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3080 =for apidoc sv_catpvn_mg
3082 Like C<sv_catpvn>, but also handles 'set' magic.
3088 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3090 sv_catpvn(sv,ptr,len);
3095 =for apidoc sv_catsv
3097 Concatenates the string from SV C<ssv> onto the end of the string in SV
3098 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3104 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3110 if ((s = SvPV(sstr, len))) {
3112 sv_utf8_upgrade(dstr);
3113 sv_catpvn(dstr,s,len);
3120 =for apidoc sv_catsv_mg
3122 Like C<sv_catsv>, but also handles 'set' magic.
3128 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3130 sv_catsv(dstr,sstr);
3135 =for apidoc sv_catpv
3137 Concatenates the string onto the end of the string which is in the SV.
3138 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3144 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3146 register STRLEN len;
3152 junk = SvPV_force(sv, tlen);
3154 SvGROW(sv, tlen + len + 1);
3157 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3159 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3164 =for apidoc sv_catpv_mg
3166 Like C<sv_catpv>, but also handles 'set' magic.
3172 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3179 Perl_newSV(pTHX_ STRLEN len)
3185 sv_upgrade(sv, SVt_PV);
3186 SvGROW(sv, len + 1);
3191 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3194 =for apidoc sv_magic
3196 Adds magic to an SV.
3202 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3206 if (SvREADONLY(sv)) {
3208 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3209 Perl_croak(aTHX_ PL_no_modify);
3211 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3212 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3219 (void)SvUPGRADE(sv, SVt_PVMG);
3221 Newz(702,mg, 1, MAGIC);
3222 mg->mg_moremagic = SvMAGIC(sv);
3225 if (!obj || obj == sv || how == '#' || how == 'r')
3229 mg->mg_obj = SvREFCNT_inc(obj);
3230 mg->mg_flags |= MGf_REFCOUNTED;
3233 mg->mg_len = namlen;
3236 mg->mg_ptr = savepvn(name, namlen);
3237 else if (namlen == HEf_SVKEY)
3238 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3242 mg->mg_virtual = &PL_vtbl_sv;
3245 mg->mg_virtual = &PL_vtbl_amagic;
3248 mg->mg_virtual = &PL_vtbl_amagicelem;
3254 mg->mg_virtual = &PL_vtbl_bm;
3257 mg->mg_virtual = &PL_vtbl_regdata;
3260 mg->mg_virtual = &PL_vtbl_regdatum;
3263 mg->mg_virtual = &PL_vtbl_env;
3266 mg->mg_virtual = &PL_vtbl_fm;
3269 mg->mg_virtual = &PL_vtbl_envelem;
3272 mg->mg_virtual = &PL_vtbl_mglob;
3275 mg->mg_virtual = &PL_vtbl_isa;
3278 mg->mg_virtual = &PL_vtbl_isaelem;
3281 mg->mg_virtual = &PL_vtbl_nkeys;
3288 mg->mg_virtual = &PL_vtbl_dbline;
3292 mg->mg_virtual = &PL_vtbl_mutex;
3294 #endif /* USE_THREADS */
3295 #ifdef USE_LOCALE_COLLATE
3297 mg->mg_virtual = &PL_vtbl_collxfrm;
3299 #endif /* USE_LOCALE_COLLATE */
3301 mg->mg_virtual = &PL_vtbl_pack;
3305 mg->mg_virtual = &PL_vtbl_packelem;
3308 mg->mg_virtual = &PL_vtbl_regexp;
3311 mg->mg_virtual = &PL_vtbl_sig;
3314 mg->mg_virtual = &PL_vtbl_sigelem;
3317 mg->mg_virtual = &PL_vtbl_taint;
3321 mg->mg_virtual = &PL_vtbl_uvar;
3324 mg->mg_virtual = &PL_vtbl_vec;
3327 mg->mg_virtual = &PL_vtbl_substr;
3330 mg->mg_virtual = &PL_vtbl_defelem;
3333 mg->mg_virtual = &PL_vtbl_glob;
3336 mg->mg_virtual = &PL_vtbl_arylen;
3339 mg->mg_virtual = &PL_vtbl_pos;
3342 mg->mg_virtual = &PL_vtbl_backref;
3344 case '~': /* Reserved for use by extensions not perl internals. */
3345 /* Useful for attaching extension internal data to perl vars. */
3346 /* Note that multiple extensions may clash if magical scalars */
3347 /* etc holding private data from one are passed to another. */
3351 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3355 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3359 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3363 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3366 for (mg = *mgp; mg; mg = *mgp) {
3367 if (mg->mg_type == type) {
3368 MGVTBL* vtbl = mg->mg_virtual;
3369 *mgp = mg->mg_moremagic;
3370 if (vtbl && vtbl->svt_free)
3371 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3372 if (mg->mg_ptr && mg->mg_type != 'g')
3373 if (mg->mg_len >= 0)
3374 Safefree(mg->mg_ptr);
3375 else if (mg->mg_len == HEf_SVKEY)
3376 SvREFCNT_dec((SV*)mg->mg_ptr);
3377 if (mg->mg_flags & MGf_REFCOUNTED)
3378 SvREFCNT_dec(mg->mg_obj);
3382 mgp = &mg->mg_moremagic;
3386 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3393 Perl_sv_rvweaken(pTHX_ SV *sv)
3396 if (!SvOK(sv)) /* let undefs pass */
3399 Perl_croak(aTHX_ "Can't weaken a nonreference");
3400 else if (SvWEAKREF(sv)) {
3402 if (ckWARN(WARN_MISC))
3403 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3407 sv_add_backref(tsv, sv);
3414 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3418 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3419 av = (AV*)mg->mg_obj;
3422 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3423 SvREFCNT_dec(av); /* for sv_magic */
3429 S_sv_del_backref(pTHX_ SV *sv)
3436 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3437 Perl_croak(aTHX_ "panic: del_backref");
3438 av = (AV *)mg->mg_obj;
3443 svp[i] = &PL_sv_undef; /* XXX */
3450 =for apidoc sv_insert
3452 Inserts a string at the specified offset/length within the SV. Similar to
3453 the Perl substr() function.
3459 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3463 register char *midend;
3464 register char *bigend;
3470 Perl_croak(aTHX_ "Can't modify non-existent substring");
3471 SvPV_force(bigstr, curlen);
3472 if (offset + len > curlen) {
3473 SvGROW(bigstr, offset+len+1);
3474 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3475 SvCUR_set(bigstr, offset+len);
3479 i = littlelen - len;
3480 if (i > 0) { /* string might grow */
3481 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3482 mid = big + offset + len;
3483 midend = bigend = big + SvCUR(bigstr);
3486 while (midend > mid) /* shove everything down */
3487 *--bigend = *--midend;
3488 Move(little,big+offset,littlelen,char);
3494 Move(little,SvPVX(bigstr)+offset,len,char);
3499 big = SvPVX(bigstr);
3502 bigend = big + SvCUR(bigstr);
3504 if (midend > bigend)
3505 Perl_croak(aTHX_ "panic: sv_insert");
3507 if (mid - big > bigend - midend) { /* faster to shorten from end */
3509 Move(little, mid, littlelen,char);
3512 i = bigend - midend;
3514 Move(midend, mid, i,char);
3518 SvCUR_set(bigstr, mid - big);
3521 else if ((i = mid - big)) { /* faster from front */
3522 midend -= littlelen;
3524 sv_chop(bigstr,midend-i);
3529 Move(little, mid, littlelen,char);
3531 else if (littlelen) {
3532 midend -= littlelen;
3533 sv_chop(bigstr,midend);
3534 Move(little,midend,littlelen,char);
3537 sv_chop(bigstr,midend);
3542 /* make sv point to what nstr did */
3545 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3548 U32 refcnt = SvREFCNT(sv);
3549 SV_CHECK_THINKFIRST(sv);
3550 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3551 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3552 if (SvMAGICAL(sv)) {
3556 sv_upgrade(nsv, SVt_PVMG);
3557 SvMAGIC(nsv) = SvMAGIC(sv);
3558 SvFLAGS(nsv) |= SvMAGICAL(sv);
3564 assert(!SvREFCNT(sv));
3565 StructCopy(nsv,sv,SV);
3566 SvREFCNT(sv) = refcnt;
3567 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3572 Perl_sv_clear(pTHX_ register SV *sv)
3576 assert(SvREFCNT(sv) == 0);
3580 if (PL_defstash) { /* Still have a symbol table? */
3585 Zero(&tmpref, 1, SV);
3586 sv_upgrade(&tmpref, SVt_RV);
3588 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3589 SvREFCNT(&tmpref) = 1;
3592 stash = SvSTASH(sv);
3593 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3596 PUSHSTACKi(PERLSI_DESTROY);
3597 SvRV(&tmpref) = SvREFCNT_inc(sv);
3602 call_sv((SV*)GvCV(destructor),
3603 G_DISCARD|G_EVAL|G_KEEPERR);
3609 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3611 del_XRV(SvANY(&tmpref));
3614 if (PL_in_clean_objs)
3615 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3617 /* DESTROY gave object new lease on life */
3623 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3624 SvOBJECT_off(sv); /* Curse the object. */
3625 if (SvTYPE(sv) != SVt_PVIO)
3626 --PL_sv_objcount; /* XXX Might want something more general */
3629 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3632 switch (SvTYPE(sv)) {
3635 IoIFP(sv) != PerlIO_stdin() &&
3636 IoIFP(sv) != PerlIO_stdout() &&
3637 IoIFP(sv) != PerlIO_stderr())
3639 io_close((IO*)sv, FALSE);
3641 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3642 PerlDir_close(IoDIRP(sv));
3643 IoDIRP(sv) = (DIR*)NULL;
3644 Safefree(IoTOP_NAME(sv));
3645 Safefree(IoFMT_NAME(sv));
3646 Safefree(IoBOTTOM_NAME(sv));
3661 SvREFCNT_dec(LvTARG(sv));
3665 Safefree(GvNAME(sv));
3666 /* cannot decrease stash refcount yet, as we might recursively delete
3667 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3668 of stash until current sv is completely gone.
3669 -- JohnPC, 27 Mar 1998 */
3670 stash = GvSTASH(sv);
3676 (void)SvOOK_off(sv);
3684 SvREFCNT_dec(SvRV(sv));
3686 else if (SvPVX(sv) && SvLEN(sv))
3687 Safefree(SvPVX(sv));
3697 switch (SvTYPE(sv)) {
3713 del_XPVIV(SvANY(sv));
3716 del_XPVNV(SvANY(sv));
3719 del_XPVMG(SvANY(sv));
3722 del_XPVLV(SvANY(sv));
3725 del_XPVAV(SvANY(sv));
3728 del_XPVHV(SvANY(sv));
3731 del_XPVCV(SvANY(sv));
3734 del_XPVGV(SvANY(sv));
3735 /* code duplication for increased performance. */
3736 SvFLAGS(sv) &= SVf_BREAK;
3737 SvFLAGS(sv) |= SVTYPEMASK;
3738 /* decrease refcount of the stash that owns this GV, if any */
3740 SvREFCNT_dec(stash);
3741 return; /* not break, SvFLAGS reset already happened */
3743 del_XPVBM(SvANY(sv));
3746 del_XPVFM(SvANY(sv));
3749 del_XPVIO(SvANY(sv));
3752 SvFLAGS(sv) &= SVf_BREAK;
3753 SvFLAGS(sv) |= SVTYPEMASK;
3757 Perl_sv_newref(pTHX_ SV *sv)
3760 ATOMIC_INC(SvREFCNT(sv));
3765 Perl_sv_free(pTHX_ SV *sv)
3768 int refcount_is_zero;
3772 if (SvREFCNT(sv) == 0) {
3773 if (SvFLAGS(sv) & SVf_BREAK)
3775 if (PL_in_clean_all) /* All is fair */
3777 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3778 /* make sure SvREFCNT(sv)==0 happens very seldom */
3779 SvREFCNT(sv) = (~(U32)0)/2;
3782 if (ckWARN_d(WARN_INTERNAL))
3783 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3786 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3787 if (!refcount_is_zero)
3791 if (ckWARN_d(WARN_DEBUGGING))
3792 Perl_warner(aTHX_ WARN_DEBUGGING,
3793 "Attempt to free temp prematurely: SV 0x%"UVxf,
3798 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3799 /* make sure SvREFCNT(sv)==0 happens very seldom */
3800 SvREFCNT(sv) = (~(U32)0)/2;
3811 Returns the length of the string in the SV. See also C<SvCUR>.
3817 Perl_sv_len(pTHX_ register SV *sv)
3826 len = mg_length(sv);
3828 junk = SvPV(sv, len);
3833 Perl_sv_len_utf8(pTHX_ register SV *sv)
3844 len = mg_length(sv);
3847 s = (U8*)SvPV(sv, len);
3858 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3863 I32 uoffset = *offsetp;
3869 start = s = (U8*)SvPV(sv, len);
3871 while (s < send && uoffset--)
3875 *offsetp = s - start;
3879 while (s < send && ulen--)
3889 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3898 s = (U8*)SvPV(sv, len);
3900 Perl_croak(aTHX_ "panic: bad byte offset");
3901 send = s + *offsetp;
3909 if (ckWARN_d(WARN_UTF8))
3910 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3920 Returns a boolean indicating whether the strings in the two SVs are
3927 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3939 pv1 = SvPV(str1, cur1);
3944 if (SvUTF8(str1) != SvUTF8(str2)) {
3946 sv_utf8_upgrade(str2);
3949 sv_utf8_upgrade(str1);
3953 pv2 = SvPV(str2, cur2);
3958 return memEQ(pv1, pv2, cur1);
3964 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3965 string in C<sv1> is less than, equal to, or greater than the string in
3972 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3979 pv1 = SvPV(str1, cur1);
3987 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3988 /* must upgrade other to UTF8 first */
3990 sv_utf8_upgrade(str2);
3993 sv_utf8_upgrade(str1);
3994 /* refresh pointer and length */
4003 pv2 = sv_2pv(str2, &cur2);
4011 return cur2 ? -1 : 0;
4016 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4019 return retval < 0 ? -1 : 1;
4024 return cur1 < cur2 ? -1 : 1;
4028 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4030 #ifdef USE_LOCALE_COLLATE
4036 if (PL_collation_standard)
4040 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4042 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4044 if (!pv1 || !len1) {
4055 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4058 return retval < 0 ? -1 : 1;
4061 * When the result of collation is equality, that doesn't mean
4062 * that there are no differences -- some locales exclude some
4063 * characters from consideration. So to avoid false equalities,
4064 * we use the raw string as a tiebreaker.
4070 #endif /* USE_LOCALE_COLLATE */
4072 return sv_cmp(sv1, sv2);
4075 #ifdef USE_LOCALE_COLLATE
4077 * Any scalar variable may carry an 'o' magic that contains the
4078 * scalar data of the variable transformed to such a format that
4079 * a normal memory comparison can be used to compare the data
4080 * according to the locale settings.
4083 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4087 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4088 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4093 Safefree(mg->mg_ptr);
4095 if ((xf = mem_collxfrm(s, len, &xlen))) {
4096 if (SvREADONLY(sv)) {
4099 return xf + sizeof(PL_collation_ix);
4102 sv_magic(sv, 0, 'o', 0, 0);
4103 mg = mg_find(sv, 'o');
4116 if (mg && mg->mg_ptr) {
4118 return mg->mg_ptr + sizeof(PL_collation_ix);
4126 #endif /* USE_LOCALE_COLLATE */
4129 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4134 register STDCHAR rslast;
4135 register STDCHAR *bp;
4139 SV_CHECK_THINKFIRST(sv);
4140 (void)SvUPGRADE(sv, SVt_PV);
4144 if (RsSNARF(PL_rs)) {
4148 else if (RsRECORD(PL_rs)) {
4149 I32 recsize, bytesread;
4152 /* Grab the size of the record we're getting */
4153 recsize = SvIV(SvRV(PL_rs));
4154 (void)SvPOK_only(sv); /* Validate pointer */
4155 buffer = SvGROW(sv, recsize + 1);
4158 /* VMS wants read instead of fread, because fread doesn't respect */
4159 /* RMS record boundaries. This is not necessarily a good thing to be */
4160 /* doing, but we've got no other real choice */
4161 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4163 bytesread = PerlIO_read(fp, buffer, recsize);
4165 SvCUR_set(sv, bytesread);
4166 buffer[bytesread] = '\0';
4167 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4169 else if (RsPARA(PL_rs)) {
4174 rsptr = SvPV(PL_rs, rslen);
4175 rslast = rslen ? rsptr[rslen - 1] : '\0';
4177 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4178 do { /* to make sure file boundaries work right */
4181 i = PerlIO_getc(fp);
4185 PerlIO_ungetc(fp,i);
4191 /* See if we know enough about I/O mechanism to cheat it ! */
4193 /* This used to be #ifdef test - it is made run-time test for ease
4194 of abstracting out stdio interface. One call should be cheap
4195 enough here - and may even be a macro allowing compile
4199 if (PerlIO_fast_gets(fp)) {
4202 * We're going to steal some values from the stdio struct
4203 * and put EVERYTHING in the innermost loop into registers.
4205 register STDCHAR *ptr;
4209 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4210 /* An ungetc()d char is handled separately from the regular
4211 * buffer, so we getc() it back out and stuff it in the buffer.
4213 i = PerlIO_getc(fp);
4214 if (i == EOF) return 0;
4215 *(--((*fp)->_ptr)) = (unsigned char) i;
4219 /* Here is some breathtakingly efficient cheating */
4221 cnt = PerlIO_get_cnt(fp); /* get count into register */
4222 (void)SvPOK_only(sv); /* validate pointer */
4223 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4224 if (cnt > 80 && SvLEN(sv) > append) {
4225 shortbuffered = cnt - SvLEN(sv) + append + 1;
4226 cnt -= shortbuffered;
4230 /* remember that cnt can be negative */
4231 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4236 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4237 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4238 DEBUG_P(PerlIO_printf(Perl_debug_log,
4239 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4240 DEBUG_P(PerlIO_printf(Perl_debug_log,
4241 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4242 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4243 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4248 while (cnt > 0) { /* this | eat */
4250 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4251 goto thats_all_folks; /* screams | sed :-) */
4255 Copy(ptr, bp, cnt, char); /* this | eat */
4256 bp += cnt; /* screams | dust */
4257 ptr += cnt; /* louder | sed :-) */
4262 if (shortbuffered) { /* oh well, must extend */
4263 cnt = shortbuffered;
4265 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4267 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4268 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4272 DEBUG_P(PerlIO_printf(Perl_debug_log,
4273 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4274 PTR2UV(ptr),(long)cnt));
4275 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4276 DEBUG_P(PerlIO_printf(Perl_debug_log,
4277 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4278 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4279 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4280 /* This used to call 'filbuf' in stdio form, but as that behaves like
4281 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4282 another abstraction. */
4283 i = PerlIO_getc(fp); /* get more characters */
4284 DEBUG_P(PerlIO_printf(Perl_debug_log,
4285 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4286 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4287 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4288 cnt = PerlIO_get_cnt(fp);
4289 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4290 DEBUG_P(PerlIO_printf(Perl_debug_log,
4291 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4293 if (i == EOF) /* all done for ever? */
4294 goto thats_really_all_folks;
4296 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4298 SvGROW(sv, bpx + cnt + 2);
4299 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4301 *bp++ = i; /* store character from PerlIO_getc */
4303 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4304 goto thats_all_folks;
4308 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4309 memNE((char*)bp - rslen, rsptr, rslen))
4310 goto screamer; /* go back to the fray */
4311 thats_really_all_folks:
4313 cnt += shortbuffered;
4314 DEBUG_P(PerlIO_printf(Perl_debug_log,
4315 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4316 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4317 DEBUG_P(PerlIO_printf(Perl_debug_log,
4318 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4319 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4320 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4322 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4323 DEBUG_P(PerlIO_printf(Perl_debug_log,
4324 "Screamer: done, len=%ld, string=|%.*s|\n",
4325 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4330 /*The big, slow, and stupid way */
4333 /* Need to work around EPOC SDK features */
4334 /* On WINS: MS VC5 generates calls to _chkstk, */
4335 /* if a `large' stack frame is allocated */
4336 /* gcc on MARM does not generate calls like these */
4342 register STDCHAR *bpe = buf + sizeof(buf);
4344 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4345 ; /* keep reading */
4349 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4350 /* Accomodate broken VAXC compiler, which applies U8 cast to
4351 * both args of ?: operator, causing EOF to change into 255
4353 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4357 sv_catpvn(sv, (char *) buf, cnt);
4359 sv_setpvn(sv, (char *) buf, cnt);
4361 if (i != EOF && /* joy */
4363 SvCUR(sv) < rslen ||
4364 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4368 * If we're reading from a TTY and we get a short read,
4369 * indicating that the user hit his EOF character, we need
4370 * to notice it now, because if we try to read from the TTY
4371 * again, the EOF condition will disappear.
4373 * The comparison of cnt to sizeof(buf) is an optimization
4374 * that prevents unnecessary calls to feof().
4378 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4383 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4384 while (i != EOF) { /* to make sure file boundaries work right */
4385 i = PerlIO_getc(fp);
4387 PerlIO_ungetc(fp,i);
4393 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4400 Auto-increment of the value in the SV.
4406 Perl_sv_inc(pTHX_ register SV *sv)
4415 if (SvTHINKFIRST(sv)) {
4416 if (SvREADONLY(sv)) {
4418 if (PL_curcop != &PL_compiling)
4419 Perl_croak(aTHX_ PL_no_modify);
4423 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4425 i = PTR2IV(SvRV(sv));
4430 flags = SvFLAGS(sv);
4431 if (flags & SVp_NOK) {
4432 (void)SvNOK_only(sv);
4436 if (flags & SVp_IOK) {
4438 if (SvUVX(sv) == UV_MAX)
4439 sv_setnv(sv, (NV)UV_MAX + 1.0);
4441 (void)SvIOK_only_UV(sv);
4444 if (SvIVX(sv) == IV_MAX)
4445 sv_setnv(sv, (NV)IV_MAX + 1.0);
4447 (void)SvIOK_only(sv);
4453 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4454 if ((flags & SVTYPEMASK) < SVt_PVNV)
4455 sv_upgrade(sv, SVt_NV);
4457 (void)SvNOK_only(sv);
4461 while (isALPHA(*d)) d++;
4462 while (isDIGIT(*d)) d++;
4464 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4468 while (d >= SvPVX(sv)) {
4476 /* MKS: The original code here died if letters weren't consecutive.
4477 * at least it didn't have to worry about non-C locales. The
4478 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4479 * arranged in order (although not consecutively) and that only
4480 * [A-Za-z] are accepted by isALPHA in the C locale.
4482 if (*d != 'z' && *d != 'Z') {
4483 do { ++*d; } while (!isALPHA(*d));
4486 *(d--) -= 'z' - 'a';
4491 *(d--) -= 'z' - 'a' + 1;
4495 /* oh,oh, the number grew */
4496 SvGROW(sv, SvCUR(sv) + 2);
4498 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4509 Auto-decrement of the value in the SV.
4515 Perl_sv_dec(pTHX_ register SV *sv)
4523 if (SvTHINKFIRST(sv)) {
4524 if (SvREADONLY(sv)) {
4526 if (PL_curcop != &PL_compiling)
4527 Perl_croak(aTHX_ PL_no_modify);
4531 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4533 i = PTR2IV(SvRV(sv));
4538 flags = SvFLAGS(sv);
4539 if (flags & SVp_NOK) {
4541 (void)SvNOK_only(sv);
4544 if (flags & SVp_IOK) {
4546 if (SvUVX(sv) == 0) {
4547 (void)SvIOK_only(sv);
4551 (void)SvIOK_only_UV(sv);
4555 if (SvIVX(sv) == IV_MIN)
4556 sv_setnv(sv, (NV)IV_MIN - 1.0);
4558 (void)SvIOK_only(sv);
4564 if (!(flags & SVp_POK)) {
4565 if ((flags & SVTYPEMASK) < SVt_PVNV)
4566 sv_upgrade(sv, SVt_NV);
4568 (void)SvNOK_only(sv);
4571 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4575 =for apidoc sv_mortalcopy
4577 Creates a new SV which is a copy of the original SV. The new SV is marked
4583 /* Make a string that will exist for the duration of the expression
4584 * evaluation. Actually, it may have to last longer than that, but
4585 * hopefully we won't free it until it has been assigned to a
4586 * permanent location. */
4589 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4595 sv_setsv(sv,oldstr);
4597 PL_tmps_stack[++PL_tmps_ix] = sv;
4603 =for apidoc sv_newmortal
4605 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4611 Perl_sv_newmortal(pTHX)
4617 SvFLAGS(sv) = SVs_TEMP;
4619 PL_tmps_stack[++PL_tmps_ix] = sv;
4624 =for apidoc sv_2mortal
4626 Marks an SV as mortal. The SV will be destroyed when the current context
4632 /* same thing without the copying */
4635 Perl_sv_2mortal(pTHX_ register SV *sv)
4640 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4643 PL_tmps_stack[++PL_tmps_ix] = sv;
4651 Creates a new SV and copies a string into it. The reference count for the
4652 SV is set to 1. If C<len> is zero, Perl will compute the length using
4653 strlen(). For efficiency, consider using C<newSVpvn> instead.
4659 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4666 sv_setpvn(sv,s,len);
4671 =for apidoc newSVpvn
4673 Creates a new SV and copies a string into it. The reference count for the
4674 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4675 string. You are responsible for ensuring that the source string is at least
4682 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4687 sv_setpvn(sv,s,len);
4691 #if defined(PERL_IMPLICIT_CONTEXT)
4693 Perl_newSVpvf_nocontext(const char* pat, ...)
4698 va_start(args, pat);
4699 sv = vnewSVpvf(pat, &args);
4706 =for apidoc newSVpvf
4708 Creates a new SV an initialize it with the string formatted like
4715 Perl_newSVpvf(pTHX_ const char* pat, ...)
4719 va_start(args, pat);
4720 sv = vnewSVpvf(pat, &args);
4726 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4730 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4737 Creates a new SV and copies a floating point value into it.
4738 The reference count for the SV is set to 1.
4744 Perl_newSVnv(pTHX_ NV n)
4756 Creates a new SV and copies an integer into it. The reference count for the
4763 Perl_newSViv(pTHX_ IV i)
4775 Creates a new SV and copies an unsigned integer into it.
4776 The reference count for the SV is set to 1.
4782 Perl_newSVuv(pTHX_ UV u)
4792 =for apidoc newRV_noinc
4794 Creates an RV wrapper for an SV. The reference count for the original
4795 SV is B<not> incremented.
4801 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4807 sv_upgrade(sv, SVt_RV);
4814 /* newRV_inc is #defined to newRV in sv.h */
4816 Perl_newRV(pTHX_ SV *tmpRef)
4818 return newRV_noinc(SvREFCNT_inc(tmpRef));
4824 Creates a new SV which is an exact duplicate of the original SV.
4829 /* make an exact duplicate of old */
4832 Perl_newSVsv(pTHX_ register SV *old)
4839 if (SvTYPE(old) == SVTYPEMASK) {
4840 if (ckWARN_d(WARN_INTERNAL))
4841 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4856 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4864 char todo[PERL_UCHAR_MAX+1];
4869 if (!*s) { /* reset ?? searches */
4870 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4871 pm->op_pmdynflags &= ~PMdf_USED;
4876 /* reset variables */
4878 if (!HvARRAY(stash))
4881 Zero(todo, 256, char);
4883 i = (unsigned char)*s;
4887 max = (unsigned char)*s++;
4888 for ( ; i <= max; i++) {
4891 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4892 for (entry = HvARRAY(stash)[i];
4894 entry = HeNEXT(entry))
4896 if (!todo[(U8)*HeKEY(entry)])
4898 gv = (GV*)HeVAL(entry);
4900 if (SvTHINKFIRST(sv)) {
4901 if (!SvREADONLY(sv) && SvROK(sv))
4906 if (SvTYPE(sv) >= SVt_PV) {
4908 if (SvPVX(sv) != Nullch)
4915 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4917 #ifndef VMS /* VMS has no environ array */
4919 environ[0] = Nullch;
4928 Perl_sv_2io(pTHX_ SV *sv)
4934 switch (SvTYPE(sv)) {
4942 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4946 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4948 return sv_2io(SvRV(sv));
4949 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4955 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4962 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4969 return *gvp = Nullgv, Nullcv;
4970 switch (SvTYPE(sv)) {
4990 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4991 tryAMAGICunDEREF(to_cv);
4994 if (SvTYPE(sv) == SVt_PVCV) {
5003 Perl_croak(aTHX_ "Not a subroutine reference");
5008 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5014 if (lref && !GvCVu(gv)) {
5017 tmpsv = NEWSV(704,0);
5018 gv_efullname3(tmpsv, gv, Nullch);
5019 /* XXX this is probably not what they think they're getting.
5020 * It has the same effect as "sub name;", i.e. just a forward
5022 newSUB(start_subparse(FALSE, 0),
5023 newSVOP(OP_CONST, 0, tmpsv),
5028 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5035 Perl_sv_true(pTHX_ register SV *sv)
5042 if ((tXpv = (XPV*)SvANY(sv)) &&
5043 (tXpv->xpv_cur > 1 ||
5044 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5051 return SvIVX(sv) != 0;
5054 return SvNVX(sv) != 0.0;
5056 return sv_2bool(sv);
5062 Perl_sv_iv(pTHX_ register SV *sv)
5066 return (IV)SvUVX(sv);
5073 Perl_sv_uv(pTHX_ register SV *sv)
5078 return (UV)SvIVX(sv);
5084 Perl_sv_nv(pTHX_ register SV *sv)
5092 Perl_sv_pv(pTHX_ SV *sv)
5099 return sv_2pv(sv, &n_a);
5103 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5109 return sv_2pv(sv, lp);
5113 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5117 if (SvTHINKFIRST(sv) && !SvROK(sv))
5118 sv_force_normal(sv);
5124 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5126 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5127 PL_op_name[PL_op->op_type]);
5131 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5136 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5137 SvGROW(sv, len + 1);
5138 Move(s,SvPVX(sv),len,char);
5143 SvPOK_on(sv); /* validate pointer */
5145 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5146 PTR2UV(sv),SvPVX(sv)));
5153 Perl_sv_pvbyte(pTHX_ SV *sv)
5159 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5161 return sv_pvn(sv,lp);
5165 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5167 return sv_pvn_force(sv,lp);
5171 Perl_sv_pvutf8(pTHX_ SV *sv)
5173 sv_utf8_upgrade(sv);
5178 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5180 sv_utf8_upgrade(sv);
5181 return sv_pvn(sv,lp);
5185 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5187 sv_utf8_upgrade(sv);
5188 return sv_pvn_force(sv,lp);
5192 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5194 if (ob && SvOBJECT(sv))
5195 return HvNAME(SvSTASH(sv));
5197 switch (SvTYPE(sv)) {
5211 case SVt_PVLV: return "LVALUE";
5212 case SVt_PVAV: return "ARRAY";
5213 case SVt_PVHV: return "HASH";
5214 case SVt_PVCV: return "CODE";
5215 case SVt_PVGV: return "GLOB";
5216 case SVt_PVFM: return "FORMAT";
5217 case SVt_PVIO: return "IO";
5218 default: return "UNKNOWN";
5224 =for apidoc sv_isobject
5226 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5227 object. If the SV is not an RV, or if the object is not blessed, then this
5234 Perl_sv_isobject(pTHX_ SV *sv)
5251 Returns a boolean indicating whether the SV is blessed into the specified
5252 class. This does not check for subtypes; use C<sv_derived_from> to verify
5253 an inheritance relationship.
5259 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5271 return strEQ(HvNAME(SvSTASH(sv)), name);
5277 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5278 it will be upgraded to one. If C<classname> is non-null then the new SV will
5279 be blessed in the specified package. The new SV is returned and its
5280 reference count is 1.
5286 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5293 SV_CHECK_THINKFIRST(rv);
5296 if (SvTYPE(rv) < SVt_RV)
5297 sv_upgrade(rv, SVt_RV);
5304 HV* stash = gv_stashpv(classname, TRUE);
5305 (void)sv_bless(rv, stash);
5311 =for apidoc sv_setref_pv
5313 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5314 argument will be upgraded to an RV. That RV will be modified to point to
5315 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5316 into the SV. The C<classname> argument indicates the package for the
5317 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5318 will be returned and will have a reference count of 1.
5320 Do not use with other Perl types such as HV, AV, SV, CV, because those
5321 objects will become corrupted by the pointer copy process.
5323 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5329 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5332 sv_setsv(rv, &PL_sv_undef);
5336 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5341 =for apidoc sv_setref_iv
5343 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5344 argument will be upgraded to an RV. That RV will be modified to point to
5345 the new SV. The C<classname> argument indicates the package for the
5346 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5347 will be returned and will have a reference count of 1.
5353 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5355 sv_setiv(newSVrv(rv,classname), iv);
5360 =for apidoc sv_setref_nv
5362 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5363 argument will be upgraded to an RV. That RV will be modified to point to
5364 the new SV. The C<classname> argument indicates the package for the
5365 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5366 will be returned and will have a reference count of 1.
5372 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5374 sv_setnv(newSVrv(rv,classname), nv);
5379 =for apidoc sv_setref_pvn
5381 Copies a string into a new SV, optionally blessing the SV. The length of the
5382 string must be specified with C<n>. The C<rv> argument will be upgraded to
5383 an RV. That RV will be modified to point to the new SV. The C<classname>
5384 argument indicates the package for the blessing. Set C<classname> to
5385 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5386 a reference count of 1.
5388 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5394 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5396 sv_setpvn(newSVrv(rv,classname), pv, n);
5401 =for apidoc sv_bless
5403 Blesses an SV into a specified package. The SV must be an RV. The package
5404 must be designated by its stash (see C<gv_stashpv()>). The reference count
5405 of the SV is unaffected.
5411 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5416 Perl_croak(aTHX_ "Can't bless non-reference value");
5418 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5419 if (SvREADONLY(tmpRef))
5420 Perl_croak(aTHX_ PL_no_modify);
5421 if (SvOBJECT(tmpRef)) {
5422 if (SvTYPE(tmpRef) != SVt_PVIO)
5424 SvREFCNT_dec(SvSTASH(tmpRef));
5427 SvOBJECT_on(tmpRef);
5428 if (SvTYPE(tmpRef) != SVt_PVIO)
5430 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5431 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5442 S_sv_unglob(pTHX_ SV *sv)
5446 assert(SvTYPE(sv) == SVt_PVGV);
5451 SvREFCNT_dec(GvSTASH(sv));
5452 GvSTASH(sv) = Nullhv;
5454 sv_unmagic(sv, '*');
5455 Safefree(GvNAME(sv));
5458 /* need to keep SvANY(sv) in the right arena */
5459 xpvmg = new_XPVMG();
5460 StructCopy(SvANY(sv), xpvmg, XPVMG);
5461 del_XPVGV(SvANY(sv));
5464 SvFLAGS(sv) &= ~SVTYPEMASK;
5465 SvFLAGS(sv) |= SVt_PVMG;
5469 =for apidoc sv_unref
5471 Unsets the RV status of the SV, and decrements the reference count of
5472 whatever was being referenced by the RV. This can almost be thought of
5473 as a reversal of C<newSVrv>. See C<SvROK_off>.
5479 Perl_sv_unref(pTHX_ SV *sv)
5483 if (SvWEAKREF(sv)) {
5491 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5494 sv_2mortal(rv); /* Schedule for freeing later */
5498 Perl_sv_taint(pTHX_ SV *sv)
5500 sv_magic((sv), Nullsv, 't', Nullch, 0);
5504 Perl_sv_untaint(pTHX_ SV *sv)
5506 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5507 MAGIC *mg = mg_find(sv, 't');
5514 Perl_sv_tainted(pTHX_ SV *sv)
5516 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5517 MAGIC *mg = mg_find(sv, 't');
5518 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5525 =for apidoc sv_setpviv
5527 Copies an integer into the given SV, also updating its string value.
5528 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5534 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5536 char buf[TYPE_CHARS(UV)];
5538 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5540 sv_setpvn(sv, ptr, ebuf - ptr);
5545 =for apidoc sv_setpviv_mg
5547 Like C<sv_setpviv>, but also handles 'set' magic.
5553 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5555 char buf[TYPE_CHARS(UV)];
5557 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5559 sv_setpvn(sv, ptr, ebuf - ptr);
5563 #if defined(PERL_IMPLICIT_CONTEXT)
5565 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5569 va_start(args, pat);
5570 sv_vsetpvf(sv, pat, &args);
5576 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5580 va_start(args, pat);
5581 sv_vsetpvf_mg(sv, pat, &args);
5587 =for apidoc sv_setpvf
5589 Processes its arguments like C<sprintf> and sets an SV to the formatted
5590 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5596 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5599 va_start(args, pat);
5600 sv_vsetpvf(sv, pat, &args);
5605 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5607 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5611 =for apidoc sv_setpvf_mg
5613 Like C<sv_setpvf>, but also handles 'set' magic.
5619 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5622 va_start(args, pat);
5623 sv_vsetpvf_mg(sv, pat, &args);
5628 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5630 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5634 #if defined(PERL_IMPLICIT_CONTEXT)
5636 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5640 va_start(args, pat);
5641 sv_vcatpvf(sv, pat, &args);
5646 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5650 va_start(args, pat);
5651 sv_vcatpvf_mg(sv, pat, &args);
5657 =for apidoc sv_catpvf
5659 Processes its arguments like C<sprintf> and appends the formatted output
5660 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5661 typically be called after calling this function to handle 'set' magic.
5667 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5670 va_start(args, pat);
5671 sv_vcatpvf(sv, pat, &args);
5676 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5678 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5682 =for apidoc sv_catpvf_mg
5684 Like C<sv_catpvf>, but also handles 'set' magic.
5690 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5693 va_start(args, pat);
5694 sv_vcatpvf_mg(sv, pat, &args);
5699 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5701 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5706 =for apidoc sv_vsetpvfn
5708 Works like C<vcatpvfn> but copies the text into the SV instead of
5715 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5717 sv_setpvn(sv, "", 0);
5718 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5722 =for apidoc sv_vcatpvfn
5724 Processes its arguments like C<vsprintf> and appends the formatted output
5725 to an SV. Uses an array of SVs if the C style variable argument list is
5726 missing (NULL). When running with taint checks enabled, indicates via
5727 C<maybe_tainted> if results are untrustworthy (often due to the use of
5734 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5742 static char nullstr[] = "(null)";
5745 /* no matter what, this is a string now */
5746 (void)SvPV_force(sv, origlen);
5748 /* special-case "", "%s", and "%_" */
5751 if (patlen == 2 && pat[0] == '%') {
5755 char *s = va_arg(*args, char*);
5756 sv_catpv(sv, s ? s : nullstr);
5758 else if (svix < svmax) {
5759 sv_catsv(sv, *svargs);
5760 if (DO_UTF8(*svargs))
5766 argsv = va_arg(*args, SV*);
5767 sv_catsv(sv, argsv);
5772 /* See comment on '_' below */
5777 patend = (char*)pat + patlen;
5778 for (p = (char*)pat; p < patend; p = q) {
5781 bool vectorize = FALSE;
5788 bool has_precis = FALSE;
5790 bool is_utf = FALSE;
5793 U8 utf8buf[UTF8_MAXLEN];
5794 STRLEN esignlen = 0;
5796 char *eptr = Nullch;
5798 /* Times 4: a decimal digit takes more than 3 binary digits.
5799 * NV_DIG: mantissa takes than many decimal digits.
5800 * Plus 32: Playing safe. */
5801 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5802 /* large enough for "%#.#f" --chip */
5803 /* what about long double NVs? --jhi */
5806 U8 *vecstr = Null(U8*);
5818 STRLEN dotstrlen = 1;
5820 for (q = p; q < patend && *q != '%'; ++q) ;
5822 sv_catpvn(sv, p, q - p);
5851 case '*': /* printf("%*vX",":",$ipv6addr) */
5856 vecsv = va_arg(*args, SV*);
5857 else if (svix < svmax)
5858 vecsv = svargs[svix++];
5861 dotstr = SvPVx(vecsv,dotstrlen);
5870 vecsv = va_arg(*args, SV*);
5871 else if (svix < svmax)
5872 vecsv = svargs[svix++];
5878 vecstr = (U8*)SvPVx(vecsv,veclen);
5879 utf = DO_UTF8(vecsv);
5891 case '1': case '2': case '3':
5892 case '4': case '5': case '6':
5893 case '7': case '8': case '9':
5896 width = width * 10 + (*q++ - '0');
5901 i = va_arg(*args, int);
5903 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5905 width = (i < 0) ? -i : i;
5916 i = va_arg(*args, int);
5918 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5919 precis = (i < 0) ? 0 : i;
5925 precis = precis * 10 + (*q++ - '0');
5942 if (*(q + 1) == 'l') { /* lld */
5956 #ifdef USE_64_BIT_INT
5974 uv = va_arg(*args, int);
5976 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5977 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5978 eptr = (char*)utf8buf;
5979 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5991 eptr = va_arg(*args, char*);
5993 #ifdef MACOS_TRADITIONAL
5994 /* On MacOS, %#s format is used for Pascal strings */
5999 elen = strlen(eptr);
6002 elen = sizeof nullstr - 1;
6005 else if (svix < svmax) {
6006 argsv = svargs[svix++];
6007 eptr = SvPVx(argsv, elen);
6008 if (DO_UTF8(argsv)) {
6009 if (has_precis && precis < elen) {
6011 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6014 if (width) { /* fudge width (can't fudge elen) */
6015 width += elen - sv_len_utf8(argsv);
6024 * The "%_" hack might have to be changed someday,
6025 * if ISO or ANSI decide to use '_' for something.
6026 * So we keep it hidden from users' code.
6030 argsv = va_arg(*args,SV*);
6031 eptr = SvPVx(argsv, elen);
6037 if (has_precis && elen > precis)
6045 uv = PTR2UV(va_arg(*args, void*));
6047 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6067 iv = (IV)utf8_to_uv(vecstr, &ulen);
6077 case 'h': iv = (short)va_arg(*args, int); break;
6078 default: iv = va_arg(*args, int); break;
6079 case 'l': iv = va_arg(*args, long); break;
6080 case 'V': iv = va_arg(*args, IV); break;
6082 case 'q': iv = va_arg(*args, Quad_t); break;
6087 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6089 case 'h': iv = (short)iv; break;
6090 default: iv = (int)iv; break;
6091 case 'l': iv = (long)iv; break;
6094 case 'q': iv = (Quad_t)iv; break;
6101 esignbuf[esignlen++] = plus;
6105 esignbuf[esignlen++] = '-';
6149 uv = utf8_to_uv(vecstr, &ulen);
6159 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6160 default: uv = va_arg(*args, unsigned); break;
6161 case 'l': uv = va_arg(*args, unsigned long); break;
6162 case 'V': uv = va_arg(*args, UV); break;
6164 case 'q': uv = va_arg(*args, Quad_t); break;
6169 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6171 case 'h': uv = (unsigned short)uv; break;
6172 default: uv = (unsigned)uv; break;
6173 case 'l': uv = (unsigned long)uv; break;
6176 case 'q': uv = (Quad_t)uv; break;
6182 eptr = ebuf + sizeof ebuf;
6188 p = (char*)((c == 'X')
6189 ? "0123456789ABCDEF" : "0123456789abcdef");
6195 esignbuf[esignlen++] = '0';
6196 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6202 *--eptr = '0' + dig;
6204 if (alt && *eptr != '0')
6210 *--eptr = '0' + dig;
6213 esignbuf[esignlen++] = '0';
6214 esignbuf[esignlen++] = 'b';
6217 default: /* it had better be ten or less */
6218 #if defined(PERL_Y2KWARN)
6219 if (ckWARN(WARN_Y2K)) {
6221 char *s = SvPV(sv,n);
6222 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6223 && (n == 2 || !isDIGIT(s[n-3])))
6225 Perl_warner(aTHX_ WARN_Y2K,
6226 "Possible Y2K bug: %%%c %s",
6227 c, "format string following '19'");
6233 *--eptr = '0' + dig;
6234 } while (uv /= base);
6237 elen = (ebuf + sizeof ebuf) - eptr;
6240 zeros = precis - elen;
6241 else if (precis == 0 && elen == 1 && *eptr == '0')
6246 /* FLOATING POINT */
6249 c = 'f'; /* maybe %F isn't supported here */
6255 /* This is evil, but floating point is even more evil */
6259 nv = va_arg(*args, NV);
6261 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6264 if (c != 'e' && c != 'E') {
6266 (void)Perl_frexp(nv, &i);
6267 if (i == PERL_INT_MIN)
6268 Perl_die(aTHX_ "panic: frexp");
6270 need = BIT_DIGITS(i);
6272 need += has_precis ? precis : 6; /* known default */
6276 need += 20; /* fudge factor */
6277 if (PL_efloatsize < need) {
6278 Safefree(PL_efloatbuf);
6279 PL_efloatsize = need + 20; /* more fudge */
6280 New(906, PL_efloatbuf, PL_efloatsize, char);
6281 PL_efloatbuf[0] = '\0';
6284 eptr = ebuf + sizeof ebuf;
6287 #ifdef USE_LONG_DOUBLE
6289 static char const my_prifldbl[] = PERL_PRIfldbl;
6290 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6291 while (p >= my_prifldbl) { *--eptr = *p--; }
6296 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6301 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6314 RESTORE_NUMERIC_STANDARD();
6315 (void)sprintf(PL_efloatbuf, eptr, nv);
6316 RESTORE_NUMERIC_LOCAL();
6319 eptr = PL_efloatbuf;
6320 elen = strlen(PL_efloatbuf);
6327 i = SvCUR(sv) - origlen;
6330 case 'h': *(va_arg(*args, short*)) = i; break;
6331 default: *(va_arg(*args, int*)) = i; break;
6332 case 'l': *(va_arg(*args, long*)) = i; break;
6333 case 'V': *(va_arg(*args, IV*)) = i; break;
6335 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6339 else if (svix < svmax)
6340 sv_setuv(svargs[svix++], (UV)i);
6341 continue; /* not "break" */
6348 if (!args && ckWARN(WARN_PRINTF) &&
6349 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6350 SV *msg = sv_newmortal();
6351 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6352 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6355 Perl_sv_catpvf(aTHX_ msg,
6356 "\"%%%c\"", c & 0xFF);
6358 Perl_sv_catpvf(aTHX_ msg,
6359 "\"%%\\%03"UVof"\"",
6362 sv_catpv(msg, "end of string");
6363 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6366 /* output mangled stuff ... */
6372 /* ... right here, because formatting flags should not apply */
6373 SvGROW(sv, SvCUR(sv) + elen + 1);
6375 memcpy(p, eptr, elen);
6378 SvCUR(sv) = p - SvPVX(sv);
6379 continue; /* not "break" */
6382 have = esignlen + zeros + elen;
6383 need = (have > width ? have : width);
6386 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6388 if (esignlen && fill == '0') {
6389 for (i = 0; i < esignlen; i++)
6393 memset(p, fill, gap);
6396 if (esignlen && fill != '0') {
6397 for (i = 0; i < esignlen; i++)
6401 for (i = zeros; i; i--)
6405 memcpy(p, eptr, elen);
6409 memset(p, ' ', gap);
6414 memcpy(p, dotstr, dotstrlen);
6418 vectorize = FALSE; /* done iterating over vecstr */
6423 SvCUR(sv) = p - SvPVX(sv);
6431 #if defined(USE_ITHREADS)
6433 #if defined(USE_THREADS)
6434 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6437 #ifndef GpREFCNT_inc
6438 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6442 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6443 #define av_dup(s) (AV*)sv_dup((SV*)s)
6444 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6445 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6446 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6447 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6448 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6449 #define io_dup(s) (IO*)sv_dup((SV*)s)
6450 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6451 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6452 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6453 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6454 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6457 Perl_re_dup(pTHX_ REGEXP *r)
6459 /* XXX fix when pmop->op_pmregexp becomes shared */
6460 return ReREFCNT_inc(r);
6464 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6468 return (PerlIO*)NULL;
6470 /* look for it in the table first */
6471 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6475 /* create anew and remember what it is */
6476 ret = PerlIO_fdupopen(fp);
6477 ptr_table_store(PL_ptr_table, fp, ret);
6482 Perl_dirp_dup(pTHX_ DIR *dp)
6491 Perl_gp_dup(pTHX_ GP *gp)
6496 /* look for it in the table first */
6497 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6501 /* create anew and remember what it is */
6502 Newz(0, ret, 1, GP);
6503 ptr_table_store(PL_ptr_table, gp, ret);
6506 ret->gp_refcnt = 0; /* must be before any other dups! */
6507 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6508 ret->gp_io = io_dup_inc(gp->gp_io);
6509 ret->gp_form = cv_dup_inc(gp->gp_form);
6510 ret->gp_av = av_dup_inc(gp->gp_av);
6511 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6512 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6513 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6514 ret->gp_cvgen = gp->gp_cvgen;
6515 ret->gp_flags = gp->gp_flags;
6516 ret->gp_line = gp->gp_line;
6517 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6522 Perl_mg_dup(pTHX_ MAGIC *mg)
6524 MAGIC *mgret = (MAGIC*)NULL;
6527 return (MAGIC*)NULL;
6528 /* look for it in the table first */
6529 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6533 for (; mg; mg = mg->mg_moremagic) {
6535 Newz(0, nmg, 1, MAGIC);
6539 mgprev->mg_moremagic = nmg;
6540 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6541 nmg->mg_private = mg->mg_private;
6542 nmg->mg_type = mg->mg_type;
6543 nmg->mg_flags = mg->mg_flags;
6544 if (mg->mg_type == 'r') {
6545 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6548 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6549 ? sv_dup_inc(mg->mg_obj)
6550 : sv_dup(mg->mg_obj);
6552 nmg->mg_len = mg->mg_len;
6553 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6554 if (mg->mg_ptr && mg->mg_type != 'g') {
6555 if (mg->mg_len >= 0) {
6556 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6557 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6558 AMT *amtp = (AMT*)mg->mg_ptr;
6559 AMT *namtp = (AMT*)nmg->mg_ptr;
6561 for (i = 1; i < NofAMmeth; i++) {
6562 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6566 else if (mg->mg_len == HEf_SVKEY)
6567 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6575 Perl_ptr_table_new(pTHX)
6578 Newz(0, tbl, 1, PTR_TBL_t);
6581 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6586 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6588 PTR_TBL_ENT_t *tblent;
6589 UV hash = PTR2UV(sv);
6591 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6592 for (; tblent; tblent = tblent->next) {
6593 if (tblent->oldval == sv)
6594 return tblent->newval;
6600 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6602 PTR_TBL_ENT_t *tblent, **otblent;
6603 /* XXX this may be pessimal on platforms where pointers aren't good
6604 * hash values e.g. if they grow faster in the most significant
6606 UV hash = PTR2UV(oldv);
6610 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6611 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6612 if (tblent->oldval == oldv) {
6613 tblent->newval = newv;
6618 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6619 tblent->oldval = oldv;
6620 tblent->newval = newv;
6621 tblent->next = *otblent;
6624 if (i && tbl->tbl_items > tbl->tbl_max)
6625 ptr_table_split(tbl);
6629 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6631 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6632 UV oldsize = tbl->tbl_max + 1;
6633 UV newsize = oldsize * 2;
6636 Renew(ary, newsize, PTR_TBL_ENT_t*);
6637 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6638 tbl->tbl_max = --newsize;
6640 for (i=0; i < oldsize; i++, ary++) {
6641 PTR_TBL_ENT_t **curentp, **entp, *ent;
6644 curentp = ary + oldsize;
6645 for (entp = ary, ent = *ary; ent; ent = *entp) {
6646 if ((newsize & PTR2UV(ent->oldval)) != i) {
6648 ent->next = *curentp;
6663 Perl_sv_dup(pTHX_ SV *sstr)
6667 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6669 /* look for it in the table first */
6670 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6674 /* create anew and remember what it is */
6676 ptr_table_store(PL_ptr_table, sstr, dstr);
6679 SvFLAGS(dstr) = SvFLAGS(sstr);
6680 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6681 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6684 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6685 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6686 PL_watch_pvx, SvPVX(sstr));
6689 switch (SvTYPE(sstr)) {
6694 SvANY(dstr) = new_XIV();
6695 SvIVX(dstr) = SvIVX(sstr);
6698 SvANY(dstr) = new_XNV();
6699 SvNVX(dstr) = SvNVX(sstr);
6702 SvANY(dstr) = new_XRV();
6703 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6706 SvANY(dstr) = new_XPV();
6707 SvCUR(dstr) = SvCUR(sstr);
6708 SvLEN(dstr) = SvLEN(sstr);
6710 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6711 else if (SvPVX(sstr) && SvLEN(sstr))
6712 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6714 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6717 SvANY(dstr) = new_XPVIV();
6718 SvCUR(dstr) = SvCUR(sstr);
6719 SvLEN(dstr) = SvLEN(sstr);
6720 SvIVX(dstr) = SvIVX(sstr);
6722 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6723 else if (SvPVX(sstr) && SvLEN(sstr))
6724 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6726 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6729 SvANY(dstr) = new_XPVNV();
6730 SvCUR(dstr) = SvCUR(sstr);
6731 SvLEN(dstr) = SvLEN(sstr);
6732 SvIVX(dstr) = SvIVX(sstr);
6733 SvNVX(dstr) = SvNVX(sstr);
6735 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6736 else if (SvPVX(sstr) && SvLEN(sstr))
6737 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6739 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6742 SvANY(dstr) = new_XPVMG();
6743 SvCUR(dstr) = SvCUR(sstr);
6744 SvLEN(dstr) = SvLEN(sstr);
6745 SvIVX(dstr) = SvIVX(sstr);
6746 SvNVX(dstr) = SvNVX(sstr);
6747 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6748 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6750 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6751 else if (SvPVX(sstr) && SvLEN(sstr))
6752 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6754 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6757 SvANY(dstr) = new_XPVBM();
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 BmRARE(dstr) = BmRARE(sstr);
6771 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6772 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6775 SvANY(dstr) = new_XPVLV();
6776 SvCUR(dstr) = SvCUR(sstr);
6777 SvLEN(dstr) = SvLEN(sstr);
6778 SvIVX(dstr) = SvIVX(sstr);
6779 SvNVX(dstr) = SvNVX(sstr);
6780 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6781 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6783 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6784 else if (SvPVX(sstr) && SvLEN(sstr))
6785 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6787 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6788 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6789 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6790 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6791 LvTYPE(dstr) = LvTYPE(sstr);
6794 SvANY(dstr) = new_XPVGV();
6795 SvCUR(dstr) = SvCUR(sstr);
6796 SvLEN(dstr) = SvLEN(sstr);
6797 SvIVX(dstr) = SvIVX(sstr);
6798 SvNVX(dstr) = SvNVX(sstr);
6799 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6800 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6802 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6803 else if (SvPVX(sstr) && SvLEN(sstr))
6804 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6806 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6807 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6808 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6809 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6810 GvFLAGS(dstr) = GvFLAGS(sstr);
6811 GvGP(dstr) = gp_dup(GvGP(sstr));
6812 (void)GpREFCNT_inc(GvGP(dstr));
6815 SvANY(dstr) = new_XPVIO();
6816 SvCUR(dstr) = SvCUR(sstr);
6817 SvLEN(dstr) = SvLEN(sstr);
6818 SvIVX(dstr) = SvIVX(sstr);
6819 SvNVX(dstr) = SvNVX(sstr);
6820 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6821 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6823 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6824 else if (SvPVX(sstr) && SvLEN(sstr))
6825 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6827 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6828 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6829 if (IoOFP(sstr) == IoIFP(sstr))
6830 IoOFP(dstr) = IoIFP(dstr);
6832 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6833 /* PL_rsfp_filters entries have fake IoDIRP() */
6834 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6835 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6837 IoDIRP(dstr) = IoDIRP(sstr);
6838 IoLINES(dstr) = IoLINES(sstr);
6839 IoPAGE(dstr) = IoPAGE(sstr);
6840 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6841 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6842 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6843 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6844 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6845 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6846 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6847 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6848 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6849 IoTYPE(dstr) = IoTYPE(sstr);
6850 IoFLAGS(dstr) = IoFLAGS(sstr);
6853 SvANY(dstr) = new_XPVAV();
6854 SvCUR(dstr) = SvCUR(sstr);
6855 SvLEN(dstr) = SvLEN(sstr);
6856 SvIVX(dstr) = SvIVX(sstr);
6857 SvNVX(dstr) = SvNVX(sstr);
6858 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6859 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6860 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6861 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6862 if (AvARRAY((AV*)sstr)) {
6863 SV **dst_ary, **src_ary;
6864 SSize_t items = AvFILLp((AV*)sstr) + 1;
6866 src_ary = AvARRAY((AV*)sstr);
6867 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6868 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6869 SvPVX(dstr) = (char*)dst_ary;
6870 AvALLOC((AV*)dstr) = dst_ary;
6871 if (AvREAL((AV*)sstr)) {
6873 *dst_ary++ = sv_dup_inc(*src_ary++);
6877 *dst_ary++ = sv_dup(*src_ary++);
6879 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6880 while (items-- > 0) {
6881 *dst_ary++ = &PL_sv_undef;
6885 SvPVX(dstr) = Nullch;
6886 AvALLOC((AV*)dstr) = (SV**)NULL;
6890 SvANY(dstr) = new_XPVHV();
6891 SvCUR(dstr) = SvCUR(sstr);
6892 SvLEN(dstr) = SvLEN(sstr);
6893 SvIVX(dstr) = SvIVX(sstr);
6894 SvNVX(dstr) = SvNVX(sstr);
6895 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6896 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6897 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6898 if (HvARRAY((HV*)sstr)) {
6900 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6901 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6902 Newz(0, dxhv->xhv_array,
6903 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6904 while (i <= sxhv->xhv_max) {
6905 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6906 !!HvSHAREKEYS(sstr));
6909 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6912 SvPVX(dstr) = Nullch;
6913 HvEITER((HV*)dstr) = (HE*)NULL;
6915 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6916 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6919 SvANY(dstr) = new_XPVFM();
6920 FmLINES(dstr) = FmLINES(sstr);
6924 SvANY(dstr) = new_XPVCV();
6926 SvCUR(dstr) = SvCUR(sstr);
6927 SvLEN(dstr) = SvLEN(sstr);
6928 SvIVX(dstr) = SvIVX(sstr);
6929 SvNVX(dstr) = SvNVX(sstr);
6930 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6931 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6932 if (SvPVX(sstr) && SvLEN(sstr))
6933 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6935 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6936 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6937 CvSTART(dstr) = CvSTART(sstr);
6938 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6939 CvXSUB(dstr) = CvXSUB(sstr);
6940 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6941 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6942 CvDEPTH(dstr) = CvDEPTH(sstr);
6943 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6944 /* XXX padlists are real, but pretend to be not */
6945 AvREAL_on(CvPADLIST(sstr));
6946 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6947 AvREAL_off(CvPADLIST(sstr));
6948 AvREAL_off(CvPADLIST(dstr));
6951 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6952 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6953 CvFLAGS(dstr) = CvFLAGS(sstr);
6956 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6960 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6967 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6972 return (PERL_CONTEXT*)NULL;
6974 /* look for it in the table first */
6975 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6979 /* create anew and remember what it is */
6980 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6981 ptr_table_store(PL_ptr_table, cxs, ncxs);
6984 PERL_CONTEXT *cx = &cxs[ix];
6985 PERL_CONTEXT *ncx = &ncxs[ix];
6986 ncx->cx_type = cx->cx_type;
6987 if (CxTYPE(cx) == CXt_SUBST) {
6988 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6991 ncx->blk_oldsp = cx->blk_oldsp;
6992 ncx->blk_oldcop = cx->blk_oldcop;
6993 ncx->blk_oldretsp = cx->blk_oldretsp;
6994 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6995 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6996 ncx->blk_oldpm = cx->blk_oldpm;
6997 ncx->blk_gimme = cx->blk_gimme;
6998 switch (CxTYPE(cx)) {
7000 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7001 ? cv_dup_inc(cx->blk_sub.cv)
7002 : cv_dup(cx->blk_sub.cv));
7003 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7004 ? av_dup_inc(cx->blk_sub.argarray)
7006 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7007 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7008 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7009 ncx->blk_sub.lval = cx->blk_sub.lval;
7012 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7013 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7014 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7015 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7016 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7019 ncx->blk_loop.label = cx->blk_loop.label;
7020 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7021 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7022 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7023 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7024 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7025 ? cx->blk_loop.iterdata
7026 : gv_dup((GV*)cx->blk_loop.iterdata));
7027 ncx->blk_loop.oldcurpad
7028 = (SV**)ptr_table_fetch(PL_ptr_table,
7029 cx->blk_loop.oldcurpad);
7030 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7031 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7032 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7033 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7034 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7037 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7038 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7039 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7040 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7053 Perl_si_dup(pTHX_ PERL_SI *si)
7058 return (PERL_SI*)NULL;
7060 /* look for it in the table first */
7061 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7065 /* create anew and remember what it is */
7066 Newz(56, nsi, 1, PERL_SI);
7067 ptr_table_store(PL_ptr_table, si, nsi);
7069 nsi->si_stack = av_dup_inc(si->si_stack);
7070 nsi->si_cxix = si->si_cxix;
7071 nsi->si_cxmax = si->si_cxmax;
7072 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7073 nsi->si_type = si->si_type;
7074 nsi->si_prev = si_dup(si->si_prev);
7075 nsi->si_next = si_dup(si->si_next);
7076 nsi->si_markoff = si->si_markoff;
7081 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7082 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7083 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7084 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7085 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7086 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7087 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7088 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7089 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7090 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7091 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7092 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7095 #define pv_dup_inc(p) SAVEPV(p)
7096 #define pv_dup(p) SAVEPV(p)
7097 #define svp_dup_inc(p,pp) any_dup(p,pp)
7100 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7107 /* look for it in the table first */
7108 ret = ptr_table_fetch(PL_ptr_table, v);
7112 /* see if it is part of the interpreter structure */
7113 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7114 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7122 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7124 ANY *ss = proto_perl->Tsavestack;
7125 I32 ix = proto_perl->Tsavestack_ix;
7126 I32 max = proto_perl->Tsavestack_max;
7139 void (*dptr) (void*);
7140 void (*dxptr) (pTHXo_ void*);
7143 Newz(54, nss, max, ANY);
7149 case SAVEt_ITEM: /* normal string */
7150 sv = (SV*)POPPTR(ss,ix);
7151 TOPPTR(nss,ix) = sv_dup_inc(sv);
7152 sv = (SV*)POPPTR(ss,ix);
7153 TOPPTR(nss,ix) = sv_dup_inc(sv);
7155 case SAVEt_SV: /* scalar reference */
7156 sv = (SV*)POPPTR(ss,ix);
7157 TOPPTR(nss,ix) = sv_dup_inc(sv);
7158 gv = (GV*)POPPTR(ss,ix);
7159 TOPPTR(nss,ix) = gv_dup_inc(gv);
7161 case SAVEt_GENERIC_SVREF: /* generic sv */
7162 case SAVEt_SVREF: /* scalar reference */
7163 sv = (SV*)POPPTR(ss,ix);
7164 TOPPTR(nss,ix) = sv_dup_inc(sv);
7165 ptr = POPPTR(ss,ix);
7166 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7168 case SAVEt_AV: /* array reference */
7169 av = (AV*)POPPTR(ss,ix);
7170 TOPPTR(nss,ix) = av_dup_inc(av);
7171 gv = (GV*)POPPTR(ss,ix);
7172 TOPPTR(nss,ix) = gv_dup(gv);
7174 case SAVEt_HV: /* hash reference */
7175 hv = (HV*)POPPTR(ss,ix);
7176 TOPPTR(nss,ix) = hv_dup_inc(hv);
7177 gv = (GV*)POPPTR(ss,ix);
7178 TOPPTR(nss,ix) = gv_dup(gv);
7180 case SAVEt_INT: /* int reference */
7181 ptr = POPPTR(ss,ix);
7182 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7183 intval = (int)POPINT(ss,ix);
7184 TOPINT(nss,ix) = intval;
7186 case SAVEt_LONG: /* long reference */
7187 ptr = POPPTR(ss,ix);
7188 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7189 longval = (long)POPLONG(ss,ix);
7190 TOPLONG(nss,ix) = longval;
7192 case SAVEt_I32: /* I32 reference */
7193 case SAVEt_I16: /* I16 reference */
7194 case SAVEt_I8: /* I8 reference */
7195 ptr = POPPTR(ss,ix);
7196 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7200 case SAVEt_IV: /* IV reference */
7201 ptr = POPPTR(ss,ix);
7202 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7206 case SAVEt_SPTR: /* SV* reference */
7207 ptr = POPPTR(ss,ix);
7208 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7209 sv = (SV*)POPPTR(ss,ix);
7210 TOPPTR(nss,ix) = sv_dup(sv);
7212 case SAVEt_VPTR: /* random* reference */
7213 ptr = POPPTR(ss,ix);
7214 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7215 ptr = POPPTR(ss,ix);
7216 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7218 case SAVEt_PPTR: /* char* reference */
7219 ptr = POPPTR(ss,ix);
7220 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7221 c = (char*)POPPTR(ss,ix);
7222 TOPPTR(nss,ix) = pv_dup(c);
7224 case SAVEt_HPTR: /* HV* reference */
7225 ptr = POPPTR(ss,ix);
7226 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7227 hv = (HV*)POPPTR(ss,ix);
7228 TOPPTR(nss,ix) = hv_dup(hv);
7230 case SAVEt_APTR: /* AV* reference */
7231 ptr = POPPTR(ss,ix);
7232 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7233 av = (AV*)POPPTR(ss,ix);
7234 TOPPTR(nss,ix) = av_dup(av);
7237 gv = (GV*)POPPTR(ss,ix);
7238 TOPPTR(nss,ix) = gv_dup(gv);
7240 case SAVEt_GP: /* scalar reference */
7241 gp = (GP*)POPPTR(ss,ix);
7242 TOPPTR(nss,ix) = gp = gp_dup(gp);
7243 (void)GpREFCNT_inc(gp);
7244 gv = (GV*)POPPTR(ss,ix);
7245 TOPPTR(nss,ix) = gv_dup_inc(c);
7246 c = (char*)POPPTR(ss,ix);
7247 TOPPTR(nss,ix) = pv_dup(c);
7254 sv = (SV*)POPPTR(ss,ix);
7255 TOPPTR(nss,ix) = sv_dup_inc(sv);
7258 ptr = POPPTR(ss,ix);
7259 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7260 /* these are assumed to be refcounted properly */
7261 switch (((OP*)ptr)->op_type) {
7268 TOPPTR(nss,ix) = ptr;
7273 TOPPTR(nss,ix) = Nullop;
7278 TOPPTR(nss,ix) = Nullop;
7281 c = (char*)POPPTR(ss,ix);
7282 TOPPTR(nss,ix) = pv_dup_inc(c);
7285 longval = POPLONG(ss,ix);
7286 TOPLONG(nss,ix) = longval;
7289 hv = (HV*)POPPTR(ss,ix);
7290 TOPPTR(nss,ix) = hv_dup_inc(hv);
7291 c = (char*)POPPTR(ss,ix);
7292 TOPPTR(nss,ix) = pv_dup_inc(c);
7296 case SAVEt_DESTRUCTOR:
7297 ptr = POPPTR(ss,ix);
7298 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7299 dptr = POPDPTR(ss,ix);
7300 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7302 case SAVEt_DESTRUCTOR_X:
7303 ptr = POPPTR(ss,ix);
7304 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7305 dxptr = POPDXPTR(ss,ix);
7306 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7308 case SAVEt_REGCONTEXT:
7314 case SAVEt_STACK_POS: /* Position on Perl stack */
7318 case SAVEt_AELEM: /* array element */
7319 sv = (SV*)POPPTR(ss,ix);
7320 TOPPTR(nss,ix) = sv_dup_inc(sv);
7323 av = (AV*)POPPTR(ss,ix);
7324 TOPPTR(nss,ix) = av_dup_inc(av);
7326 case SAVEt_HELEM: /* hash element */
7327 sv = (SV*)POPPTR(ss,ix);
7328 TOPPTR(nss,ix) = sv_dup_inc(sv);
7329 sv = (SV*)POPPTR(ss,ix);
7330 TOPPTR(nss,ix) = sv_dup_inc(sv);
7331 hv = (HV*)POPPTR(ss,ix);
7332 TOPPTR(nss,ix) = hv_dup_inc(hv);
7335 ptr = POPPTR(ss,ix);
7336 TOPPTR(nss,ix) = ptr;
7343 av = (AV*)POPPTR(ss,ix);
7344 TOPPTR(nss,ix) = av_dup(av);
7347 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7359 perl_clone(PerlInterpreter *proto_perl, UV flags)
7362 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7365 #ifdef PERL_IMPLICIT_SYS
7366 return perl_clone_using(proto_perl, flags,
7368 proto_perl->IMemShared,
7369 proto_perl->IMemParse,
7379 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7380 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7381 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7382 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7383 struct IPerlDir* ipD, struct IPerlSock* ipS,
7384 struct IPerlProc* ipP)
7386 /* XXX many of the string copies here can be optimized if they're
7387 * constants; they need to be allocated as common memory and just
7388 * their pointers copied. */
7392 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7394 PERL_SET_THX(pPerl);
7395 # else /* !PERL_OBJECT */
7396 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7397 PERL_SET_THX(my_perl);
7400 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7405 # else /* !DEBUGGING */
7406 Zero(my_perl, 1, PerlInterpreter);
7407 # endif /* DEBUGGING */
7411 PL_MemShared = ipMS;
7419 # endif /* PERL_OBJECT */
7420 #else /* !PERL_IMPLICIT_SYS */
7422 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7423 PERL_SET_THX(my_perl);
7426 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7431 # else /* !DEBUGGING */
7432 Zero(my_perl, 1, PerlInterpreter);
7433 # endif /* DEBUGGING */
7434 #endif /* PERL_IMPLICIT_SYS */
7437 PL_xiv_arenaroot = NULL;
7442 PL_xpviv_root = NULL;
7443 PL_xpvnv_root = NULL;
7444 PL_xpvcv_root = NULL;
7445 PL_xpvav_root = NULL;
7446 PL_xpvhv_root = NULL;
7447 PL_xpvmg_root = NULL;
7448 PL_xpvlv_root = NULL;
7449 PL_xpvbm_root = NULL;
7451 PL_nice_chunk = NULL;
7452 PL_nice_chunk_size = 0;
7455 PL_sv_root = Nullsv;
7456 PL_sv_arenaroot = Nullsv;
7458 PL_debug = proto_perl->Idebug;
7460 /* create SV map for pointer relocation */
7461 PL_ptr_table = ptr_table_new();
7463 /* initialize these special pointers as early as possible */
7464 SvANY(&PL_sv_undef) = NULL;
7465 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7466 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7467 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7470 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7472 SvANY(&PL_sv_no) = new_XPVNV();
7474 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7475 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7476 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7477 SvCUR(&PL_sv_no) = 0;
7478 SvLEN(&PL_sv_no) = 1;
7479 SvNVX(&PL_sv_no) = 0;
7480 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7483 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7485 SvANY(&PL_sv_yes) = new_XPVNV();
7487 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7488 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7489 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7490 SvCUR(&PL_sv_yes) = 1;
7491 SvLEN(&PL_sv_yes) = 2;
7492 SvNVX(&PL_sv_yes) = 1;
7493 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7495 /* create shared string table */
7496 PL_strtab = newHV();
7497 HvSHAREKEYS_off(PL_strtab);
7498 hv_ksplit(PL_strtab, 512);
7499 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7501 PL_compiling = proto_perl->Icompiling;
7502 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7503 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7504 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7505 if (!specialWARN(PL_compiling.cop_warnings))
7506 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7507 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7509 /* pseudo environmental stuff */
7510 PL_origargc = proto_perl->Iorigargc;
7512 New(0, PL_origargv, i+1, char*);
7513 PL_origargv[i] = '\0';
7515 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7517 PL_envgv = gv_dup(proto_perl->Ienvgv);
7518 PL_incgv = gv_dup(proto_perl->Iincgv);
7519 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7520 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7521 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7522 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7525 PL_minus_c = proto_perl->Iminus_c;
7526 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7527 PL_localpatches = proto_perl->Ilocalpatches;
7528 PL_splitstr = proto_perl->Isplitstr;
7529 PL_preprocess = proto_perl->Ipreprocess;
7530 PL_minus_n = proto_perl->Iminus_n;
7531 PL_minus_p = proto_perl->Iminus_p;
7532 PL_minus_l = proto_perl->Iminus_l;
7533 PL_minus_a = proto_perl->Iminus_a;
7534 PL_minus_F = proto_perl->Iminus_F;
7535 PL_doswitches = proto_perl->Idoswitches;
7536 PL_dowarn = proto_perl->Idowarn;
7537 PL_doextract = proto_perl->Idoextract;
7538 PL_sawampersand = proto_perl->Isawampersand;
7539 PL_unsafe = proto_perl->Iunsafe;
7540 PL_inplace = SAVEPV(proto_perl->Iinplace);
7541 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7542 PL_perldb = proto_perl->Iperldb;
7543 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7545 /* magical thingies */
7546 /* XXX time(&PL_basetime) when asked for? */
7547 PL_basetime = proto_perl->Ibasetime;
7548 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7550 PL_maxsysfd = proto_perl->Imaxsysfd;
7551 PL_multiline = proto_perl->Imultiline;
7552 PL_statusvalue = proto_perl->Istatusvalue;
7554 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7557 /* shortcuts to various I/O objects */
7558 PL_stdingv = gv_dup(proto_perl->Istdingv);
7559 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7560 PL_defgv = gv_dup(proto_perl->Idefgv);
7561 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7562 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7563 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7565 /* shortcuts to regexp stuff */
7566 PL_replgv = gv_dup(proto_perl->Ireplgv);
7568 /* shortcuts to misc objects */
7569 PL_errgv = gv_dup(proto_perl->Ierrgv);
7571 /* shortcuts to debugging objects */
7572 PL_DBgv = gv_dup(proto_perl->IDBgv);
7573 PL_DBline = gv_dup(proto_perl->IDBline);
7574 PL_DBsub = gv_dup(proto_perl->IDBsub);
7575 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7576 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7577 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7578 PL_lineary = av_dup(proto_perl->Ilineary);
7579 PL_dbargs = av_dup(proto_perl->Idbargs);
7582 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7583 PL_curstash = hv_dup(proto_perl->Tcurstash);
7584 PL_debstash = hv_dup(proto_perl->Idebstash);
7585 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7586 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7588 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7589 PL_endav = av_dup_inc(proto_perl->Iendav);
7590 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7591 PL_initav = av_dup_inc(proto_perl->Iinitav);
7593 PL_sub_generation = proto_perl->Isub_generation;
7595 /* funky return mechanisms */
7596 PL_forkprocess = proto_perl->Iforkprocess;
7598 /* subprocess state */
7599 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7601 /* internal state */
7602 PL_tainting = proto_perl->Itainting;
7603 PL_maxo = proto_perl->Imaxo;
7604 if (proto_perl->Iop_mask)
7605 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7607 PL_op_mask = Nullch;
7609 /* current interpreter roots */
7610 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7611 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7612 PL_main_start = proto_perl->Imain_start;
7613 PL_eval_root = proto_perl->Ieval_root;
7614 PL_eval_start = proto_perl->Ieval_start;
7616 /* runtime control stuff */
7617 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7618 PL_copline = proto_perl->Icopline;
7620 PL_filemode = proto_perl->Ifilemode;
7621 PL_lastfd = proto_perl->Ilastfd;
7622 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7625 PL_gensym = proto_perl->Igensym;
7626 PL_preambled = proto_perl->Ipreambled;
7627 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7628 PL_laststatval = proto_perl->Ilaststatval;
7629 PL_laststype = proto_perl->Ilaststype;
7630 PL_mess_sv = Nullsv;
7632 PL_orslen = proto_perl->Iorslen;
7633 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7634 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7636 /* interpreter atexit processing */
7637 PL_exitlistlen = proto_perl->Iexitlistlen;
7638 if (PL_exitlistlen) {
7639 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7640 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7643 PL_exitlist = (PerlExitListEntry*)NULL;
7644 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7646 PL_profiledata = NULL;
7647 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7648 /* PL_rsfp_filters entries have fake IoDIRP() */
7649 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7651 PL_compcv = cv_dup(proto_perl->Icompcv);
7652 PL_comppad = av_dup(proto_perl->Icomppad);
7653 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7654 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7655 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7656 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7657 proto_perl->Tcurpad);
7659 #ifdef HAVE_INTERP_INTERN
7660 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7663 /* more statics moved here */
7664 PL_generation = proto_perl->Igeneration;
7665 PL_DBcv = cv_dup(proto_perl->IDBcv);
7667 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7668 PL_in_clean_all = proto_perl->Iin_clean_all;
7670 PL_uid = proto_perl->Iuid;
7671 PL_euid = proto_perl->Ieuid;
7672 PL_gid = proto_perl->Igid;
7673 PL_egid = proto_perl->Iegid;
7674 PL_nomemok = proto_perl->Inomemok;
7675 PL_an = proto_perl->Ian;
7676 PL_cop_seqmax = proto_perl->Icop_seqmax;
7677 PL_op_seqmax = proto_perl->Iop_seqmax;
7678 PL_evalseq = proto_perl->Ievalseq;
7679 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7680 PL_origalen = proto_perl->Iorigalen;
7681 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7682 PL_osname = SAVEPV(proto_perl->Iosname);
7683 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7684 PL_sighandlerp = proto_perl->Isighandlerp;
7687 PL_runops = proto_perl->Irunops;
7689 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7692 PL_cshlen = proto_perl->Icshlen;
7693 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7696 PL_lex_state = proto_perl->Ilex_state;
7697 PL_lex_defer = proto_perl->Ilex_defer;
7698 PL_lex_expect = proto_perl->Ilex_expect;
7699 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7700 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7701 PL_lex_starts = proto_perl->Ilex_starts;
7702 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7703 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7704 PL_lex_op = proto_perl->Ilex_op;
7705 PL_lex_inpat = proto_perl->Ilex_inpat;
7706 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7707 PL_lex_brackets = proto_perl->Ilex_brackets;
7708 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7709 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7710 PL_lex_casemods = proto_perl->Ilex_casemods;
7711 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7712 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7714 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7715 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7716 PL_nexttoke = proto_perl->Inexttoke;
7718 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7719 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7720 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7721 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7722 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7723 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7724 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7725 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7726 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7727 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7728 PL_pending_ident = proto_perl->Ipending_ident;
7729 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7731 PL_expect = proto_perl->Iexpect;
7733 PL_multi_start = proto_perl->Imulti_start;
7734 PL_multi_end = proto_perl->Imulti_end;
7735 PL_multi_open = proto_perl->Imulti_open;
7736 PL_multi_close = proto_perl->Imulti_close;
7738 PL_error_count = proto_perl->Ierror_count;
7739 PL_subline = proto_perl->Isubline;
7740 PL_subname = sv_dup_inc(proto_perl->Isubname);
7742 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7743 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7744 PL_padix = proto_perl->Ipadix;
7745 PL_padix_floor = proto_perl->Ipadix_floor;
7746 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7748 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7749 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7750 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7751 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7752 PL_last_lop_op = proto_perl->Ilast_lop_op;
7753 PL_in_my = proto_perl->Iin_my;
7754 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7756 PL_cryptseen = proto_perl->Icryptseen;
7759 PL_hints = proto_perl->Ihints;
7761 PL_amagic_generation = proto_perl->Iamagic_generation;
7763 #ifdef USE_LOCALE_COLLATE
7764 PL_collation_ix = proto_perl->Icollation_ix;
7765 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7766 PL_collation_standard = proto_perl->Icollation_standard;
7767 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7768 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7769 #endif /* USE_LOCALE_COLLATE */
7771 #ifdef USE_LOCALE_NUMERIC
7772 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7773 PL_numeric_standard = proto_perl->Inumeric_standard;
7774 PL_numeric_local = proto_perl->Inumeric_local;
7775 PL_numeric_radix = proto_perl->Inumeric_radix;
7776 #endif /* !USE_LOCALE_NUMERIC */
7778 /* utf8 character classes */
7779 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7780 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7781 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7782 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7783 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7784 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7785 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7786 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7787 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7788 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7789 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7790 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7791 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7792 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7793 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7794 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7795 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7798 PL_last_swash_hv = Nullhv; /* reinits on demand */
7799 PL_last_swash_klen = 0;
7800 PL_last_swash_key[0]= '\0';
7801 PL_last_swash_tmps = (U8*)NULL;
7802 PL_last_swash_slen = 0;
7804 /* perly.c globals */
7805 PL_yydebug = proto_perl->Iyydebug;
7806 PL_yynerrs = proto_perl->Iyynerrs;
7807 PL_yyerrflag = proto_perl->Iyyerrflag;
7808 PL_yychar = proto_perl->Iyychar;
7809 PL_yyval = proto_perl->Iyyval;
7810 PL_yylval = proto_perl->Iyylval;
7812 PL_glob_index = proto_perl->Iglob_index;
7813 PL_srand_called = proto_perl->Isrand_called;
7814 PL_uudmap['M'] = 0; /* reinits on demand */
7815 PL_bitcount = Nullch; /* reinits on demand */
7817 if (proto_perl->Ipsig_ptr) {
7818 int sig_num[] = { SIG_NUM };
7819 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7820 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7821 for (i = 1; PL_sig_name[i]; i++) {
7822 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7823 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7827 PL_psig_ptr = (SV**)NULL;
7828 PL_psig_name = (SV**)NULL;
7831 /* thrdvar.h stuff */
7834 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7835 PL_tmps_ix = proto_perl->Ttmps_ix;
7836 PL_tmps_max = proto_perl->Ttmps_max;
7837 PL_tmps_floor = proto_perl->Ttmps_floor;
7838 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7840 while (i <= PL_tmps_ix) {
7841 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7845 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7846 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7847 Newz(54, PL_markstack, i, I32);
7848 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7849 - proto_perl->Tmarkstack);
7850 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7851 - proto_perl->Tmarkstack);
7852 Copy(proto_perl->Tmarkstack, PL_markstack,
7853 PL_markstack_ptr - PL_markstack + 1, I32);
7855 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7856 * NOTE: unlike the others! */
7857 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7858 PL_scopestack_max = proto_perl->Tscopestack_max;
7859 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7860 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7862 /* next push_return() sets PL_retstack[PL_retstack_ix]
7863 * NOTE: unlike the others! */
7864 PL_retstack_ix = proto_perl->Tretstack_ix;
7865 PL_retstack_max = proto_perl->Tretstack_max;
7866 Newz(54, PL_retstack, PL_retstack_max, OP*);
7867 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7869 /* NOTE: si_dup() looks at PL_markstack */
7870 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7872 /* PL_curstack = PL_curstackinfo->si_stack; */
7873 PL_curstack = av_dup(proto_perl->Tcurstack);
7874 PL_mainstack = av_dup(proto_perl->Tmainstack);
7876 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7877 PL_stack_base = AvARRAY(PL_curstack);
7878 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7879 - proto_perl->Tstack_base);
7880 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7882 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7883 * NOTE: unlike the others! */
7884 PL_savestack_ix = proto_perl->Tsavestack_ix;
7885 PL_savestack_max = proto_perl->Tsavestack_max;
7886 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7887 PL_savestack = ss_dup(proto_perl);
7893 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7894 PL_top_env = &PL_start_env;
7896 PL_op = proto_perl->Top;
7899 PL_Xpv = (XPV*)NULL;
7900 PL_na = proto_perl->Tna;
7902 PL_statbuf = proto_perl->Tstatbuf;
7903 PL_statcache = proto_perl->Tstatcache;
7904 PL_statgv = gv_dup(proto_perl->Tstatgv);
7905 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7907 PL_timesbuf = proto_perl->Ttimesbuf;
7910 PL_tainted = proto_perl->Ttainted;
7911 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7912 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7913 PL_rs = sv_dup_inc(proto_perl->Trs);
7914 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7915 PL_ofslen = proto_perl->Tofslen;
7916 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7917 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7918 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7919 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7920 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7921 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7923 PL_restartop = proto_perl->Trestartop;
7924 PL_in_eval = proto_perl->Tin_eval;
7925 PL_delaymagic = proto_perl->Tdelaymagic;
7926 PL_dirty = proto_perl->Tdirty;
7927 PL_localizing = proto_perl->Tlocalizing;
7929 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7930 PL_protect = proto_perl->Tprotect;
7932 PL_errors = sv_dup_inc(proto_perl->Terrors);
7933 PL_av_fetch_sv = Nullsv;
7934 PL_hv_fetch_sv = Nullsv;
7935 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7936 PL_modcount = proto_perl->Tmodcount;
7937 PL_lastgotoprobe = Nullop;
7938 PL_dumpindent = proto_perl->Tdumpindent;
7940 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7941 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7942 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7943 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7944 PL_sortcxix = proto_perl->Tsortcxix;
7945 PL_efloatbuf = Nullch; /* reinits on demand */
7946 PL_efloatsize = 0; /* reinits on demand */
7950 PL_screamfirst = NULL;
7951 PL_screamnext = NULL;
7952 PL_maxscream = -1; /* reinits on demand */
7953 PL_lastscream = Nullsv;
7955 PL_watchaddr = NULL;
7956 PL_watchok = Nullch;
7958 PL_regdummy = proto_perl->Tregdummy;
7959 PL_regcomp_parse = Nullch;
7960 PL_regxend = Nullch;
7961 PL_regcode = (regnode*)NULL;
7964 PL_regprecomp = Nullch;
7969 PL_seen_zerolen = 0;
7971 PL_regcomp_rx = (regexp*)NULL;
7973 PL_colorset = 0; /* reinits PL_colors[] */
7974 /*PL_colors[6] = {0,0,0,0,0,0};*/
7975 PL_reg_whilem_seen = 0;
7976 PL_reginput = Nullch;
7979 PL_regstartp = (I32*)NULL;
7980 PL_regendp = (I32*)NULL;
7981 PL_reglastparen = (U32*)NULL;
7982 PL_regtill = Nullch;
7984 PL_reg_start_tmp = (char**)NULL;
7985 PL_reg_start_tmpl = 0;
7986 PL_regdata = (struct reg_data*)NULL;
7989 PL_reg_eval_set = 0;
7991 PL_regprogram = (regnode*)NULL;
7993 PL_regcc = (CURCUR*)NULL;
7994 PL_reg_call_cc = (struct re_cc_state*)NULL;
7995 PL_reg_re = (regexp*)NULL;
7996 PL_reg_ganch = Nullch;
7998 PL_reg_magic = (MAGIC*)NULL;
8000 PL_reg_oldcurpm = (PMOP*)NULL;
8001 PL_reg_curpm = (PMOP*)NULL;
8002 PL_reg_oldsaved = Nullch;
8003 PL_reg_oldsavedlen = 0;
8005 PL_reg_leftiter = 0;
8006 PL_reg_poscache = Nullch;
8007 PL_reg_poscache_size= 0;
8009 /* RE engine - function pointers */
8010 PL_regcompp = proto_perl->Tregcompp;
8011 PL_regexecp = proto_perl->Tregexecp;
8012 PL_regint_start = proto_perl->Tregint_start;
8013 PL_regint_string = proto_perl->Tregint_string;
8014 PL_regfree = proto_perl->Tregfree;
8016 PL_reginterp_cnt = 0;
8017 PL_reg_starttry = 0;
8020 return (PerlInterpreter*)pPerl;
8026 #else /* !USE_ITHREADS */
8032 #endif /* USE_ITHREADS */
8035 do_report_used(pTHXo_ SV *sv)
8037 if (SvTYPE(sv) != SVTYPEMASK) {
8038 PerlIO_printf(Perl_debug_log, "****\n");
8044 do_clean_objs(pTHXo_ SV *sv)
8048 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8049 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8055 /* XXX Might want to check arrays, etc. */
8058 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8060 do_clean_named_objs(pTHXo_ SV *sv)
8062 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8063 if ( SvOBJECT(GvSV(sv)) ||
8064 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8065 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8066 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8067 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8069 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8077 do_clean_all(pTHXo_ SV *sv)
8079 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8080 SvFLAGS(sv) |= SVf_BREAK;