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, '*', Nullch, 0);
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));
2779 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2780 SvPV_set(sstr, Nullch);
2785 else { /* have to copy actual string */
2786 STRLEN len = SvCUR(sstr);
2788 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2789 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2790 SvCUR_set(dstr, len);
2791 *SvEND(dstr) = '\0';
2792 (void)SvPOK_only(dstr);
2794 if ((sflags & SVf_UTF8) && !IN_BYTE)
2797 if (sflags & SVp_NOK) {
2799 SvNVX(dstr) = SvNVX(sstr);
2801 if (sflags & SVp_IOK) {
2802 (void)SvIOK_on(dstr);
2803 SvIVX(dstr) = SvIVX(sstr);
2804 if (sflags & SVf_IVisUV)
2808 else if (sflags & SVp_NOK) {
2809 SvNVX(dstr) = SvNVX(sstr);
2810 (void)SvNOK_only(dstr);
2811 if (sflags & SVf_IOK) {
2812 (void)SvIOK_on(dstr);
2813 SvIVX(dstr) = SvIVX(sstr);
2814 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2815 if (sflags & SVf_IVisUV)
2819 else if (sflags & SVp_IOK) {
2820 (void)SvIOK_only(dstr);
2821 SvIVX(dstr) = SvIVX(sstr);
2822 if (sflags & SVf_IVisUV)
2826 if (dtype == SVt_PVGV) {
2827 if (ckWARN(WARN_MISC))
2828 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2831 (void)SvOK_off(dstr);
2837 =for apidoc sv_setsv_mg
2839 Like C<sv_setsv>, but also handles 'set' magic.
2845 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2847 sv_setsv(dstr,sstr);
2852 =for apidoc sv_setpvn
2854 Copies a string into an SV. The C<len> parameter indicates the number of
2855 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2861 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2863 register char *dptr;
2864 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2865 elicit a warning, but it won't hurt. */
2866 SV_CHECK_THINKFIRST(sv);
2871 (void)SvUPGRADE(sv, SVt_PV);
2873 SvGROW(sv, len + 1);
2875 Move(ptr,dptr,len,char);
2878 (void)SvPOK_only(sv); /* validate pointer */
2883 =for apidoc sv_setpvn_mg
2885 Like C<sv_setpvn>, but also handles 'set' magic.
2891 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2893 sv_setpvn(sv,ptr,len);
2898 =for apidoc sv_setpv
2900 Copies a string into an SV. The string must be null-terminated. Does not
2901 handle 'set' magic. See C<sv_setpv_mg>.
2907 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2909 register STRLEN len;
2911 SV_CHECK_THINKFIRST(sv);
2917 (void)SvUPGRADE(sv, SVt_PV);
2919 SvGROW(sv, len + 1);
2920 Move(ptr,SvPVX(sv),len+1,char);
2922 (void)SvPOK_only(sv); /* validate pointer */
2927 =for apidoc sv_setpv_mg
2929 Like C<sv_setpv>, but also handles 'set' magic.
2935 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2942 =for apidoc sv_usepvn
2944 Tells an SV to use C<ptr> to find its string value. Normally the string is
2945 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2946 The C<ptr> should point to memory that was allocated by C<malloc>. The
2947 string length, C<len>, must be supplied. This function will realloc the
2948 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2949 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2950 See C<sv_usepvn_mg>.
2956 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2958 SV_CHECK_THINKFIRST(sv);
2959 (void)SvUPGRADE(sv, SVt_PV);
2964 (void)SvOOK_off(sv);
2965 if (SvPVX(sv) && SvLEN(sv))
2966 Safefree(SvPVX(sv));
2967 Renew(ptr, len+1, char);
2970 SvLEN_set(sv, len+1);
2972 (void)SvPOK_only(sv); /* validate pointer */
2977 =for apidoc sv_usepvn_mg
2979 Like C<sv_usepvn>, but also handles 'set' magic.
2985 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2987 sv_usepvn(sv,ptr,len);
2992 Perl_sv_force_normal(pTHX_ register SV *sv)
2994 if (SvREADONLY(sv)) {
2996 if (PL_curcop != &PL_compiling)
2997 Perl_croak(aTHX_ PL_no_modify);
3001 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3008 Efficient removal of characters from the beginning of the string buffer.
3009 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3010 the string buffer. The C<ptr> becomes the first character of the adjusted
3017 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3021 register STRLEN delta;
3023 if (!ptr || !SvPOKp(sv))
3025 SV_CHECK_THINKFIRST(sv);
3026 if (SvTYPE(sv) < SVt_PVIV)
3027 sv_upgrade(sv,SVt_PVIV);
3030 if (!SvLEN(sv)) { /* make copy of shared string */
3031 char *pvx = SvPVX(sv);
3032 STRLEN len = SvCUR(sv);
3033 SvGROW(sv, len + 1);
3034 Move(pvx,SvPVX(sv),len,char);
3038 SvFLAGS(sv) |= SVf_OOK;
3040 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3041 delta = ptr - SvPVX(sv);
3049 =for apidoc sv_catpvn
3051 Concatenates the string onto the end of the string which is in the SV. The
3052 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3053 'set' magic. See C<sv_catpvn_mg>.
3059 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3064 junk = SvPV_force(sv, tlen);
3065 SvGROW(sv, tlen + len + 1);
3068 Move(ptr,SvPVX(sv)+tlen,len,char);
3071 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3076 =for apidoc sv_catpvn_mg
3078 Like C<sv_catpvn>, but also handles 'set' magic.
3084 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3086 sv_catpvn(sv,ptr,len);
3091 =for apidoc sv_catsv
3093 Concatenates the string from SV C<ssv> onto the end of the string in SV
3094 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3100 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3106 if ((s = SvPV(sstr, len))) {
3107 if (DO_UTF8(sstr)) {
3108 sv_utf8_upgrade(dstr);
3109 sv_catpvn(dstr,s,len);
3113 sv_catpvn(dstr,s,len);
3118 =for apidoc sv_catsv_mg
3120 Like C<sv_catsv>, but also handles 'set' magic.
3126 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3128 sv_catsv(dstr,sstr);
3133 =for apidoc sv_catpv
3135 Concatenates the string onto the end of the string which is in the SV.
3136 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3142 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3144 register STRLEN len;
3150 junk = SvPV_force(sv, tlen);
3152 SvGROW(sv, tlen + len + 1);
3155 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3157 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3162 =for apidoc sv_catpv_mg
3164 Like C<sv_catpv>, but also handles 'set' magic.
3170 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3177 Perl_newSV(pTHX_ STRLEN len)
3183 sv_upgrade(sv, SVt_PV);
3184 SvGROW(sv, len + 1);
3189 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3192 =for apidoc sv_magic
3194 Adds magic to an SV.
3200 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3204 if (SvREADONLY(sv)) {
3206 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3207 Perl_croak(aTHX_ PL_no_modify);
3209 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3210 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3217 (void)SvUPGRADE(sv, SVt_PVMG);
3219 Newz(702,mg, 1, MAGIC);
3220 mg->mg_moremagic = SvMAGIC(sv);
3223 if (!obj || obj == sv || how == '#' || how == 'r')
3227 mg->mg_obj = SvREFCNT_inc(obj);
3228 mg->mg_flags |= MGf_REFCOUNTED;
3231 mg->mg_len = namlen;
3234 mg->mg_ptr = savepvn(name, namlen);
3235 else if (namlen == HEf_SVKEY)
3236 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3240 mg->mg_virtual = &PL_vtbl_sv;
3243 mg->mg_virtual = &PL_vtbl_amagic;
3246 mg->mg_virtual = &PL_vtbl_amagicelem;
3252 mg->mg_virtual = &PL_vtbl_bm;
3255 mg->mg_virtual = &PL_vtbl_regdata;
3258 mg->mg_virtual = &PL_vtbl_regdatum;
3261 mg->mg_virtual = &PL_vtbl_env;
3264 mg->mg_virtual = &PL_vtbl_fm;
3267 mg->mg_virtual = &PL_vtbl_envelem;
3270 mg->mg_virtual = &PL_vtbl_mglob;
3273 mg->mg_virtual = &PL_vtbl_isa;
3276 mg->mg_virtual = &PL_vtbl_isaelem;
3279 mg->mg_virtual = &PL_vtbl_nkeys;
3286 mg->mg_virtual = &PL_vtbl_dbline;
3290 mg->mg_virtual = &PL_vtbl_mutex;
3292 #endif /* USE_THREADS */
3293 #ifdef USE_LOCALE_COLLATE
3295 mg->mg_virtual = &PL_vtbl_collxfrm;
3297 #endif /* USE_LOCALE_COLLATE */
3299 mg->mg_virtual = &PL_vtbl_pack;
3303 mg->mg_virtual = &PL_vtbl_packelem;
3306 mg->mg_virtual = &PL_vtbl_regexp;
3309 mg->mg_virtual = &PL_vtbl_sig;
3312 mg->mg_virtual = &PL_vtbl_sigelem;
3315 mg->mg_virtual = &PL_vtbl_taint;
3319 mg->mg_virtual = &PL_vtbl_uvar;
3322 mg->mg_virtual = &PL_vtbl_vec;
3325 mg->mg_virtual = &PL_vtbl_substr;
3328 mg->mg_virtual = &PL_vtbl_defelem;
3331 mg->mg_virtual = &PL_vtbl_glob;
3334 mg->mg_virtual = &PL_vtbl_arylen;
3337 mg->mg_virtual = &PL_vtbl_pos;
3340 mg->mg_virtual = &PL_vtbl_backref;
3342 case '~': /* Reserved for use by extensions not perl internals. */
3343 /* Useful for attaching extension internal data to perl vars. */
3344 /* Note that multiple extensions may clash if magical scalars */
3345 /* etc holding private data from one are passed to another. */
3349 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3353 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3357 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3361 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3364 for (mg = *mgp; mg; mg = *mgp) {
3365 if (mg->mg_type == type) {
3366 MGVTBL* vtbl = mg->mg_virtual;
3367 *mgp = mg->mg_moremagic;
3368 if (vtbl && vtbl->svt_free)
3369 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3370 if (mg->mg_ptr && mg->mg_type != 'g')
3371 if (mg->mg_len >= 0)
3372 Safefree(mg->mg_ptr);
3373 else if (mg->mg_len == HEf_SVKEY)
3374 SvREFCNT_dec((SV*)mg->mg_ptr);
3375 if (mg->mg_flags & MGf_REFCOUNTED)
3376 SvREFCNT_dec(mg->mg_obj);
3380 mgp = &mg->mg_moremagic;
3384 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3391 Perl_sv_rvweaken(pTHX_ SV *sv)
3394 if (!SvOK(sv)) /* let undefs pass */
3397 Perl_croak(aTHX_ "Can't weaken a nonreference");
3398 else if (SvWEAKREF(sv)) {
3400 if (ckWARN(WARN_MISC))
3401 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3405 sv_add_backref(tsv, sv);
3412 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3416 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3417 av = (AV*)mg->mg_obj;
3420 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3421 SvREFCNT_dec(av); /* for sv_magic */
3427 S_sv_del_backref(pTHX_ SV *sv)
3434 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3435 Perl_croak(aTHX_ "panic: del_backref");
3436 av = (AV *)mg->mg_obj;
3441 svp[i] = &PL_sv_undef; /* XXX */
3448 =for apidoc sv_insert
3450 Inserts a string at the specified offset/length within the SV. Similar to
3451 the Perl substr() function.
3457 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3461 register char *midend;
3462 register char *bigend;
3468 Perl_croak(aTHX_ "Can't modify non-existent substring");
3469 SvPV_force(bigstr, curlen);
3470 (void)SvPOK_only_UTF8(bigstr);
3471 if (offset + len > curlen) {
3472 SvGROW(bigstr, offset+len+1);
3473 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3474 SvCUR_set(bigstr, offset+len);
3478 i = littlelen - len;
3479 if (i > 0) { /* string might grow */
3480 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3481 mid = big + offset + len;
3482 midend = bigend = big + SvCUR(bigstr);
3485 while (midend > mid) /* shove everything down */
3486 *--bigend = *--midend;
3487 Move(little,big+offset,littlelen,char);
3493 Move(little,SvPVX(bigstr)+offset,len,char);
3498 big = SvPVX(bigstr);
3501 bigend = big + SvCUR(bigstr);
3503 if (midend > bigend)
3504 Perl_croak(aTHX_ "panic: sv_insert");
3506 if (mid - big > bigend - midend) { /* faster to shorten from end */
3508 Move(little, mid, littlelen,char);
3511 i = bigend - midend;
3513 Move(midend, mid, i,char);
3517 SvCUR_set(bigstr, mid - big);
3520 else if ((i = mid - big)) { /* faster from front */
3521 midend -= littlelen;
3523 sv_chop(bigstr,midend-i);
3528 Move(little, mid, littlelen,char);
3530 else if (littlelen) {
3531 midend -= littlelen;
3532 sv_chop(bigstr,midend);
3533 Move(little,midend,littlelen,char);
3536 sv_chop(bigstr,midend);
3541 /* make sv point to what nstr did */
3544 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3547 U32 refcnt = SvREFCNT(sv);
3548 SV_CHECK_THINKFIRST(sv);
3549 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3550 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3551 if (SvMAGICAL(sv)) {
3555 sv_upgrade(nsv, SVt_PVMG);
3556 SvMAGIC(nsv) = SvMAGIC(sv);
3557 SvFLAGS(nsv) |= SvMAGICAL(sv);
3563 assert(!SvREFCNT(sv));
3564 StructCopy(nsv,sv,SV);
3565 SvREFCNT(sv) = refcnt;
3566 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3571 Perl_sv_clear(pTHX_ register SV *sv)
3575 assert(SvREFCNT(sv) == 0);
3579 if (PL_defstash) { /* Still have a symbol table? */
3584 Zero(&tmpref, 1, SV);
3585 sv_upgrade(&tmpref, SVt_RV);
3587 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3588 SvREFCNT(&tmpref) = 1;
3591 stash = SvSTASH(sv);
3592 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3595 PUSHSTACKi(PERLSI_DESTROY);
3596 SvRV(&tmpref) = SvREFCNT_inc(sv);
3601 call_sv((SV*)GvCV(destructor),
3602 G_DISCARD|G_EVAL|G_KEEPERR);
3608 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3610 del_XRV(SvANY(&tmpref));
3613 if (PL_in_clean_objs)
3614 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3616 /* DESTROY gave object new lease on life */
3622 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3623 SvOBJECT_off(sv); /* Curse the object. */
3624 if (SvTYPE(sv) != SVt_PVIO)
3625 --PL_sv_objcount; /* XXX Might want something more general */
3628 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3631 switch (SvTYPE(sv)) {
3634 IoIFP(sv) != PerlIO_stdin() &&
3635 IoIFP(sv) != PerlIO_stdout() &&
3636 IoIFP(sv) != PerlIO_stderr())
3638 io_close((IO*)sv, FALSE);
3640 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3641 PerlDir_close(IoDIRP(sv));
3642 IoDIRP(sv) = (DIR*)NULL;
3643 Safefree(IoTOP_NAME(sv));
3644 Safefree(IoFMT_NAME(sv));
3645 Safefree(IoBOTTOM_NAME(sv));
3660 SvREFCNT_dec(LvTARG(sv));
3664 Safefree(GvNAME(sv));
3665 /* cannot decrease stash refcount yet, as we might recursively delete
3666 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3667 of stash until current sv is completely gone.
3668 -- JohnPC, 27 Mar 1998 */
3669 stash = GvSTASH(sv);
3675 (void)SvOOK_off(sv);
3683 SvREFCNT_dec(SvRV(sv));
3685 else if (SvPVX(sv) && SvLEN(sv))
3686 Safefree(SvPVX(sv));
3696 switch (SvTYPE(sv)) {
3712 del_XPVIV(SvANY(sv));
3715 del_XPVNV(SvANY(sv));
3718 del_XPVMG(SvANY(sv));
3721 del_XPVLV(SvANY(sv));
3724 del_XPVAV(SvANY(sv));
3727 del_XPVHV(SvANY(sv));
3730 del_XPVCV(SvANY(sv));
3733 del_XPVGV(SvANY(sv));
3734 /* code duplication for increased performance. */
3735 SvFLAGS(sv) &= SVf_BREAK;
3736 SvFLAGS(sv) |= SVTYPEMASK;
3737 /* decrease refcount of the stash that owns this GV, if any */
3739 SvREFCNT_dec(stash);
3740 return; /* not break, SvFLAGS reset already happened */
3742 del_XPVBM(SvANY(sv));
3745 del_XPVFM(SvANY(sv));
3748 del_XPVIO(SvANY(sv));
3751 SvFLAGS(sv) &= SVf_BREAK;
3752 SvFLAGS(sv) |= SVTYPEMASK;
3756 Perl_sv_newref(pTHX_ SV *sv)
3759 ATOMIC_INC(SvREFCNT(sv));
3764 Perl_sv_free(pTHX_ SV *sv)
3767 int refcount_is_zero;
3771 if (SvREFCNT(sv) == 0) {
3772 if (SvFLAGS(sv) & SVf_BREAK)
3774 if (PL_in_clean_all) /* All is fair */
3776 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3777 /* make sure SvREFCNT(sv)==0 happens very seldom */
3778 SvREFCNT(sv) = (~(U32)0)/2;
3781 if (ckWARN_d(WARN_INTERNAL))
3782 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3785 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3786 if (!refcount_is_zero)
3790 if (ckWARN_d(WARN_DEBUGGING))
3791 Perl_warner(aTHX_ WARN_DEBUGGING,
3792 "Attempt to free temp prematurely: SV 0x%"UVxf,
3797 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3798 /* make sure SvREFCNT(sv)==0 happens very seldom */
3799 SvREFCNT(sv) = (~(U32)0)/2;
3810 Returns the length of the string in the SV. See also C<SvCUR>.
3816 Perl_sv_len(pTHX_ register SV *sv)
3825 len = mg_length(sv);
3827 junk = SvPV(sv, len);
3832 Perl_sv_len_utf8(pTHX_ register SV *sv)
3843 len = mg_length(sv);
3846 s = (U8*)SvPV(sv, len);
3857 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3862 I32 uoffset = *offsetp;
3868 start = s = (U8*)SvPV(sv, len);
3870 while (s < send && uoffset--)
3874 *offsetp = s - start;
3878 while (s < send && ulen--)
3888 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3897 s = (U8*)SvPV(sv, len);
3899 Perl_croak(aTHX_ "panic: bad byte offset");
3900 send = s + *offsetp;
3908 if (ckWARN_d(WARN_UTF8))
3909 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3919 Returns a boolean indicating whether the strings in the two SVs are
3926 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3938 pv1 = SvPV(str1, cur1);
3943 if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3945 sv_utf8_upgrade(str2);
3948 sv_utf8_upgrade(str1);
3952 pv2 = SvPV(str2, cur2);
3957 return memEQ(pv1, pv2, cur1);
3963 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3964 string in C<sv1> is less than, equal to, or greater than the string in
3971 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3978 pv1 = SvPV(str1, cur1);
3986 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3987 /* must upgrade other to UTF8 first */
3989 sv_utf8_upgrade(str2);
3992 sv_utf8_upgrade(str1);
3993 /* refresh pointer and length */
4002 pv2 = sv_2pv(str2, &cur2);
4010 return cur2 ? -1 : 0;
4015 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4018 return retval < 0 ? -1 : 1;
4023 return cur1 < cur2 ? -1 : 1;
4027 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4029 #ifdef USE_LOCALE_COLLATE
4035 if (PL_collation_standard)
4039 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4041 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4043 if (!pv1 || !len1) {
4054 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4057 return retval < 0 ? -1 : 1;
4060 * When the result of collation is equality, that doesn't mean
4061 * that there are no differences -- some locales exclude some
4062 * characters from consideration. So to avoid false equalities,
4063 * we use the raw string as a tiebreaker.
4069 #endif /* USE_LOCALE_COLLATE */
4071 return sv_cmp(sv1, sv2);
4074 #ifdef USE_LOCALE_COLLATE
4076 * Any scalar variable may carry an 'o' magic that contains the
4077 * scalar data of the variable transformed to such a format that
4078 * a normal memory comparison can be used to compare the data
4079 * according to the locale settings.
4082 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4086 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4087 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4092 Safefree(mg->mg_ptr);
4094 if ((xf = mem_collxfrm(s, len, &xlen))) {
4095 if (SvREADONLY(sv)) {
4098 return xf + sizeof(PL_collation_ix);
4101 sv_magic(sv, 0, 'o', 0, 0);
4102 mg = mg_find(sv, 'o');
4115 if (mg && mg->mg_ptr) {
4117 return mg->mg_ptr + sizeof(PL_collation_ix);
4125 #endif /* USE_LOCALE_COLLATE */
4128 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4133 register STDCHAR rslast;
4134 register STDCHAR *bp;
4138 SV_CHECK_THINKFIRST(sv);
4139 (void)SvUPGRADE(sv, SVt_PV);
4143 if (RsSNARF(PL_rs)) {
4147 else if (RsRECORD(PL_rs)) {
4148 I32 recsize, bytesread;
4151 /* Grab the size of the record we're getting */
4152 recsize = SvIV(SvRV(PL_rs));
4153 (void)SvPOK_only(sv); /* Validate pointer */
4154 buffer = SvGROW(sv, recsize + 1);
4157 /* VMS wants read instead of fread, because fread doesn't respect */
4158 /* RMS record boundaries. This is not necessarily a good thing to be */
4159 /* doing, but we've got no other real choice */
4160 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4162 bytesread = PerlIO_read(fp, buffer, recsize);
4164 SvCUR_set(sv, bytesread);
4165 buffer[bytesread] = '\0';
4166 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4168 else if (RsPARA(PL_rs)) {
4173 rsptr = SvPV(PL_rs, rslen);
4174 rslast = rslen ? rsptr[rslen - 1] : '\0';
4176 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4177 do { /* to make sure file boundaries work right */
4180 i = PerlIO_getc(fp);
4184 PerlIO_ungetc(fp,i);
4190 /* See if we know enough about I/O mechanism to cheat it ! */
4192 /* This used to be #ifdef test - it is made run-time test for ease
4193 of abstracting out stdio interface. One call should be cheap
4194 enough here - and may even be a macro allowing compile
4198 if (PerlIO_fast_gets(fp)) {
4201 * We're going to steal some values from the stdio struct
4202 * and put EVERYTHING in the innermost loop into registers.
4204 register STDCHAR *ptr;
4208 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4209 /* An ungetc()d char is handled separately from the regular
4210 * buffer, so we getc() it back out and stuff it in the buffer.
4212 i = PerlIO_getc(fp);
4213 if (i == EOF) return 0;
4214 *(--((*fp)->_ptr)) = (unsigned char) i;
4218 /* Here is some breathtakingly efficient cheating */
4220 cnt = PerlIO_get_cnt(fp); /* get count into register */
4221 (void)SvPOK_only(sv); /* validate pointer */
4222 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4223 if (cnt > 80 && SvLEN(sv) > append) {
4224 shortbuffered = cnt - SvLEN(sv) + append + 1;
4225 cnt -= shortbuffered;
4229 /* remember that cnt can be negative */
4230 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4235 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4236 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4237 DEBUG_P(PerlIO_printf(Perl_debug_log,
4238 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4239 DEBUG_P(PerlIO_printf(Perl_debug_log,
4240 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4241 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4242 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4247 while (cnt > 0) { /* this | eat */
4249 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4250 goto thats_all_folks; /* screams | sed :-) */
4254 Copy(ptr, bp, cnt, char); /* this | eat */
4255 bp += cnt; /* screams | dust */
4256 ptr += cnt; /* louder | sed :-) */
4261 if (shortbuffered) { /* oh well, must extend */
4262 cnt = shortbuffered;
4264 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4266 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4267 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4271 DEBUG_P(PerlIO_printf(Perl_debug_log,
4272 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4273 PTR2UV(ptr),(long)cnt));
4274 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4275 DEBUG_P(PerlIO_printf(Perl_debug_log,
4276 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4277 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4278 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4279 /* This used to call 'filbuf' in stdio form, but as that behaves like
4280 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4281 another abstraction. */
4282 i = PerlIO_getc(fp); /* get more characters */
4283 DEBUG_P(PerlIO_printf(Perl_debug_log,
4284 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4285 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4286 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4287 cnt = PerlIO_get_cnt(fp);
4288 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4289 DEBUG_P(PerlIO_printf(Perl_debug_log,
4290 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4292 if (i == EOF) /* all done for ever? */
4293 goto thats_really_all_folks;
4295 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4297 SvGROW(sv, bpx + cnt + 2);
4298 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4300 *bp++ = i; /* store character from PerlIO_getc */
4302 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4303 goto thats_all_folks;
4307 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4308 memNE((char*)bp - rslen, rsptr, rslen))
4309 goto screamer; /* go back to the fray */
4310 thats_really_all_folks:
4312 cnt += shortbuffered;
4313 DEBUG_P(PerlIO_printf(Perl_debug_log,
4314 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4315 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4316 DEBUG_P(PerlIO_printf(Perl_debug_log,
4317 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4318 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4319 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4321 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4322 DEBUG_P(PerlIO_printf(Perl_debug_log,
4323 "Screamer: done, len=%ld, string=|%.*s|\n",
4324 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4329 /*The big, slow, and stupid way */
4332 /* Need to work around EPOC SDK features */
4333 /* On WINS: MS VC5 generates calls to _chkstk, */
4334 /* if a `large' stack frame is allocated */
4335 /* gcc on MARM does not generate calls like these */
4341 register STDCHAR *bpe = buf + sizeof(buf);
4343 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4344 ; /* keep reading */
4348 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4349 /* Accomodate broken VAXC compiler, which applies U8 cast to
4350 * both args of ?: operator, causing EOF to change into 255
4352 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4356 sv_catpvn(sv, (char *) buf, cnt);
4358 sv_setpvn(sv, (char *) buf, cnt);
4360 if (i != EOF && /* joy */
4362 SvCUR(sv) < rslen ||
4363 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4367 * If we're reading from a TTY and we get a short read,
4368 * indicating that the user hit his EOF character, we need
4369 * to notice it now, because if we try to read from the TTY
4370 * again, the EOF condition will disappear.
4372 * The comparison of cnt to sizeof(buf) is an optimization
4373 * that prevents unnecessary calls to feof().
4377 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4382 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4383 while (i != EOF) { /* to make sure file boundaries work right */
4384 i = PerlIO_getc(fp);
4386 PerlIO_ungetc(fp,i);
4392 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4399 Auto-increment of the value in the SV.
4405 Perl_sv_inc(pTHX_ register SV *sv)
4414 if (SvTHINKFIRST(sv)) {
4415 if (SvREADONLY(sv)) {
4417 if (PL_curcop != &PL_compiling)
4418 Perl_croak(aTHX_ PL_no_modify);
4422 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4424 i = PTR2IV(SvRV(sv));
4429 flags = SvFLAGS(sv);
4430 if (flags & SVp_NOK) {
4431 (void)SvNOK_only(sv);
4435 if (flags & SVp_IOK) {
4437 if (SvUVX(sv) == UV_MAX)
4438 sv_setnv(sv, (NV)UV_MAX + 1.0);
4440 (void)SvIOK_only_UV(sv);
4443 if (SvIVX(sv) == IV_MAX)
4444 sv_setnv(sv, (NV)IV_MAX + 1.0);
4446 (void)SvIOK_only(sv);
4452 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4453 if ((flags & SVTYPEMASK) < SVt_PVNV)
4454 sv_upgrade(sv, SVt_NV);
4456 (void)SvNOK_only(sv);
4460 while (isALPHA(*d)) d++;
4461 while (isDIGIT(*d)) d++;
4463 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4467 while (d >= SvPVX(sv)) {
4475 /* MKS: The original code here died if letters weren't consecutive.
4476 * at least it didn't have to worry about non-C locales. The
4477 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4478 * arranged in order (although not consecutively) and that only
4479 * [A-Za-z] are accepted by isALPHA in the C locale.
4481 if (*d != 'z' && *d != 'Z') {
4482 do { ++*d; } while (!isALPHA(*d));
4485 *(d--) -= 'z' - 'a';
4490 *(d--) -= 'z' - 'a' + 1;
4494 /* oh,oh, the number grew */
4495 SvGROW(sv, SvCUR(sv) + 2);
4497 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4508 Auto-decrement of the value in the SV.
4514 Perl_sv_dec(pTHX_ register SV *sv)
4522 if (SvTHINKFIRST(sv)) {
4523 if (SvREADONLY(sv)) {
4525 if (PL_curcop != &PL_compiling)
4526 Perl_croak(aTHX_ PL_no_modify);
4530 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4532 i = PTR2IV(SvRV(sv));
4537 flags = SvFLAGS(sv);
4538 if (flags & SVp_NOK) {
4540 (void)SvNOK_only(sv);
4543 if (flags & SVp_IOK) {
4545 if (SvUVX(sv) == 0) {
4546 (void)SvIOK_only(sv);
4550 (void)SvIOK_only_UV(sv);
4554 if (SvIVX(sv) == IV_MIN)
4555 sv_setnv(sv, (NV)IV_MIN - 1.0);
4557 (void)SvIOK_only(sv);
4563 if (!(flags & SVp_POK)) {
4564 if ((flags & SVTYPEMASK) < SVt_PVNV)
4565 sv_upgrade(sv, SVt_NV);
4567 (void)SvNOK_only(sv);
4570 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4574 =for apidoc sv_mortalcopy
4576 Creates a new SV which is a copy of the original SV. The new SV is marked
4582 /* Make a string that will exist for the duration of the expression
4583 * evaluation. Actually, it may have to last longer than that, but
4584 * hopefully we won't free it until it has been assigned to a
4585 * permanent location. */
4588 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4594 sv_setsv(sv,oldstr);
4596 PL_tmps_stack[++PL_tmps_ix] = sv;
4602 =for apidoc sv_newmortal
4604 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4610 Perl_sv_newmortal(pTHX)
4616 SvFLAGS(sv) = SVs_TEMP;
4618 PL_tmps_stack[++PL_tmps_ix] = sv;
4623 =for apidoc sv_2mortal
4625 Marks an SV as mortal. The SV will be destroyed when the current context
4631 /* same thing without the copying */
4634 Perl_sv_2mortal(pTHX_ register SV *sv)
4639 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4642 PL_tmps_stack[++PL_tmps_ix] = sv;
4650 Creates a new SV and copies a string into it. The reference count for the
4651 SV is set to 1. If C<len> is zero, Perl will compute the length using
4652 strlen(). For efficiency, consider using C<newSVpvn> instead.
4658 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4665 sv_setpvn(sv,s,len);
4670 =for apidoc newSVpvn
4672 Creates a new SV and copies a string into it. The reference count for the
4673 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4674 string. You are responsible for ensuring that the source string is at least
4681 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4686 sv_setpvn(sv,s,len);
4690 #if defined(PERL_IMPLICIT_CONTEXT)
4692 Perl_newSVpvf_nocontext(const char* pat, ...)
4697 va_start(args, pat);
4698 sv = vnewSVpvf(pat, &args);
4705 =for apidoc newSVpvf
4707 Creates a new SV an initialize it with the string formatted like
4714 Perl_newSVpvf(pTHX_ const char* pat, ...)
4718 va_start(args, pat);
4719 sv = vnewSVpvf(pat, &args);
4725 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4729 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4736 Creates a new SV and copies a floating point value into it.
4737 The reference count for the SV is set to 1.
4743 Perl_newSVnv(pTHX_ NV n)
4755 Creates a new SV and copies an integer into it. The reference count for the
4762 Perl_newSViv(pTHX_ IV i)
4774 Creates a new SV and copies an unsigned integer into it.
4775 The reference count for the SV is set to 1.
4781 Perl_newSVuv(pTHX_ UV u)
4791 =for apidoc newRV_noinc
4793 Creates an RV wrapper for an SV. The reference count for the original
4794 SV is B<not> incremented.
4800 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4806 sv_upgrade(sv, SVt_RV);
4813 /* newRV_inc is #defined to newRV in sv.h */
4815 Perl_newRV(pTHX_ SV *tmpRef)
4817 return newRV_noinc(SvREFCNT_inc(tmpRef));
4823 Creates a new SV which is an exact duplicate of the original SV.
4828 /* make an exact duplicate of old */
4831 Perl_newSVsv(pTHX_ register SV *old)
4838 if (SvTYPE(old) == SVTYPEMASK) {
4839 if (ckWARN_d(WARN_INTERNAL))
4840 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4855 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4863 char todo[PERL_UCHAR_MAX+1];
4868 if (!*s) { /* reset ?? searches */
4869 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4870 pm->op_pmdynflags &= ~PMdf_USED;
4875 /* reset variables */
4877 if (!HvARRAY(stash))
4880 Zero(todo, 256, char);
4882 i = (unsigned char)*s;
4886 max = (unsigned char)*s++;
4887 for ( ; i <= max; i++) {
4890 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4891 for (entry = HvARRAY(stash)[i];
4893 entry = HeNEXT(entry))
4895 if (!todo[(U8)*HeKEY(entry)])
4897 gv = (GV*)HeVAL(entry);
4899 if (SvTHINKFIRST(sv)) {
4900 if (!SvREADONLY(sv) && SvROK(sv))
4905 if (SvTYPE(sv) >= SVt_PV) {
4907 if (SvPVX(sv) != Nullch)
4914 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4916 #ifndef VMS /* VMS has no environ array */
4918 environ[0] = Nullch;
4927 Perl_sv_2io(pTHX_ SV *sv)
4933 switch (SvTYPE(sv)) {
4941 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4945 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4947 return sv_2io(SvRV(sv));
4948 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4954 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4961 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4968 return *gvp = Nullgv, Nullcv;
4969 switch (SvTYPE(sv)) {
4989 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4990 tryAMAGICunDEREF(to_cv);
4993 if (SvTYPE(sv) == SVt_PVCV) {
5002 Perl_croak(aTHX_ "Not a subroutine reference");
5007 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5013 if (lref && !GvCVu(gv)) {
5016 tmpsv = NEWSV(704,0);
5017 gv_efullname3(tmpsv, gv, Nullch);
5018 /* XXX this is probably not what they think they're getting.
5019 * It has the same effect as "sub name;", i.e. just a forward
5021 newSUB(start_subparse(FALSE, 0),
5022 newSVOP(OP_CONST, 0, tmpsv),
5027 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5034 Perl_sv_true(pTHX_ register SV *sv)
5041 if ((tXpv = (XPV*)SvANY(sv)) &&
5042 (tXpv->xpv_cur > 1 ||
5043 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5050 return SvIVX(sv) != 0;
5053 return SvNVX(sv) != 0.0;
5055 return sv_2bool(sv);
5061 Perl_sv_iv(pTHX_ register SV *sv)
5065 return (IV)SvUVX(sv);
5072 Perl_sv_uv(pTHX_ register SV *sv)
5077 return (UV)SvIVX(sv);
5083 Perl_sv_nv(pTHX_ register SV *sv)
5091 Perl_sv_pv(pTHX_ SV *sv)
5098 return sv_2pv(sv, &n_a);
5102 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5108 return sv_2pv(sv, lp);
5112 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5116 if (SvTHINKFIRST(sv) && !SvROK(sv))
5117 sv_force_normal(sv);
5123 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5125 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5126 PL_op_name[PL_op->op_type]);
5130 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5135 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5136 SvGROW(sv, len + 1);
5137 Move(s,SvPVX(sv),len,char);
5142 SvPOK_on(sv); /* validate pointer */
5144 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5145 PTR2UV(sv),SvPVX(sv)));
5152 Perl_sv_pvbyte(pTHX_ SV *sv)
5158 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5160 return sv_pvn(sv,lp);
5164 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5166 return sv_pvn_force(sv,lp);
5170 Perl_sv_pvutf8(pTHX_ SV *sv)
5172 sv_utf8_upgrade(sv);
5177 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5179 sv_utf8_upgrade(sv);
5180 return sv_pvn(sv,lp);
5184 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5186 sv_utf8_upgrade(sv);
5187 return sv_pvn_force(sv,lp);
5191 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5193 if (ob && SvOBJECT(sv))
5194 return HvNAME(SvSTASH(sv));
5196 switch (SvTYPE(sv)) {
5210 case SVt_PVLV: return "LVALUE";
5211 case SVt_PVAV: return "ARRAY";
5212 case SVt_PVHV: return "HASH";
5213 case SVt_PVCV: return "CODE";
5214 case SVt_PVGV: return "GLOB";
5215 case SVt_PVFM: return "FORMAT";
5216 case SVt_PVIO: return "IO";
5217 default: return "UNKNOWN";
5223 =for apidoc sv_isobject
5225 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5226 object. If the SV is not an RV, or if the object is not blessed, then this
5233 Perl_sv_isobject(pTHX_ SV *sv)
5250 Returns a boolean indicating whether the SV is blessed into the specified
5251 class. This does not check for subtypes; use C<sv_derived_from> to verify
5252 an inheritance relationship.
5258 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5270 return strEQ(HvNAME(SvSTASH(sv)), name);
5276 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5277 it will be upgraded to one. If C<classname> is non-null then the new SV will
5278 be blessed in the specified package. The new SV is returned and its
5279 reference count is 1.
5285 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5292 SV_CHECK_THINKFIRST(rv);
5295 if (SvTYPE(rv) < SVt_RV)
5296 sv_upgrade(rv, SVt_RV);
5303 HV* stash = gv_stashpv(classname, TRUE);
5304 (void)sv_bless(rv, stash);
5310 =for apidoc sv_setref_pv
5312 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5313 argument will be upgraded to an RV. That RV will be modified to point to
5314 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5315 into the SV. The C<classname> argument indicates the package for the
5316 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5317 will be returned and will have a reference count of 1.
5319 Do not use with other Perl types such as HV, AV, SV, CV, because those
5320 objects will become corrupted by the pointer copy process.
5322 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5328 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5331 sv_setsv(rv, &PL_sv_undef);
5335 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5340 =for apidoc sv_setref_iv
5342 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5343 argument will be upgraded to an RV. That RV will be modified to point to
5344 the new SV. The C<classname> argument indicates the package for the
5345 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5346 will be returned and will have a reference count of 1.
5352 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5354 sv_setiv(newSVrv(rv,classname), iv);
5359 =for apidoc sv_setref_nv
5361 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5362 argument will be upgraded to an RV. That RV will be modified to point to
5363 the new SV. The C<classname> argument indicates the package for the
5364 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5365 will be returned and will have a reference count of 1.
5371 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5373 sv_setnv(newSVrv(rv,classname), nv);
5378 =for apidoc sv_setref_pvn
5380 Copies a string into a new SV, optionally blessing the SV. The length of the
5381 string must be specified with C<n>. The C<rv> argument will be upgraded to
5382 an RV. That RV will be modified to point to the new SV. The C<classname>
5383 argument indicates the package for the blessing. Set C<classname> to
5384 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5385 a reference count of 1.
5387 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5393 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5395 sv_setpvn(newSVrv(rv,classname), pv, n);
5400 =for apidoc sv_bless
5402 Blesses an SV into a specified package. The SV must be an RV. The package
5403 must be designated by its stash (see C<gv_stashpv()>). The reference count
5404 of the SV is unaffected.
5410 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5415 Perl_croak(aTHX_ "Can't bless non-reference value");
5417 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5418 if (SvREADONLY(tmpRef))
5419 Perl_croak(aTHX_ PL_no_modify);
5420 if (SvOBJECT(tmpRef)) {
5421 if (SvTYPE(tmpRef) != SVt_PVIO)
5423 SvREFCNT_dec(SvSTASH(tmpRef));
5426 SvOBJECT_on(tmpRef);
5427 if (SvTYPE(tmpRef) != SVt_PVIO)
5429 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5430 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5441 S_sv_unglob(pTHX_ SV *sv)
5445 assert(SvTYPE(sv) == SVt_PVGV);
5450 SvREFCNT_dec(GvSTASH(sv));
5451 GvSTASH(sv) = Nullhv;
5453 sv_unmagic(sv, '*');
5454 Safefree(GvNAME(sv));
5457 /* need to keep SvANY(sv) in the right arena */
5458 xpvmg = new_XPVMG();
5459 StructCopy(SvANY(sv), xpvmg, XPVMG);
5460 del_XPVGV(SvANY(sv));
5463 SvFLAGS(sv) &= ~SVTYPEMASK;
5464 SvFLAGS(sv) |= SVt_PVMG;
5468 =for apidoc sv_unref
5470 Unsets the RV status of the SV, and decrements the reference count of
5471 whatever was being referenced by the RV. This can almost be thought of
5472 as a reversal of C<newSVrv>. See C<SvROK_off>.
5478 Perl_sv_unref(pTHX_ SV *sv)
5482 if (SvWEAKREF(sv)) {
5490 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5493 sv_2mortal(rv); /* Schedule for freeing later */
5497 Perl_sv_taint(pTHX_ SV *sv)
5499 sv_magic((sv), Nullsv, 't', Nullch, 0);
5503 Perl_sv_untaint(pTHX_ SV *sv)
5505 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5506 MAGIC *mg = mg_find(sv, 't');
5513 Perl_sv_tainted(pTHX_ SV *sv)
5515 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5516 MAGIC *mg = mg_find(sv, 't');
5517 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5524 =for apidoc sv_setpviv
5526 Copies an integer into the given SV, also updating its string value.
5527 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5533 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5535 char buf[TYPE_CHARS(UV)];
5537 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5539 sv_setpvn(sv, ptr, ebuf - ptr);
5544 =for apidoc sv_setpviv_mg
5546 Like C<sv_setpviv>, but also handles 'set' magic.
5552 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5554 char buf[TYPE_CHARS(UV)];
5556 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5558 sv_setpvn(sv, ptr, ebuf - ptr);
5562 #if defined(PERL_IMPLICIT_CONTEXT)
5564 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5568 va_start(args, pat);
5569 sv_vsetpvf(sv, pat, &args);
5575 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5579 va_start(args, pat);
5580 sv_vsetpvf_mg(sv, pat, &args);
5586 =for apidoc sv_setpvf
5588 Processes its arguments like C<sprintf> and sets an SV to the formatted
5589 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5595 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5598 va_start(args, pat);
5599 sv_vsetpvf(sv, pat, &args);
5604 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5606 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5610 =for apidoc sv_setpvf_mg
5612 Like C<sv_setpvf>, but also handles 'set' magic.
5618 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5621 va_start(args, pat);
5622 sv_vsetpvf_mg(sv, pat, &args);
5627 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5629 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5633 #if defined(PERL_IMPLICIT_CONTEXT)
5635 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5639 va_start(args, pat);
5640 sv_vcatpvf(sv, pat, &args);
5645 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5649 va_start(args, pat);
5650 sv_vcatpvf_mg(sv, pat, &args);
5656 =for apidoc sv_catpvf
5658 Processes its arguments like C<sprintf> and appends the formatted output
5659 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5660 typically be called after calling this function to handle 'set' magic.
5666 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5669 va_start(args, pat);
5670 sv_vcatpvf(sv, pat, &args);
5675 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5677 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5681 =for apidoc sv_catpvf_mg
5683 Like C<sv_catpvf>, but also handles 'set' magic.
5689 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5692 va_start(args, pat);
5693 sv_vcatpvf_mg(sv, pat, &args);
5698 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5700 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5705 =for apidoc sv_vsetpvfn
5707 Works like C<vcatpvfn> but copies the text into the SV instead of
5714 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5716 sv_setpvn(sv, "", 0);
5717 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5721 =for apidoc sv_vcatpvfn
5723 Processes its arguments like C<vsprintf> and appends the formatted output
5724 to an SV. Uses an array of SVs if the C style variable argument list is
5725 missing (NULL). When running with taint checks enabled, indicates via
5726 C<maybe_tainted> if results are untrustworthy (often due to the use of
5733 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5741 static char nullstr[] = "(null)";
5744 /* no matter what, this is a string now */
5745 (void)SvPV_force(sv, origlen);
5747 /* special-case "", "%s", and "%_" */
5750 if (patlen == 2 && pat[0] == '%') {
5754 char *s = va_arg(*args, char*);
5755 sv_catpv(sv, s ? s : nullstr);
5757 else if (svix < svmax) {
5758 sv_catsv(sv, *svargs);
5759 if (DO_UTF8(*svargs))
5765 argsv = va_arg(*args, SV*);
5766 sv_catsv(sv, argsv);
5771 /* See comment on '_' below */
5776 patend = (char*)pat + patlen;
5777 for (p = (char*)pat; p < patend; p = q) {
5780 bool vectorize = FALSE;
5787 bool has_precis = FALSE;
5789 bool is_utf = FALSE;
5792 U8 utf8buf[UTF8_MAXLEN];
5793 STRLEN esignlen = 0;
5795 char *eptr = Nullch;
5797 /* Times 4: a decimal digit takes more than 3 binary digits.
5798 * NV_DIG: mantissa takes than many decimal digits.
5799 * Plus 32: Playing safe. */
5800 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5801 /* large enough for "%#.#f" --chip */
5802 /* what about long double NVs? --jhi */
5805 U8 *vecstr = Null(U8*);
5817 STRLEN dotstrlen = 1;
5819 for (q = p; q < patend && *q != '%'; ++q) ;
5821 sv_catpvn(sv, p, q - p);
5850 case '*': /* printf("%*vX",":",$ipv6addr) */
5855 vecsv = va_arg(*args, SV*);
5856 else if (svix < svmax)
5857 vecsv = svargs[svix++];
5860 dotstr = SvPVx(vecsv,dotstrlen);
5869 vecsv = va_arg(*args, SV*);
5870 else if (svix < svmax)
5871 vecsv = svargs[svix++];
5877 vecstr = (U8*)SvPVx(vecsv,veclen);
5878 utf = DO_UTF8(vecsv);
5890 case '1': case '2': case '3':
5891 case '4': case '5': case '6':
5892 case '7': case '8': case '9':
5895 width = width * 10 + (*q++ - '0');
5900 i = va_arg(*args, int);
5902 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5904 width = (i < 0) ? -i : i;
5915 i = va_arg(*args, int);
5917 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5918 precis = (i < 0) ? 0 : i;
5924 precis = precis * 10 + (*q++ - '0');
5941 if (*(q + 1) == 'l') { /* lld */
5968 uv = va_arg(*args, int);
5970 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5971 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5972 eptr = (char*)utf8buf;
5973 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5985 eptr = va_arg(*args, char*);
5987 #ifdef MACOS_TRADITIONAL
5988 /* On MacOS, %#s format is used for Pascal strings */
5993 elen = strlen(eptr);
5996 elen = sizeof nullstr - 1;
5999 else if (svix < svmax) {
6000 argsv = svargs[svix++];
6001 eptr = SvPVx(argsv, elen);
6002 if (DO_UTF8(argsv)) {
6003 if (has_precis && precis < elen) {
6005 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6008 if (width) { /* fudge width (can't fudge elen) */
6009 width += elen - sv_len_utf8(argsv);
6018 * The "%_" hack might have to be changed someday,
6019 * if ISO or ANSI decide to use '_' for something.
6020 * So we keep it hidden from users' code.
6024 argsv = va_arg(*args,SV*);
6025 eptr = SvPVx(argsv, elen);
6031 if (has_precis && elen > precis)
6039 uv = PTR2UV(va_arg(*args, void*));
6041 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6061 iv = (IV)utf8_to_uv(vecstr, &ulen);
6071 case 'h': iv = (short)va_arg(*args, int); break;
6072 default: iv = va_arg(*args, int); break;
6073 case 'l': iv = va_arg(*args, long); break;
6074 case 'V': iv = va_arg(*args, IV); break;
6076 case 'q': iv = va_arg(*args, Quad_t); break;
6081 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6083 case 'h': iv = (short)iv; break;
6085 case 'l': iv = (long)iv; break;
6088 case 'q': iv = (Quad_t)iv; break;
6095 esignbuf[esignlen++] = plus;
6099 esignbuf[esignlen++] = '-';
6143 uv = utf8_to_uv(vecstr, &ulen);
6153 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6154 default: uv = va_arg(*args, unsigned); break;
6155 case 'l': uv = va_arg(*args, unsigned long); break;
6156 case 'V': uv = va_arg(*args, UV); break;
6158 case 'q': uv = va_arg(*args, Quad_t); break;
6163 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6165 case 'h': uv = (unsigned short)uv; break;
6167 case 'l': uv = (unsigned long)uv; break;
6170 case 'q': uv = (Quad_t)uv; break;
6176 eptr = ebuf + sizeof ebuf;
6182 p = (char*)((c == 'X')
6183 ? "0123456789ABCDEF" : "0123456789abcdef");
6189 esignbuf[esignlen++] = '0';
6190 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6196 *--eptr = '0' + dig;
6198 if (alt && *eptr != '0')
6204 *--eptr = '0' + dig;
6207 esignbuf[esignlen++] = '0';
6208 esignbuf[esignlen++] = 'b';
6211 default: /* it had better be ten or less */
6212 #if defined(PERL_Y2KWARN)
6213 if (ckWARN(WARN_Y2K)) {
6215 char *s = SvPV(sv,n);
6216 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6217 && (n == 2 || !isDIGIT(s[n-3])))
6219 Perl_warner(aTHX_ WARN_Y2K,
6220 "Possible Y2K bug: %%%c %s",
6221 c, "format string following '19'");
6227 *--eptr = '0' + dig;
6228 } while (uv /= base);
6231 elen = (ebuf + sizeof ebuf) - eptr;
6234 zeros = precis - elen;
6235 else if (precis == 0 && elen == 1 && *eptr == '0')
6240 /* FLOATING POINT */
6243 c = 'f'; /* maybe %F isn't supported here */
6249 /* This is evil, but floating point is even more evil */
6253 nv = va_arg(*args, NV);
6255 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6258 if (c != 'e' && c != 'E') {
6260 (void)Perl_frexp(nv, &i);
6261 if (i == PERL_INT_MIN)
6262 Perl_die(aTHX_ "panic: frexp");
6264 need = BIT_DIGITS(i);
6266 need += has_precis ? precis : 6; /* known default */
6270 need += 20; /* fudge factor */
6271 if (PL_efloatsize < need) {
6272 Safefree(PL_efloatbuf);
6273 PL_efloatsize = need + 20; /* more fudge */
6274 New(906, PL_efloatbuf, PL_efloatsize, char);
6275 PL_efloatbuf[0] = '\0';
6278 eptr = ebuf + sizeof ebuf;
6281 #ifdef USE_LONG_DOUBLE
6283 static char const my_prifldbl[] = PERL_PRIfldbl;
6284 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6285 while (p >= my_prifldbl) { *--eptr = *p--; }
6290 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6295 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6308 RESTORE_NUMERIC_STANDARD();
6309 (void)sprintf(PL_efloatbuf, eptr, nv);
6310 RESTORE_NUMERIC_LOCAL();
6313 eptr = PL_efloatbuf;
6314 elen = strlen(PL_efloatbuf);
6321 i = SvCUR(sv) - origlen;
6324 case 'h': *(va_arg(*args, short*)) = i; break;
6325 default: *(va_arg(*args, int*)) = i; break;
6326 case 'l': *(va_arg(*args, long*)) = i; break;
6327 case 'V': *(va_arg(*args, IV*)) = i; break;
6329 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6333 else if (svix < svmax)
6334 sv_setuv(svargs[svix++], (UV)i);
6335 continue; /* not "break" */
6342 if (!args && ckWARN(WARN_PRINTF) &&
6343 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6344 SV *msg = sv_newmortal();
6345 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6346 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6349 Perl_sv_catpvf(aTHX_ msg,
6350 "\"%%%c\"", c & 0xFF);
6352 Perl_sv_catpvf(aTHX_ msg,
6353 "\"%%\\%03"UVof"\"",
6356 sv_catpv(msg, "end of string");
6357 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6360 /* output mangled stuff ... */
6366 /* ... right here, because formatting flags should not apply */
6367 SvGROW(sv, SvCUR(sv) + elen + 1);
6369 memcpy(p, eptr, elen);
6372 SvCUR(sv) = p - SvPVX(sv);
6373 continue; /* not "break" */
6376 have = esignlen + zeros + elen;
6377 need = (have > width ? have : width);
6380 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6382 if (esignlen && fill == '0') {
6383 for (i = 0; i < esignlen; i++)
6387 memset(p, fill, gap);
6390 if (esignlen && fill != '0') {
6391 for (i = 0; i < esignlen; i++)
6395 for (i = zeros; i; i--)
6399 memcpy(p, eptr, elen);
6403 memset(p, ' ', gap);
6408 memcpy(p, dotstr, dotstrlen);
6412 vectorize = FALSE; /* done iterating over vecstr */
6417 SvCUR(sv) = p - SvPVX(sv);
6425 #if defined(USE_ITHREADS)
6427 #if defined(USE_THREADS)
6428 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6431 #ifndef GpREFCNT_inc
6432 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6436 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6437 #define av_dup(s) (AV*)sv_dup((SV*)s)
6438 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6439 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6440 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6441 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6442 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6443 #define io_dup(s) (IO*)sv_dup((SV*)s)
6444 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6445 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6446 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6447 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6448 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6451 Perl_re_dup(pTHX_ REGEXP *r)
6453 /* XXX fix when pmop->op_pmregexp becomes shared */
6454 return ReREFCNT_inc(r);
6458 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6462 return (PerlIO*)NULL;
6464 /* look for it in the table first */
6465 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6469 /* create anew and remember what it is */
6470 ret = PerlIO_fdupopen(fp);
6471 ptr_table_store(PL_ptr_table, fp, ret);
6476 Perl_dirp_dup(pTHX_ DIR *dp)
6485 Perl_gp_dup(pTHX_ GP *gp)
6490 /* look for it in the table first */
6491 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6495 /* create anew and remember what it is */
6496 Newz(0, ret, 1, GP);
6497 ptr_table_store(PL_ptr_table, gp, ret);
6500 ret->gp_refcnt = 0; /* must be before any other dups! */
6501 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6502 ret->gp_io = io_dup_inc(gp->gp_io);
6503 ret->gp_form = cv_dup_inc(gp->gp_form);
6504 ret->gp_av = av_dup_inc(gp->gp_av);
6505 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6506 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6507 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6508 ret->gp_cvgen = gp->gp_cvgen;
6509 ret->gp_flags = gp->gp_flags;
6510 ret->gp_line = gp->gp_line;
6511 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6516 Perl_mg_dup(pTHX_ MAGIC *mg)
6518 MAGIC *mgret = (MAGIC*)NULL;
6521 return (MAGIC*)NULL;
6522 /* look for it in the table first */
6523 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6527 for (; mg; mg = mg->mg_moremagic) {
6529 Newz(0, nmg, 1, MAGIC);
6533 mgprev->mg_moremagic = nmg;
6534 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6535 nmg->mg_private = mg->mg_private;
6536 nmg->mg_type = mg->mg_type;
6537 nmg->mg_flags = mg->mg_flags;
6538 if (mg->mg_type == 'r') {
6539 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6542 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6543 ? sv_dup_inc(mg->mg_obj)
6544 : sv_dup(mg->mg_obj);
6546 nmg->mg_len = mg->mg_len;
6547 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6548 if (mg->mg_ptr && mg->mg_type != 'g') {
6549 if (mg->mg_len >= 0) {
6550 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6551 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6552 AMT *amtp = (AMT*)mg->mg_ptr;
6553 AMT *namtp = (AMT*)nmg->mg_ptr;
6555 for (i = 1; i < NofAMmeth; i++) {
6556 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6560 else if (mg->mg_len == HEf_SVKEY)
6561 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6569 Perl_ptr_table_new(pTHX)
6572 Newz(0, tbl, 1, PTR_TBL_t);
6575 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6580 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6582 PTR_TBL_ENT_t *tblent;
6583 UV hash = PTR2UV(sv);
6585 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6586 for (; tblent; tblent = tblent->next) {
6587 if (tblent->oldval == sv)
6588 return tblent->newval;
6594 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6596 PTR_TBL_ENT_t *tblent, **otblent;
6597 /* XXX this may be pessimal on platforms where pointers aren't good
6598 * hash values e.g. if they grow faster in the most significant
6600 UV hash = PTR2UV(oldv);
6604 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6605 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6606 if (tblent->oldval == oldv) {
6607 tblent->newval = newv;
6612 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6613 tblent->oldval = oldv;
6614 tblent->newval = newv;
6615 tblent->next = *otblent;
6618 if (i && tbl->tbl_items > tbl->tbl_max)
6619 ptr_table_split(tbl);
6623 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6625 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6626 UV oldsize = tbl->tbl_max + 1;
6627 UV newsize = oldsize * 2;
6630 Renew(ary, newsize, PTR_TBL_ENT_t*);
6631 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6632 tbl->tbl_max = --newsize;
6634 for (i=0; i < oldsize; i++, ary++) {
6635 PTR_TBL_ENT_t **curentp, **entp, *ent;
6638 curentp = ary + oldsize;
6639 for (entp = ary, ent = *ary; ent; ent = *entp) {
6640 if ((newsize & PTR2UV(ent->oldval)) != i) {
6642 ent->next = *curentp;
6657 Perl_sv_dup(pTHX_ SV *sstr)
6661 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6663 /* look for it in the table first */
6664 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6668 /* create anew and remember what it is */
6670 ptr_table_store(PL_ptr_table, sstr, dstr);
6673 SvFLAGS(dstr) = SvFLAGS(sstr);
6674 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6675 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6678 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6679 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6680 PL_watch_pvx, SvPVX(sstr));
6683 switch (SvTYPE(sstr)) {
6688 SvANY(dstr) = new_XIV();
6689 SvIVX(dstr) = SvIVX(sstr);
6692 SvANY(dstr) = new_XNV();
6693 SvNVX(dstr) = SvNVX(sstr);
6696 SvANY(dstr) = new_XRV();
6697 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6700 SvANY(dstr) = new_XPV();
6701 SvCUR(dstr) = SvCUR(sstr);
6702 SvLEN(dstr) = SvLEN(sstr);
6704 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6705 else if (SvPVX(sstr) && SvLEN(sstr))
6706 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6708 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6711 SvANY(dstr) = new_XPVIV();
6712 SvCUR(dstr) = SvCUR(sstr);
6713 SvLEN(dstr) = SvLEN(sstr);
6714 SvIVX(dstr) = SvIVX(sstr);
6716 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6717 else if (SvPVX(sstr) && SvLEN(sstr))
6718 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6720 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6723 SvANY(dstr) = new_XPVNV();
6724 SvCUR(dstr) = SvCUR(sstr);
6725 SvLEN(dstr) = SvLEN(sstr);
6726 SvIVX(dstr) = SvIVX(sstr);
6727 SvNVX(dstr) = SvNVX(sstr);
6729 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6730 else if (SvPVX(sstr) && SvLEN(sstr))
6731 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6733 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6736 SvANY(dstr) = new_XPVMG();
6737 SvCUR(dstr) = SvCUR(sstr);
6738 SvLEN(dstr) = SvLEN(sstr);
6739 SvIVX(dstr) = SvIVX(sstr);
6740 SvNVX(dstr) = SvNVX(sstr);
6741 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6742 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6744 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6745 else if (SvPVX(sstr) && SvLEN(sstr))
6746 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6748 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6751 SvANY(dstr) = new_XPVBM();
6752 SvCUR(dstr) = SvCUR(sstr);
6753 SvLEN(dstr) = SvLEN(sstr);
6754 SvIVX(dstr) = SvIVX(sstr);
6755 SvNVX(dstr) = SvNVX(sstr);
6756 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6757 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6759 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6760 else if (SvPVX(sstr) && SvLEN(sstr))
6761 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6763 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6764 BmRARE(dstr) = BmRARE(sstr);
6765 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6766 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6769 SvANY(dstr) = new_XPVLV();
6770 SvCUR(dstr) = SvCUR(sstr);
6771 SvLEN(dstr) = SvLEN(sstr);
6772 SvIVX(dstr) = SvIVX(sstr);
6773 SvNVX(dstr) = SvNVX(sstr);
6774 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6775 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6777 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6778 else if (SvPVX(sstr) && SvLEN(sstr))
6779 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6781 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6782 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6783 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6784 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6785 LvTYPE(dstr) = LvTYPE(sstr);
6788 SvANY(dstr) = new_XPVGV();
6789 SvCUR(dstr) = SvCUR(sstr);
6790 SvLEN(dstr) = SvLEN(sstr);
6791 SvIVX(dstr) = SvIVX(sstr);
6792 SvNVX(dstr) = SvNVX(sstr);
6793 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6794 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6796 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6797 else if (SvPVX(sstr) && SvLEN(sstr))
6798 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6800 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6801 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6802 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6803 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6804 GvFLAGS(dstr) = GvFLAGS(sstr);
6805 GvGP(dstr) = gp_dup(GvGP(sstr));
6806 (void)GpREFCNT_inc(GvGP(dstr));
6809 SvANY(dstr) = new_XPVIO();
6810 SvCUR(dstr) = SvCUR(sstr);
6811 SvLEN(dstr) = SvLEN(sstr);
6812 SvIVX(dstr) = SvIVX(sstr);
6813 SvNVX(dstr) = SvNVX(sstr);
6814 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6815 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6817 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6818 else if (SvPVX(sstr) && SvLEN(sstr))
6819 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6821 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6822 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6823 if (IoOFP(sstr) == IoIFP(sstr))
6824 IoOFP(dstr) = IoIFP(dstr);
6826 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6827 /* PL_rsfp_filters entries have fake IoDIRP() */
6828 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6829 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6831 IoDIRP(dstr) = IoDIRP(sstr);
6832 IoLINES(dstr) = IoLINES(sstr);
6833 IoPAGE(dstr) = IoPAGE(sstr);
6834 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6835 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6836 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6837 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6838 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6839 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6840 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6841 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6842 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6843 IoTYPE(dstr) = IoTYPE(sstr);
6844 IoFLAGS(dstr) = IoFLAGS(sstr);
6847 SvANY(dstr) = new_XPVAV();
6848 SvCUR(dstr) = SvCUR(sstr);
6849 SvLEN(dstr) = SvLEN(sstr);
6850 SvIVX(dstr) = SvIVX(sstr);
6851 SvNVX(dstr) = SvNVX(sstr);
6852 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6853 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6854 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6855 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6856 if (AvARRAY((AV*)sstr)) {
6857 SV **dst_ary, **src_ary;
6858 SSize_t items = AvFILLp((AV*)sstr) + 1;
6860 src_ary = AvARRAY((AV*)sstr);
6861 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6862 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6863 SvPVX(dstr) = (char*)dst_ary;
6864 AvALLOC((AV*)dstr) = dst_ary;
6865 if (AvREAL((AV*)sstr)) {
6867 *dst_ary++ = sv_dup_inc(*src_ary++);
6871 *dst_ary++ = sv_dup(*src_ary++);
6873 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6874 while (items-- > 0) {
6875 *dst_ary++ = &PL_sv_undef;
6879 SvPVX(dstr) = Nullch;
6880 AvALLOC((AV*)dstr) = (SV**)NULL;
6884 SvANY(dstr) = new_XPVHV();
6885 SvCUR(dstr) = SvCUR(sstr);
6886 SvLEN(dstr) = SvLEN(sstr);
6887 SvIVX(dstr) = SvIVX(sstr);
6888 SvNVX(dstr) = SvNVX(sstr);
6889 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6890 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6891 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6892 if (HvARRAY((HV*)sstr)) {
6894 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6895 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6896 Newz(0, dxhv->xhv_array,
6897 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6898 while (i <= sxhv->xhv_max) {
6899 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6900 !!HvSHAREKEYS(sstr));
6903 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6906 SvPVX(dstr) = Nullch;
6907 HvEITER((HV*)dstr) = (HE*)NULL;
6909 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6910 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6913 SvANY(dstr) = new_XPVFM();
6914 FmLINES(dstr) = FmLINES(sstr);
6918 SvANY(dstr) = new_XPVCV();
6920 SvCUR(dstr) = SvCUR(sstr);
6921 SvLEN(dstr) = SvLEN(sstr);
6922 SvIVX(dstr) = SvIVX(sstr);
6923 SvNVX(dstr) = SvNVX(sstr);
6924 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6925 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6926 if (SvPVX(sstr) && SvLEN(sstr))
6927 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6929 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6930 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6931 CvSTART(dstr) = CvSTART(sstr);
6932 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6933 CvXSUB(dstr) = CvXSUB(sstr);
6934 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6935 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6936 CvDEPTH(dstr) = CvDEPTH(sstr);
6937 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6938 /* XXX padlists are real, but pretend to be not */
6939 AvREAL_on(CvPADLIST(sstr));
6940 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6941 AvREAL_off(CvPADLIST(sstr));
6942 AvREAL_off(CvPADLIST(dstr));
6945 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6946 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6947 CvFLAGS(dstr) = CvFLAGS(sstr);
6950 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6954 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6961 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6966 return (PERL_CONTEXT*)NULL;
6968 /* look for it in the table first */
6969 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6973 /* create anew and remember what it is */
6974 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6975 ptr_table_store(PL_ptr_table, cxs, ncxs);
6978 PERL_CONTEXT *cx = &cxs[ix];
6979 PERL_CONTEXT *ncx = &ncxs[ix];
6980 ncx->cx_type = cx->cx_type;
6981 if (CxTYPE(cx) == CXt_SUBST) {
6982 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6985 ncx->blk_oldsp = cx->blk_oldsp;
6986 ncx->blk_oldcop = cx->blk_oldcop;
6987 ncx->blk_oldretsp = cx->blk_oldretsp;
6988 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6989 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6990 ncx->blk_oldpm = cx->blk_oldpm;
6991 ncx->blk_gimme = cx->blk_gimme;
6992 switch (CxTYPE(cx)) {
6994 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6995 ? cv_dup_inc(cx->blk_sub.cv)
6996 : cv_dup(cx->blk_sub.cv));
6997 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6998 ? av_dup_inc(cx->blk_sub.argarray)
7000 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7001 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7002 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7003 ncx->blk_sub.lval = cx->blk_sub.lval;
7006 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7007 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7008 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7009 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7010 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7013 ncx->blk_loop.label = cx->blk_loop.label;
7014 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7015 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7016 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7017 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7018 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7019 ? cx->blk_loop.iterdata
7020 : gv_dup((GV*)cx->blk_loop.iterdata));
7021 ncx->blk_loop.oldcurpad
7022 = (SV**)ptr_table_fetch(PL_ptr_table,
7023 cx->blk_loop.oldcurpad);
7024 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7025 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7026 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7027 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7028 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7031 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7032 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7033 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7034 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7047 Perl_si_dup(pTHX_ PERL_SI *si)
7052 return (PERL_SI*)NULL;
7054 /* look for it in the table first */
7055 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7059 /* create anew and remember what it is */
7060 Newz(56, nsi, 1, PERL_SI);
7061 ptr_table_store(PL_ptr_table, si, nsi);
7063 nsi->si_stack = av_dup_inc(si->si_stack);
7064 nsi->si_cxix = si->si_cxix;
7065 nsi->si_cxmax = si->si_cxmax;
7066 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7067 nsi->si_type = si->si_type;
7068 nsi->si_prev = si_dup(si->si_prev);
7069 nsi->si_next = si_dup(si->si_next);
7070 nsi->si_markoff = si->si_markoff;
7075 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7076 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7077 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7078 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7079 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7080 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7081 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7082 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7083 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7084 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7085 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7086 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7089 #define pv_dup_inc(p) SAVEPV(p)
7090 #define pv_dup(p) SAVEPV(p)
7091 #define svp_dup_inc(p,pp) any_dup(p,pp)
7094 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7101 /* look for it in the table first */
7102 ret = ptr_table_fetch(PL_ptr_table, v);
7106 /* see if it is part of the interpreter structure */
7107 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7108 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7116 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7118 ANY *ss = proto_perl->Tsavestack;
7119 I32 ix = proto_perl->Tsavestack_ix;
7120 I32 max = proto_perl->Tsavestack_max;
7133 void (*dptr) (void*);
7134 void (*dxptr) (pTHXo_ void*);
7137 Newz(54, nss, max, ANY);
7143 case SAVEt_ITEM: /* normal string */
7144 sv = (SV*)POPPTR(ss,ix);
7145 TOPPTR(nss,ix) = sv_dup_inc(sv);
7146 sv = (SV*)POPPTR(ss,ix);
7147 TOPPTR(nss,ix) = sv_dup_inc(sv);
7149 case SAVEt_SV: /* scalar reference */
7150 sv = (SV*)POPPTR(ss,ix);
7151 TOPPTR(nss,ix) = sv_dup_inc(sv);
7152 gv = (GV*)POPPTR(ss,ix);
7153 TOPPTR(nss,ix) = gv_dup_inc(gv);
7155 case SAVEt_GENERIC_PVREF: /* generic char* */
7156 c = (char*)POPPTR(ss,ix);
7157 TOPPTR(nss,ix) = pv_dup(c);
7158 ptr = POPPTR(ss,ix);
7159 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
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);
7891 ENTER; /* perl_destruct() wants to LEAVE; */
7894 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7895 PL_top_env = &PL_start_env;
7897 PL_op = proto_perl->Top;
7900 PL_Xpv = (XPV*)NULL;
7901 PL_na = proto_perl->Tna;
7903 PL_statbuf = proto_perl->Tstatbuf;
7904 PL_statcache = proto_perl->Tstatcache;
7905 PL_statgv = gv_dup(proto_perl->Tstatgv);
7906 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7908 PL_timesbuf = proto_perl->Ttimesbuf;
7911 PL_tainted = proto_perl->Ttainted;
7912 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7913 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7914 PL_rs = sv_dup_inc(proto_perl->Trs);
7915 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7916 PL_ofslen = proto_perl->Tofslen;
7917 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7918 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7919 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7920 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7921 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7922 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7924 PL_restartop = proto_perl->Trestartop;
7925 PL_in_eval = proto_perl->Tin_eval;
7926 PL_delaymagic = proto_perl->Tdelaymagic;
7927 PL_dirty = proto_perl->Tdirty;
7928 PL_localizing = proto_perl->Tlocalizing;
7930 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7931 PL_protect = proto_perl->Tprotect;
7933 PL_errors = sv_dup_inc(proto_perl->Terrors);
7934 PL_av_fetch_sv = Nullsv;
7935 PL_hv_fetch_sv = Nullsv;
7936 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7937 PL_modcount = proto_perl->Tmodcount;
7938 PL_lastgotoprobe = Nullop;
7939 PL_dumpindent = proto_perl->Tdumpindent;
7941 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7942 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7943 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7944 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7945 PL_sortcxix = proto_perl->Tsortcxix;
7946 PL_efloatbuf = Nullch; /* reinits on demand */
7947 PL_efloatsize = 0; /* reinits on demand */
7951 PL_screamfirst = NULL;
7952 PL_screamnext = NULL;
7953 PL_maxscream = -1; /* reinits on demand */
7954 PL_lastscream = Nullsv;
7956 PL_watchaddr = NULL;
7957 PL_watchok = Nullch;
7959 PL_regdummy = proto_perl->Tregdummy;
7960 PL_regcomp_parse = Nullch;
7961 PL_regxend = Nullch;
7962 PL_regcode = (regnode*)NULL;
7965 PL_regprecomp = Nullch;
7970 PL_seen_zerolen = 0;
7972 PL_regcomp_rx = (regexp*)NULL;
7974 PL_colorset = 0; /* reinits PL_colors[] */
7975 /*PL_colors[6] = {0,0,0,0,0,0};*/
7976 PL_reg_whilem_seen = 0;
7977 PL_reginput = Nullch;
7980 PL_regstartp = (I32*)NULL;
7981 PL_regendp = (I32*)NULL;
7982 PL_reglastparen = (U32*)NULL;
7983 PL_regtill = Nullch;
7985 PL_reg_start_tmp = (char**)NULL;
7986 PL_reg_start_tmpl = 0;
7987 PL_regdata = (struct reg_data*)NULL;
7990 PL_reg_eval_set = 0;
7992 PL_regprogram = (regnode*)NULL;
7994 PL_regcc = (CURCUR*)NULL;
7995 PL_reg_call_cc = (struct re_cc_state*)NULL;
7996 PL_reg_re = (regexp*)NULL;
7997 PL_reg_ganch = Nullch;
7999 PL_reg_magic = (MAGIC*)NULL;
8001 PL_reg_oldcurpm = (PMOP*)NULL;
8002 PL_reg_curpm = (PMOP*)NULL;
8003 PL_reg_oldsaved = Nullch;
8004 PL_reg_oldsavedlen = 0;
8006 PL_reg_leftiter = 0;
8007 PL_reg_poscache = Nullch;
8008 PL_reg_poscache_size= 0;
8010 /* RE engine - function pointers */
8011 PL_regcompp = proto_perl->Tregcompp;
8012 PL_regexecp = proto_perl->Tregexecp;
8013 PL_regint_start = proto_perl->Tregint_start;
8014 PL_regint_string = proto_perl->Tregint_string;
8015 PL_regfree = proto_perl->Tregfree;
8017 PL_reginterp_cnt = 0;
8018 PL_reg_starttry = 0;
8021 return (PerlInterpreter*)pPerl;
8027 #else /* !USE_ITHREADS */
8033 #endif /* USE_ITHREADS */
8036 do_report_used(pTHXo_ SV *sv)
8038 if (SvTYPE(sv) != SVTYPEMASK) {
8039 PerlIO_printf(Perl_debug_log, "****\n");
8045 do_clean_objs(pTHXo_ SV *sv)
8049 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8050 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8056 /* XXX Might want to check arrays, etc. */
8059 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8061 do_clean_named_objs(pTHXo_ SV *sv)
8063 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8064 if ( SvOBJECT(GvSV(sv)) ||
8065 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8066 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8067 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8068 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8070 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8078 do_clean_all(pTHXo_ SV *sv)
8080 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8081 SvFLAGS(sv) |= SVf_BREAK;