3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
207 Safefree((void *)sva);
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
219 Perl_report_uninit(pTHX)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
237 * See comment in more_xiv() -- RAM.
239 PL_xiv_root = *(IV**)xiv;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
245 S_del_xiv(pTHX_ XPVIV *p)
247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
249 *(IV**)xiv = PL_xiv_root;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
268 while (xiv < xivend) {
269 *(IV**)xiv = (IV *)(xiv + 1);
283 PL_xnv_root = *(NV**)xnv;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
289 S_del_xnv(pTHX_ XPVNV *p)
291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
293 *(NV**)xnv = PL_xnv_root;
303 New(711, xnv, 1008/sizeof(NV), NV);
304 xnvend = &xnv[1008 / sizeof(NV) - 1];
305 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
307 while (xnv < xnvend) {
308 *(NV**)xnv = (NV*)(xnv + 1);
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
328 S_del_xrv(pTHX_ XRV *p)
331 p->xrv_rv = (SV*)PL_xrv_root;
340 register XRV* xrvend;
341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
365 S_del_xpv(pTHX_ XPV *p)
368 p->xpv_pv = (char*)PL_xpv_root;
377 register XPV* xpvend;
378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
402 S_del_xpviv(pTHX_ XPVIV *p)
405 p->xpv_pv = (char*)PL_xpviv_root;
414 register XPVIV* xpviv;
415 register XPVIV* xpvivend;
416 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417 xpviv = PL_xpviv_root;
418 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419 while (xpviv < xpvivend) {
420 xpviv->xpv_pv = (char*)(xpviv + 1);
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
441 S_del_xpvnv(pTHX_ XPVNV *p)
444 p->xpv_pv = (char*)PL_xpvnv_root;
453 register XPVNV* xpvnv;
454 register XPVNV* xpvnvend;
455 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456 xpvnv = PL_xpvnv_root;
457 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458 while (xpvnv < xpvnvend) {
459 xpvnv->xpv_pv = (char*)(xpvnv + 1);
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
481 S_del_xpvcv(pTHX_ XPVCV *p)
484 p->xpv_pv = (char*)PL_xpvcv_root;
493 register XPVCV* xpvcv;
494 register XPVCV* xpvcvend;
495 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496 xpvcv = PL_xpvcv_root;
497 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498 while (xpvcv < xpvcvend) {
499 xpvcv->xpv_pv = (char*)(xpvcv + 1);
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
521 S_del_xpvav(pTHX_ XPVAV *p)
524 p->xav_array = (char*)PL_xpvav_root;
533 register XPVAV* xpvav;
534 register XPVAV* xpvavend;
535 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536 xpvav = PL_xpvav_root;
537 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538 while (xpvav < xpvavend) {
539 xpvav->xav_array = (char*)(xpvav + 1);
542 xpvav->xav_array = 0;
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
561 S_del_xpvhv(pTHX_ XPVHV *p)
564 p->xhv_array = (char*)PL_xpvhv_root;
573 register XPVHV* xpvhv;
574 register XPVHV* xpvhvend;
575 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576 xpvhv = PL_xpvhv_root;
577 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578 while (xpvhv < xpvhvend) {
579 xpvhv->xhv_array = (char*)(xpvhv + 1);
582 xpvhv->xhv_array = 0;
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
600 S_del_xpvmg(pTHX_ XPVMG *p)
603 p->xpv_pv = (char*)PL_xpvmg_root;
612 register XPVMG* xpvmg;
613 register XPVMG* xpvmgend;
614 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615 xpvmg = PL_xpvmg_root;
616 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617 while (xpvmg < xpvmgend) {
618 xpvmg->xpv_pv = (char*)(xpvmg + 1);
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
640 S_del_xpvlv(pTHX_ XPVLV *p)
643 p->xpv_pv = (char*)PL_xpvlv_root;
652 register XPVLV* xpvlv;
653 register XPVLV* xpvlvend;
654 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655 xpvlv = PL_xpvlv_root;
656 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657 while (xpvlv < xpvlvend) {
658 xpvlv->xpv_pv = (char*)(xpvlv + 1);
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
679 S_del_xpvbm(pTHX_ XPVBM *p)
682 p->xpv_pv = (char*)PL_xpvbm_root;
691 register XPVBM* xpvbm;
692 register XPVBM* xpvbmend;
693 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694 xpvbm = PL_xpvbm_root;
695 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696 while (xpvbm < xpvbmend) {
697 xpvbm->xpv_pv = (char*)(xpvbm + 1);
704 # define my_safemalloc(s) (void*)safexmalloc(717,s)
705 # define my_safefree(p) safexfree((char*)p)
707 # define my_safemalloc(s) (void*)safemalloc(s)
708 # define my_safefree(p) safefree((char*)p)
713 #define new_XIV() my_safemalloc(sizeof(XPVIV))
714 #define del_XIV(p) my_safefree(p)
716 #define new_XNV() my_safemalloc(sizeof(XPVNV))
717 #define del_XNV(p) my_safefree(p)
719 #define new_XRV() my_safemalloc(sizeof(XRV))
720 #define del_XRV(p) my_safefree(p)
722 #define new_XPV() my_safemalloc(sizeof(XPV))
723 #define del_XPV(p) my_safefree(p)
725 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726 #define del_XPVIV(p) my_safefree(p)
728 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729 #define del_XPVNV(p) my_safefree(p)
731 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732 #define del_XPVCV(p) my_safefree(p)
734 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735 #define del_XPVAV(p) my_safefree(p)
737 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738 #define del_XPVHV(p) my_safefree(p)
740 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741 #define del_XPVMG(p) my_safefree(p)
743 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744 #define del_XPVLV(p) my_safefree(p)
746 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747 #define del_XPVBM(p) my_safefree(p)
751 #define new_XIV() (void*)new_xiv()
752 #define del_XIV(p) del_xiv((XPVIV*) p)
754 #define new_XNV() (void*)new_xnv()
755 #define del_XNV(p) del_xnv((XPVNV*) p)
757 #define new_XRV() (void*)new_xrv()
758 #define del_XRV(p) del_xrv((XRV*) p)
760 #define new_XPV() (void*)new_xpv()
761 #define del_XPV(p) del_xpv((XPV *)p)
763 #define new_XPVIV() (void*)new_xpviv()
764 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
766 #define new_XPVNV() (void*)new_xpvnv()
767 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
769 #define new_XPVCV() (void*)new_xpvcv()
770 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
772 #define new_XPVAV() (void*)new_xpvav()
773 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
775 #define new_XPVHV() (void*)new_xpvhv()
776 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
778 #define new_XPVMG() (void*)new_xpvmg()
779 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
781 #define new_XPVLV() (void*)new_xpvlv()
782 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
784 #define new_XPVBM() (void*)new_xpvbm()
785 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
789 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790 #define del_XPVGV(p) my_safefree(p)
792 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793 #define del_XPVFM(p) my_safefree(p)
795 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796 #define del_XPVIO(p) my_safefree(p)
799 =for apidoc sv_upgrade
801 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
808 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
818 if (SvTYPE(sv) == mt)
824 switch (SvTYPE(sv)) {
845 else if (mt < SVt_PVIV)
862 pv = (char*)SvRV(sv);
882 else if (mt == SVt_NV)
893 del_XPVIV(SvANY(sv));
903 del_XPVNV(SvANY(sv));
913 del_XPVMG(SvANY(sv));
916 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
921 Perl_croak(aTHX_ "Can't upgrade to undef");
923 SvANY(sv) = new_XIV();
927 SvANY(sv) = new_XNV();
931 SvANY(sv) = new_XRV();
935 SvANY(sv) = new_XPV();
941 SvANY(sv) = new_XPVIV();
951 SvANY(sv) = new_XPVNV();
959 SvANY(sv) = new_XPVMG();
969 SvANY(sv) = new_XPVLV();
983 SvANY(sv) = new_XPVAV();
998 SvANY(sv) = new_XPVHV();
1006 SvMAGIC(sv) = magic;
1007 SvSTASH(sv) = stash;
1014 SvANY(sv) = new_XPVCV();
1015 Zero(SvANY(sv), 1, XPVCV);
1021 SvMAGIC(sv) = magic;
1022 SvSTASH(sv) = stash;
1025 SvANY(sv) = new_XPVGV();
1031 SvMAGIC(sv) = magic;
1032 SvSTASH(sv) = stash;
1040 SvANY(sv) = new_XPVBM();
1046 SvMAGIC(sv) = magic;
1047 SvSTASH(sv) = stash;
1053 SvANY(sv) = new_XPVFM();
1054 Zero(SvANY(sv), 1, XPVFM);
1060 SvMAGIC(sv) = magic;
1061 SvSTASH(sv) = stash;
1064 SvANY(sv) = new_XPVIO();
1065 Zero(SvANY(sv), 1, XPVIO);
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
1073 IoPAGE_LEN(sv) = 60;
1076 SvFLAGS(sv) &= ~SVTYPEMASK;
1082 Perl_sv_backoff(pTHX_ register SV *sv)
1086 char *s = SvPVX(sv);
1087 SvLEN(sv) += SvIVX(sv);
1088 SvPVX(sv) -= SvIVX(sv);
1090 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1092 SvFLAGS(sv) &= ~SVf_OOK;
1099 Expands the character buffer in the SV. This will use C<sv_unref> and will
1100 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1107 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1111 #ifdef HAS_64K_LIMIT
1112 if (newlen >= 0x10000) {
1113 PerlIO_printf(Perl_debug_log,
1114 "Allocation too large: %"UVxf"\n", (UV)newlen);
1117 #endif /* HAS_64K_LIMIT */
1120 if (SvTYPE(sv) < SVt_PV) {
1121 sv_upgrade(sv, SVt_PV);
1124 else if (SvOOK(sv)) { /* pv is offset? */
1127 if (newlen > SvLEN(sv))
1128 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129 #ifdef HAS_64K_LIMIT
1130 if (newlen >= 0x10000)
1136 if (newlen > SvLEN(sv)) { /* need more room? */
1137 if (SvLEN(sv) && s) {
1138 #if defined(MYMALLOC) && !defined(LEAKTEST)
1139 STRLEN l = malloced_size((void*)SvPVX(sv));
1145 Renew(s,newlen,char);
1148 New(703,s,newlen,char);
1150 SvLEN_set(sv, newlen);
1156 =for apidoc sv_setiv
1158 Copies an integer into the given SV. Does not handle 'set' magic. See
1165 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1167 SV_CHECK_THINKFIRST(sv);
1168 switch (SvTYPE(sv)) {
1170 sv_upgrade(sv, SVt_IV);
1173 sv_upgrade(sv, SVt_PVNV);
1177 sv_upgrade(sv, SVt_PVIV);
1188 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189 PL_op_desc[PL_op->op_type]);
1192 (void)SvIOK_only(sv); /* validate number */
1198 =for apidoc sv_setiv_mg
1200 Like C<sv_setiv>, but also handles 'set' magic.
1206 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1213 =for apidoc sv_setuv
1215 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1222 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1230 =for apidoc sv_setuv_mg
1232 Like C<sv_setuv>, but also handles 'set' magic.
1238 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1245 =for apidoc sv_setnv
1247 Copies a double into the given SV. Does not handle 'set' magic. See
1254 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1256 SV_CHECK_THINKFIRST(sv);
1257 switch (SvTYPE(sv)) {
1260 sv_upgrade(sv, SVt_NV);
1265 sv_upgrade(sv, SVt_PVNV);
1276 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277 PL_op_name[PL_op->op_type]);
1281 (void)SvNOK_only(sv); /* validate number */
1286 =for apidoc sv_setnv_mg
1288 Like C<sv_setnv>, but also handles 'set' magic.
1294 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1301 S_not_a_number(pTHX_ SV *sv)
1307 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308 /* each *s can expand to 4 chars + "...\0",
1309 i.e. need room for 8 chars */
1311 for (s = SvPVX(sv); *s && d < limit; s++) {
1313 if (ch & 128 && !isPRINT_LC(ch)) {
1322 else if (ch == '\r') {
1326 else if (ch == '\f') {
1330 else if (ch == '\\') {
1334 else if (isPRINT_LC(ch))
1349 Perl_warner(aTHX_ WARN_NUMERIC,
1350 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351 PL_op_desc[PL_op->op_type]);
1353 Perl_warner(aTHX_ WARN_NUMERIC,
1354 "Argument \"%s\" isn't numeric", tmpbuf);
1357 /* the number can be converted to integer with atol() or atoll() */
1358 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1362 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1364 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1365 until proven guilty, assume that things are not that bad... */
1368 Perl_sv_2iv(pTHX_ register SV *sv)
1372 if (SvGMAGICAL(sv)) {
1377 return I_V(SvNVX(sv));
1379 if (SvPOKp(sv) && SvLEN(sv))
1382 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1384 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1390 if (SvTHINKFIRST(sv)) {
1393 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1394 return SvIV(tmpstr);
1395 return PTR2IV(SvRV(sv));
1397 if (SvREADONLY(sv) && !SvOK(sv)) {
1399 if (ckWARN(WARN_UNINITIALIZED))
1406 return (IV)(SvUVX(sv));
1413 /* We can cache the IV/UV value even if it not good enough
1414 * to reconstruct NV, since the conversion to PV will prefer
1418 if (SvTYPE(sv) == SVt_NV)
1419 sv_upgrade(sv, SVt_PVNV);
1422 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1423 SvIVX(sv) = I_V(SvNVX(sv));
1425 SvUVX(sv) = U_V(SvNVX(sv));
1428 DEBUG_c(PerlIO_printf(Perl_debug_log,
1429 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1433 return (IV)SvUVX(sv);
1436 else if (SvPOKp(sv) && SvLEN(sv)) {
1437 I32 numtype = looks_like_number(sv);
1439 /* We want to avoid a possible problem when we cache an IV which
1440 may be later translated to an NV, and the resulting NV is not
1441 the translation of the initial data.
1443 This means that if we cache such an IV, we need to cache the
1444 NV as well. Moreover, we trade speed for space, and do not
1445 cache the NV if not needed.
1447 if (numtype & IS_NUMBER_NOT_IV) {
1448 /* May be not an integer. Need to cache NV if we cache IV
1449 * - otherwise future conversion to NV will be wrong. */
1452 d = Atof(SvPVX(sv));
1454 if (SvTYPE(sv) < SVt_PVNV)
1455 sv_upgrade(sv, SVt_PVNV);
1459 #if defined(USE_LONG_DOUBLE)
1460 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1461 PTR2UV(sv), SvNVX(sv)));
1463 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1464 PTR2UV(sv), SvNVX(sv)));
1466 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1467 SvIVX(sv) = I_V(SvNVX(sv));
1469 SvUVX(sv) = U_V(SvNVX(sv));
1475 /* The NV may be reconstructed from IV - safe to cache IV,
1476 which may be calculated by atol(). */
1477 if (SvTYPE(sv) == SVt_PV)
1478 sv_upgrade(sv, SVt_PVIV);
1480 SvIVX(sv) = Atol(SvPVX(sv));
1482 else { /* Not a number. Cache 0. */
1485 if (SvTYPE(sv) < SVt_PVIV)
1486 sv_upgrade(sv, SVt_PVIV);
1489 if (ckWARN(WARN_NUMERIC))
1495 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1497 if (SvTYPE(sv) < SVt_IV)
1498 /* Typically the caller expects that sv_any is not NULL now. */
1499 sv_upgrade(sv, SVt_IV);
1502 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1503 PTR2UV(sv),SvIVX(sv)));
1504 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1508 Perl_sv_2uv(pTHX_ register SV *sv)
1512 if (SvGMAGICAL(sv)) {
1517 return U_V(SvNVX(sv));
1518 if (SvPOKp(sv) && SvLEN(sv))
1521 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1523 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1529 if (SvTHINKFIRST(sv)) {
1532 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1533 return SvUV(tmpstr);
1534 return PTR2UV(SvRV(sv));
1536 if (SvREADONLY(sv) && !SvOK(sv)) {
1538 if (ckWARN(WARN_UNINITIALIZED))
1548 return (UV)SvIVX(sv);
1552 /* We can cache the IV/UV value even if it not good enough
1553 * to reconstruct NV, since the conversion to PV will prefer
1556 if (SvTYPE(sv) == SVt_NV)
1557 sv_upgrade(sv, SVt_PVNV);
1559 if (SvNVX(sv) >= -0.5) {
1561 SvUVX(sv) = U_V(SvNVX(sv));
1564 SvIVX(sv) = I_V(SvNVX(sv));
1566 DEBUG_c(PerlIO_printf(Perl_debug_log,
1567 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1570 (IV)(UV)SvIVX(sv)));
1571 return (UV)SvIVX(sv);
1574 else if (SvPOKp(sv) && SvLEN(sv)) {
1575 I32 numtype = looks_like_number(sv);
1577 /* We want to avoid a possible problem when we cache a UV which
1578 may be later translated to an NV, and the resulting NV is not
1579 the translation of the initial data.
1581 This means that if we cache such a UV, we need to cache the
1582 NV as well. Moreover, we trade speed for space, and do not
1583 cache the NV if not needed.
1585 if (numtype & IS_NUMBER_NOT_IV) {
1586 /* May be not an integer. Need to cache NV if we cache IV
1587 * - otherwise future conversion to NV will be wrong. */
1590 d = Atof(SvPVX(sv));
1592 if (SvTYPE(sv) < SVt_PVNV)
1593 sv_upgrade(sv, SVt_PVNV);
1597 #if defined(USE_LONG_DOUBLE)
1598 DEBUG_c(PerlIO_printf(Perl_debug_log,
1599 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1600 PTR2UV(sv), SvNVX(sv)));
1602 DEBUG_c(PerlIO_printf(Perl_debug_log,
1603 "0x%"UVxf" 2nv(%g)\n",
1604 PTR2UV(sv), SvNVX(sv)));
1606 if (SvNVX(sv) < -0.5) {
1607 SvIVX(sv) = I_V(SvNVX(sv));
1610 SvUVX(sv) = U_V(SvNVX(sv));
1614 else if (numtype & IS_NUMBER_NEG) {
1615 /* The NV may be reconstructed from IV - safe to cache IV,
1616 which may be calculated by atol(). */
1617 if (SvTYPE(sv) == SVt_PV)
1618 sv_upgrade(sv, SVt_PVIV);
1620 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1622 else if (numtype) { /* Non-negative */
1623 /* The NV may be reconstructed from UV - safe to cache UV,
1624 which may be calculated by strtoul()/atol. */
1625 if (SvTYPE(sv) == SVt_PV)
1626 sv_upgrade(sv, SVt_PVIV);
1628 (void)SvIsUV_on(sv);
1630 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1631 #else /* no atou(), but we know the number fits into IV... */
1632 /* The only problem may be if it is negative... */
1633 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1636 else { /* Not a number. Cache 0. */
1639 if (SvTYPE(sv) < SVt_PVIV)
1640 sv_upgrade(sv, SVt_PVIV);
1642 (void)SvIsUV_on(sv);
1643 SvUVX(sv) = 0; /* We assume that 0s have the
1644 same bitmap in IV and UV. */
1645 if (ckWARN(WARN_NUMERIC))
1650 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1652 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1655 if (SvTYPE(sv) < SVt_IV)
1656 /* Typically the caller expects that sv_any is not NULL now. */
1657 sv_upgrade(sv, SVt_IV);
1661 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1662 PTR2UV(sv),SvUVX(sv)));
1663 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1667 Perl_sv_2nv(pTHX_ register SV *sv)
1671 if (SvGMAGICAL(sv)) {
1675 if (SvPOKp(sv) && SvLEN(sv)) {
1677 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1679 return Atof(SvPVX(sv));
1683 return (NV)SvUVX(sv);
1685 return (NV)SvIVX(sv);
1688 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1690 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1696 if (SvTHINKFIRST(sv)) {
1699 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1700 return SvNV(tmpstr);
1701 return PTR2NV(SvRV(sv));
1703 if (SvREADONLY(sv) && !SvOK(sv)) {
1705 if (ckWARN(WARN_UNINITIALIZED))
1710 if (SvTYPE(sv) < SVt_NV) {
1711 if (SvTYPE(sv) == SVt_IV)
1712 sv_upgrade(sv, SVt_PVNV);
1714 sv_upgrade(sv, SVt_NV);
1715 #if defined(USE_LONG_DOUBLE)
1717 RESTORE_NUMERIC_STANDARD();
1718 PerlIO_printf(Perl_debug_log,
1719 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1720 PTR2UV(sv), SvNVX(sv));
1721 RESTORE_NUMERIC_LOCAL();
1725 RESTORE_NUMERIC_STANDARD();
1726 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1727 PTR2UV(sv), SvNVX(sv));
1728 RESTORE_NUMERIC_LOCAL();
1732 else if (SvTYPE(sv) < SVt_PVNV)
1733 sv_upgrade(sv, SVt_PVNV);
1735 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1737 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1739 else if (SvPOKp(sv) && SvLEN(sv)) {
1741 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1743 SvNVX(sv) = Atof(SvPVX(sv));
1747 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1749 if (SvTYPE(sv) < SVt_NV)
1750 /* Typically the caller expects that sv_any is not NULL now. */
1751 sv_upgrade(sv, SVt_NV);
1755 #if defined(USE_LONG_DOUBLE)
1757 RESTORE_NUMERIC_STANDARD();
1758 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1759 PTR2UV(sv), SvNVX(sv));
1760 RESTORE_NUMERIC_LOCAL();
1764 RESTORE_NUMERIC_STANDARD();
1765 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1766 PTR2UV(sv), SvNVX(sv));
1767 RESTORE_NUMERIC_LOCAL();
1774 S_asIV(pTHX_ SV *sv)
1776 I32 numtype = looks_like_number(sv);
1779 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1780 return Atol(SvPVX(sv));
1783 if (ckWARN(WARN_NUMERIC))
1786 d = Atof(SvPVX(sv));
1791 S_asUV(pTHX_ SV *sv)
1793 I32 numtype = looks_like_number(sv);
1796 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1797 return Strtoul(SvPVX(sv), Null(char**), 10);
1801 if (ckWARN(WARN_NUMERIC))
1804 return U_V(Atof(SvPVX(sv)));
1808 * Returns a combination of (advisory only - can get false negatives)
1809 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1811 * 0 if does not look like number.
1813 * In fact possible values are 0 and
1814 * IS_NUMBER_TO_INT_BY_ATOL 123
1815 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1816 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1817 * IS_NUMBER_INFINITY
1818 * with a possible addition of IS_NUMBER_NEG.
1822 =for apidoc looks_like_number
1824 Test if an the content of an SV looks like a number (or is a
1831 Perl_looks_like_number(pTHX_ SV *sv)
1834 register char *send;
1835 register char *sbegin;
1836 register char *nbegin;
1845 else if (SvPOKp(sv))
1846 sbegin = SvPV(sv, len);
1849 send = sbegin + len;
1856 numtype = IS_NUMBER_NEG;
1863 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1864 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1868 /* next must be digit or the radix separator or beginning of infinity */
1872 } while (isDIGIT(*s));
1874 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1875 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1877 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1880 #ifdef USE_LOCALE_NUMERIC
1881 || IS_NUMERIC_RADIX(*s)
1885 numtype |= IS_NUMBER_NOT_IV;
1886 while (isDIGIT(*s)) /* optional digits after the radix */
1891 #ifdef USE_LOCALE_NUMERIC
1892 || IS_NUMERIC_RADIX(*s)
1896 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1897 /* no digits before the radix means we need digits after it */
1901 } while (isDIGIT(*s));
1906 else if (*s == 'I' || *s == 'i') {
1907 s++; if (*s != 'N' && *s != 'n') return 0;
1908 s++; if (*s != 'F' && *s != 'f') return 0;
1909 s++; if (*s == 'I' || *s == 'i') {
1910 s++; if (*s != 'N' && *s != 'n') return 0;
1911 s++; if (*s != 'I' && *s != 'i') return 0;
1912 s++; if (*s != 'T' && *s != 't') return 0;
1913 s++; if (*s != 'Y' && *s != 'y') return 0;
1921 numtype = IS_NUMBER_INFINITY;
1923 /* we can have an optional exponent part */
1924 if (*s == 'e' || *s == 'E') {
1925 numtype &= ~IS_NUMBER_NEG;
1926 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1928 if (*s == '+' || *s == '-')
1933 } while (isDIGIT(*s));
1943 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1944 return IS_NUMBER_TO_INT_BY_ATOL;
1949 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1952 return sv_2pv(sv, &n_a);
1955 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1957 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1959 char *ptr = buf + TYPE_CHARS(UV);
1973 *--ptr = '0' + (uv % 10);
1982 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1987 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1988 char *tmpbuf = tbuf;
1994 if (SvGMAGICAL(sv)) {
2002 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2004 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2009 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2014 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2016 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2023 if (SvTHINKFIRST(sv)) {
2026 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2027 return SvPV(tmpstr,*lp);
2034 switch (SvTYPE(sv)) {
2036 if ( ((SvFLAGS(sv) &
2037 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2038 == (SVs_OBJECT|SVs_RMG))
2039 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2040 && (mg = mg_find(sv, 'r'))) {
2042 regexp *re = (regexp *)mg->mg_obj;
2045 char *fptr = "msix";
2050 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2052 while((ch = *fptr++)) {
2054 reflags[left++] = ch;
2057 reflags[right--] = ch;
2062 reflags[left] = '-';
2066 mg->mg_len = re->prelen + 4 + left;
2067 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2068 Copy("(?", mg->mg_ptr, 2, char);
2069 Copy(reflags, mg->mg_ptr+2, left, char);
2070 Copy(":", mg->mg_ptr+left+2, 1, char);
2071 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2072 mg->mg_ptr[mg->mg_len - 1] = ')';
2073 mg->mg_ptr[mg->mg_len] = 0;
2075 PL_reginterp_cnt += re->program[0].next_off;
2087 case SVt_PVBM: s = "SCALAR"; break;
2088 case SVt_PVLV: s = "LVALUE"; break;
2089 case SVt_PVAV: s = "ARRAY"; break;
2090 case SVt_PVHV: s = "HASH"; break;
2091 case SVt_PVCV: s = "CODE"; break;
2092 case SVt_PVGV: s = "GLOB"; break;
2093 case SVt_PVFM: s = "FORMAT"; break;
2094 case SVt_PVIO: s = "IO"; break;
2095 default: s = "UNKNOWN"; break;
2099 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2102 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2108 if (SvREADONLY(sv) && !SvOK(sv)) {
2110 if (ckWARN(WARN_UNINITIALIZED))
2116 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2117 /* XXXX 64-bit? IV may have better precision... */
2118 /* I tried changing this for to be 64-bit-aware and
2119 * the t/op/numconvert.t became very, very, angry.
2121 if (SvTYPE(sv) < SVt_PVNV)
2122 sv_upgrade(sv, SVt_PVNV);
2125 olderrno = errno; /* some Xenix systems wipe out errno here */
2127 if (SvNVX(sv) == 0.0)
2128 (void)strcpy(s,"0");
2132 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2135 #ifdef FIXNEGATIVEZERO
2136 if (*s == '-' && s[1] == '0' && !s[2])
2145 else if (SvIOKp(sv)) {
2146 U32 isIOK = SvIOK(sv);
2147 U32 isUIOK = SvIsUV(sv);
2148 char buf[TYPE_CHARS(UV)];
2151 if (SvTYPE(sv) < SVt_PVIV)
2152 sv_upgrade(sv, SVt_PVIV);
2154 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2156 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2157 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2158 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2159 SvCUR_set(sv, ebuf - ptr);
2172 if (ckWARN(WARN_UNINITIALIZED)
2173 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2178 if (SvTYPE(sv) < SVt_PV)
2179 /* Typically the caller expects that sv_any is not NULL now. */
2180 sv_upgrade(sv, SVt_PV);
2183 *lp = s - SvPVX(sv);
2186 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2187 PTR2UV(sv),SvPVX(sv)));
2191 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2192 /* Sneaky stuff here */
2196 tsv = newSVpv(tmpbuf, 0);
2212 len = strlen(tmpbuf);
2214 #ifdef FIXNEGATIVEZERO
2215 if (len == 2 && t[0] == '-' && t[1] == '0') {
2220 (void)SvUPGRADE(sv, SVt_PV);
2222 s = SvGROW(sv, len + 1);
2231 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2234 return sv_2pvbyte(sv, &n_a);
2238 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2240 return sv_2pv(sv,lp);
2244 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2247 return sv_2pvutf8(sv, &n_a);
2251 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2253 sv_utf8_upgrade(sv);
2254 return sv_2pv(sv,lp);
2257 /* This function is only called on magical items */
2259 Perl_sv_2bool(pTHX_ register SV *sv)
2269 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2270 return SvTRUE(tmpsv);
2271 return SvRV(sv) != 0;
2274 register XPV* Xpvtmp;
2275 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2276 (*Xpvtmp->xpv_pv > '0' ||
2277 Xpvtmp->xpv_cur > 1 ||
2278 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2285 return SvIVX(sv) != 0;
2288 return SvNVX(sv) != 0.0;
2296 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2301 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2304 /* This function could be much more efficient if we had a FLAG
2305 * to signal if there are any hibit chars in the string
2308 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2315 SvGROW(sv, SvCUR(sv) + hicount + 1);
2317 src = SvEND(sv) - 1;
2318 SvCUR_set(sv, SvCUR(sv) + hicount);
2319 dst = SvEND(sv) - 1;
2324 uv_to_utf8((U8*)dst, (U8)*src--);
2337 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2339 if (SvPOK(sv) && SvUTF8(sv)) {
2340 char *c = SvPVX(sv);
2342 /* need to figure out if this is possible at all first */
2343 while (c < SvEND(sv)) {
2346 UV uv = utf8_to_uv((U8*)c, &len);
2351 /* XXX might want to make a callback here instead */
2352 Perl_croak(aTHX_ "Big byte");
2365 char *src = first_hi;
2366 char *dst = first_hi;
2367 while (src < SvEND(sv)) {
2370 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2378 SvCUR_set(sv, dst - SvPVX(sv));
2386 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2388 sv_utf8_upgrade(sv);
2393 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2397 bool has_utf = FALSE;
2398 if (!sv_utf8_downgrade(sv, TRUE))
2401 /* it is actually just a matter of turning the utf8 flag on, but
2402 * we want to make sure everything inside is valid utf8 first.
2405 while (c < SvEND(sv)) {
2408 (void)utf8_to_uv((U8*)c, &len);
2428 /* Note: sv_setsv() should not be called with a source string that needs
2429 * to be reused, since it may destroy the source string if it is marked
2434 =for apidoc sv_setsv
2436 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2437 The source SV may be destroyed if it is mortal. Does not handle 'set'
2438 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2445 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2448 register U32 sflags;
2454 SV_CHECK_THINKFIRST(dstr);
2456 sstr = &PL_sv_undef;
2457 stype = SvTYPE(sstr);
2458 dtype = SvTYPE(dstr);
2462 /* There's a lot of redundancy below but we're going for speed here */
2467 if (dtype != SVt_PVGV) {
2468 (void)SvOK_off(dstr);
2476 sv_upgrade(dstr, SVt_IV);
2479 sv_upgrade(dstr, SVt_PVNV);
2483 sv_upgrade(dstr, SVt_PVIV);
2486 (void)SvIOK_only(dstr);
2487 SvIVX(dstr) = SvIVX(sstr);
2500 sv_upgrade(dstr, SVt_NV);
2505 sv_upgrade(dstr, SVt_PVNV);
2508 SvNVX(dstr) = SvNVX(sstr);
2509 (void)SvNOK_only(dstr);
2517 sv_upgrade(dstr, SVt_RV);
2518 else if (dtype == SVt_PVGV &&
2519 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2522 if (GvIMPORTED(dstr) != GVf_IMPORTED
2523 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2525 GvIMPORTED_on(dstr);
2536 sv_upgrade(dstr, SVt_PV);
2539 if (dtype < SVt_PVIV)
2540 sv_upgrade(dstr, SVt_PVIV);
2543 if (dtype < SVt_PVNV)
2544 sv_upgrade(dstr, SVt_PVNV);
2551 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2552 PL_op_name[PL_op->op_type]);
2554 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2558 if (dtype <= SVt_PVGV) {
2560 if (dtype != SVt_PVGV) {
2561 char *name = GvNAME(sstr);
2562 STRLEN len = GvNAMELEN(sstr);
2563 sv_upgrade(dstr, SVt_PVGV);
2564 sv_magic(dstr, dstr, '*', name, len);
2565 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2566 GvNAME(dstr) = savepvn(name, len);
2567 GvNAMELEN(dstr) = len;
2568 SvFAKE_on(dstr); /* can coerce to non-glob */
2570 /* ahem, death to those who redefine active sort subs */
2571 else if (PL_curstackinfo->si_type == PERLSI_SORT
2572 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2573 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2575 (void)SvOK_off(dstr);
2576 GvINTRO_off(dstr); /* one-shot flag */
2578 GvGP(dstr) = gp_ref(GvGP(sstr));
2580 if (GvIMPORTED(dstr) != GVf_IMPORTED
2581 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2583 GvIMPORTED_on(dstr);
2591 if (SvGMAGICAL(sstr)) {
2593 if (SvTYPE(sstr) != stype) {
2594 stype = SvTYPE(sstr);
2595 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2599 if (stype == SVt_PVLV)
2600 (void)SvUPGRADE(dstr, SVt_PVNV);
2602 (void)SvUPGRADE(dstr, stype);
2605 sflags = SvFLAGS(sstr);
2607 if (sflags & SVf_ROK) {
2608 if (dtype >= SVt_PV) {
2609 if (dtype == SVt_PVGV) {
2610 SV *sref = SvREFCNT_inc(SvRV(sstr));
2612 int intro = GvINTRO(dstr);
2617 GvINTRO_off(dstr); /* one-shot flag */
2618 Newz(602,gp, 1, GP);
2619 GvGP(dstr) = gp_ref(gp);
2620 GvSV(dstr) = NEWSV(72,0);
2621 GvLINE(dstr) = CopLINE(PL_curcop);
2622 GvEGV(dstr) = (GV*)dstr;
2625 switch (SvTYPE(sref)) {
2628 SAVESPTR(GvAV(dstr));
2630 dref = (SV*)GvAV(dstr);
2631 GvAV(dstr) = (AV*)sref;
2632 if (!GvIMPORTED_AV(dstr)
2633 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2635 GvIMPORTED_AV_on(dstr);
2640 SAVESPTR(GvHV(dstr));
2642 dref = (SV*)GvHV(dstr);
2643 GvHV(dstr) = (HV*)sref;
2644 if (!GvIMPORTED_HV(dstr)
2645 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2647 GvIMPORTED_HV_on(dstr);
2652 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2653 SvREFCNT_dec(GvCV(dstr));
2654 GvCV(dstr) = Nullcv;
2655 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2656 PL_sub_generation++;
2658 SAVESPTR(GvCV(dstr));
2661 dref = (SV*)GvCV(dstr);
2662 if (GvCV(dstr) != (CV*)sref) {
2663 CV* cv = GvCV(dstr);
2665 if (!GvCVGEN((GV*)dstr) &&
2666 (CvROOT(cv) || CvXSUB(cv)))
2668 SV *const_sv = cv_const_sv(cv);
2669 bool const_changed = TRUE;
2671 const_changed = sv_cmp(const_sv,
2672 op_const_sv(CvSTART((CV*)sref),
2674 /* ahem, death to those who redefine
2675 * active sort subs */
2676 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2677 PL_sortcop == CvSTART(cv))
2679 "Can't redefine active sort subroutine %s",
2680 GvENAME((GV*)dstr));
2681 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2682 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2683 "Constant subroutine %s redefined"
2684 : "Subroutine %s redefined",
2685 GvENAME((GV*)dstr));
2687 cv_ckproto(cv, (GV*)dstr,
2688 SvPOK(sref) ? SvPVX(sref) : Nullch);
2690 GvCV(dstr) = (CV*)sref;
2691 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2692 GvASSUMECV_on(dstr);
2693 PL_sub_generation++;
2695 if (!GvIMPORTED_CV(dstr)
2696 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2698 GvIMPORTED_CV_on(dstr);
2703 SAVESPTR(GvIOp(dstr));
2705 dref = (SV*)GvIOp(dstr);
2706 GvIOp(dstr) = (IO*)sref;
2710 SAVESPTR(GvSV(dstr));
2712 dref = (SV*)GvSV(dstr);
2714 if (!GvIMPORTED_SV(dstr)
2715 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2717 GvIMPORTED_SV_on(dstr);
2729 (void)SvOOK_off(dstr); /* backoff */
2731 Safefree(SvPVX(dstr));
2732 SvLEN(dstr)=SvCUR(dstr)=0;
2735 (void)SvOK_off(dstr);
2736 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2738 if (sflags & SVp_NOK) {
2740 SvNVX(dstr) = SvNVX(sstr);
2742 if (sflags & SVp_IOK) {
2743 (void)SvIOK_on(dstr);
2744 SvIVX(dstr) = SvIVX(sstr);
2745 if (sflags & SVf_IVisUV)
2748 if (SvAMAGIC(sstr)) {
2752 else if (sflags & SVp_POK) {
2755 * Check to see if we can just swipe the string. If so, it's a
2756 * possible small lose on short strings, but a big win on long ones.
2757 * It might even be a win on short strings if SvPVX(dstr)
2758 * has to be allocated and SvPVX(sstr) has to be freed.
2761 if (SvTEMP(sstr) && /* slated for free anyway? */
2762 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2763 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2765 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2767 SvFLAGS(dstr) &= ~SVf_OOK;
2768 Safefree(SvPVX(dstr) - SvIVX(dstr));
2770 else if (SvLEN(dstr))
2771 Safefree(SvPVX(dstr));
2773 (void)SvPOK_only(dstr);
2774 SvPV_set(dstr, SvPVX(sstr));
2775 SvLEN_set(dstr, SvLEN(sstr));
2776 SvCUR_set(dstr, SvCUR(sstr));
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))) {
3108 sv_utf8_upgrade(dstr);
3109 sv_catpvn(dstr,s,len);
3116 =for apidoc sv_catsv_mg
3118 Like C<sv_catsv>, but also handles 'set' magic.
3124 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3126 sv_catsv(dstr,sstr);
3131 =for apidoc sv_catpv
3133 Concatenates the string onto the end of the string which is in the SV.
3134 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3140 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3142 register STRLEN len;
3148 junk = SvPV_force(sv, tlen);
3150 SvGROW(sv, tlen + len + 1);
3153 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3155 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3160 =for apidoc sv_catpv_mg
3162 Like C<sv_catpv>, but also handles 'set' magic.
3168 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3175 Perl_newSV(pTHX_ STRLEN len)
3181 sv_upgrade(sv, SVt_PV);
3182 SvGROW(sv, len + 1);
3187 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3190 =for apidoc sv_magic
3192 Adds magic to an SV.
3198 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3202 if (SvREADONLY(sv)) {
3204 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3205 Perl_croak(aTHX_ PL_no_modify);
3207 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3208 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3215 (void)SvUPGRADE(sv, SVt_PVMG);
3217 Newz(702,mg, 1, MAGIC);
3218 mg->mg_moremagic = SvMAGIC(sv);
3221 if (!obj || obj == sv || how == '#' || how == 'r')
3225 mg->mg_obj = SvREFCNT_inc(obj);
3226 mg->mg_flags |= MGf_REFCOUNTED;
3229 mg->mg_len = namlen;
3232 mg->mg_ptr = savepvn(name, namlen);
3233 else if (namlen == HEf_SVKEY)
3234 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3238 mg->mg_virtual = &PL_vtbl_sv;
3241 mg->mg_virtual = &PL_vtbl_amagic;
3244 mg->mg_virtual = &PL_vtbl_amagicelem;
3250 mg->mg_virtual = &PL_vtbl_bm;
3253 mg->mg_virtual = &PL_vtbl_regdata;
3256 mg->mg_virtual = &PL_vtbl_regdatum;
3259 mg->mg_virtual = &PL_vtbl_env;
3262 mg->mg_virtual = &PL_vtbl_fm;
3265 mg->mg_virtual = &PL_vtbl_envelem;
3268 mg->mg_virtual = &PL_vtbl_mglob;
3271 mg->mg_virtual = &PL_vtbl_isa;
3274 mg->mg_virtual = &PL_vtbl_isaelem;
3277 mg->mg_virtual = &PL_vtbl_nkeys;
3284 mg->mg_virtual = &PL_vtbl_dbline;
3288 mg->mg_virtual = &PL_vtbl_mutex;
3290 #endif /* USE_THREADS */
3291 #ifdef USE_LOCALE_COLLATE
3293 mg->mg_virtual = &PL_vtbl_collxfrm;
3295 #endif /* USE_LOCALE_COLLATE */
3297 mg->mg_virtual = &PL_vtbl_pack;
3301 mg->mg_virtual = &PL_vtbl_packelem;
3304 mg->mg_virtual = &PL_vtbl_regexp;
3307 mg->mg_virtual = &PL_vtbl_sig;
3310 mg->mg_virtual = &PL_vtbl_sigelem;
3313 mg->mg_virtual = &PL_vtbl_taint;
3317 mg->mg_virtual = &PL_vtbl_uvar;
3320 mg->mg_virtual = &PL_vtbl_vec;
3323 mg->mg_virtual = &PL_vtbl_substr;
3326 mg->mg_virtual = &PL_vtbl_defelem;
3329 mg->mg_virtual = &PL_vtbl_glob;
3332 mg->mg_virtual = &PL_vtbl_arylen;
3335 mg->mg_virtual = &PL_vtbl_pos;
3338 mg->mg_virtual = &PL_vtbl_backref;
3340 case '~': /* Reserved for use by extensions not perl internals. */
3341 /* Useful for attaching extension internal data to perl vars. */
3342 /* Note that multiple extensions may clash if magical scalars */
3343 /* etc holding private data from one are passed to another. */
3347 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3351 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3355 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3359 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3362 for (mg = *mgp; mg; mg = *mgp) {
3363 if (mg->mg_type == type) {
3364 MGVTBL* vtbl = mg->mg_virtual;
3365 *mgp = mg->mg_moremagic;
3366 if (vtbl && vtbl->svt_free)
3367 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3368 if (mg->mg_ptr && mg->mg_type != 'g')
3369 if (mg->mg_len >= 0)
3370 Safefree(mg->mg_ptr);
3371 else if (mg->mg_len == HEf_SVKEY)
3372 SvREFCNT_dec((SV*)mg->mg_ptr);
3373 if (mg->mg_flags & MGf_REFCOUNTED)
3374 SvREFCNT_dec(mg->mg_obj);
3378 mgp = &mg->mg_moremagic;
3382 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3389 Perl_sv_rvweaken(pTHX_ SV *sv)
3392 if (!SvOK(sv)) /* let undefs pass */
3395 Perl_croak(aTHX_ "Can't weaken a nonreference");
3396 else if (SvWEAKREF(sv)) {
3398 if (ckWARN(WARN_MISC))
3399 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3403 sv_add_backref(tsv, sv);
3410 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3414 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3415 av = (AV*)mg->mg_obj;
3418 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3419 SvREFCNT_dec(av); /* for sv_magic */
3425 S_sv_del_backref(pTHX_ SV *sv)
3432 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3433 Perl_croak(aTHX_ "panic: del_backref");
3434 av = (AV *)mg->mg_obj;
3439 svp[i] = &PL_sv_undef; /* XXX */
3446 =for apidoc sv_insert
3448 Inserts a string at the specified offset/length within the SV. Similar to
3449 the Perl substr() function.
3455 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3459 register char *midend;
3460 register char *bigend;
3466 Perl_croak(aTHX_ "Can't modify non-existent substring");
3467 SvPV_force(bigstr, curlen);
3468 if (offset + len > curlen) {
3469 SvGROW(bigstr, offset+len+1);
3470 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3471 SvCUR_set(bigstr, offset+len);
3475 i = littlelen - len;
3476 if (i > 0) { /* string might grow */
3477 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3478 mid = big + offset + len;
3479 midend = bigend = big + SvCUR(bigstr);
3482 while (midend > mid) /* shove everything down */
3483 *--bigend = *--midend;
3484 Move(little,big+offset,littlelen,char);
3490 Move(little,SvPVX(bigstr)+offset,len,char);
3495 big = SvPVX(bigstr);
3498 bigend = big + SvCUR(bigstr);
3500 if (midend > bigend)
3501 Perl_croak(aTHX_ "panic: sv_insert");
3503 if (mid - big > bigend - midend) { /* faster to shorten from end */
3505 Move(little, mid, littlelen,char);
3508 i = bigend - midend;
3510 Move(midend, mid, i,char);
3514 SvCUR_set(bigstr, mid - big);
3517 else if ((i = mid - big)) { /* faster from front */
3518 midend -= littlelen;
3520 sv_chop(bigstr,midend-i);
3525 Move(little, mid, littlelen,char);
3527 else if (littlelen) {
3528 midend -= littlelen;
3529 sv_chop(bigstr,midend);
3530 Move(little,midend,littlelen,char);
3533 sv_chop(bigstr,midend);
3538 /* make sv point to what nstr did */
3541 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3544 U32 refcnt = SvREFCNT(sv);
3545 SV_CHECK_THINKFIRST(sv);
3546 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3547 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3548 if (SvMAGICAL(sv)) {
3552 sv_upgrade(nsv, SVt_PVMG);
3553 SvMAGIC(nsv) = SvMAGIC(sv);
3554 SvFLAGS(nsv) |= SvMAGICAL(sv);
3560 assert(!SvREFCNT(sv));
3561 StructCopy(nsv,sv,SV);
3562 SvREFCNT(sv) = refcnt;
3563 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3568 Perl_sv_clear(pTHX_ register SV *sv)
3572 assert(SvREFCNT(sv) == 0);
3576 if (PL_defstash) { /* Still have a symbol table? */
3581 Zero(&tmpref, 1, SV);
3582 sv_upgrade(&tmpref, SVt_RV);
3584 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3585 SvREFCNT(&tmpref) = 1;
3588 stash = SvSTASH(sv);
3589 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3592 PUSHSTACKi(PERLSI_DESTROY);
3593 SvRV(&tmpref) = SvREFCNT_inc(sv);
3598 call_sv((SV*)GvCV(destructor),
3599 G_DISCARD|G_EVAL|G_KEEPERR);
3605 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3607 del_XRV(SvANY(&tmpref));
3610 if (PL_in_clean_objs)
3611 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3613 /* DESTROY gave object new lease on life */
3619 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3620 SvOBJECT_off(sv); /* Curse the object. */
3621 if (SvTYPE(sv) != SVt_PVIO)
3622 --PL_sv_objcount; /* XXX Might want something more general */
3625 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3628 switch (SvTYPE(sv)) {
3631 IoIFP(sv) != PerlIO_stdin() &&
3632 IoIFP(sv) != PerlIO_stdout() &&
3633 IoIFP(sv) != PerlIO_stderr())
3635 io_close((IO*)sv, FALSE);
3637 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3638 PerlDir_close(IoDIRP(sv));
3639 IoDIRP(sv) = (DIR*)NULL;
3640 Safefree(IoTOP_NAME(sv));
3641 Safefree(IoFMT_NAME(sv));
3642 Safefree(IoBOTTOM_NAME(sv));
3657 SvREFCNT_dec(LvTARG(sv));
3661 Safefree(GvNAME(sv));
3662 /* cannot decrease stash refcount yet, as we might recursively delete
3663 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3664 of stash until current sv is completely gone.
3665 -- JohnPC, 27 Mar 1998 */
3666 stash = GvSTASH(sv);
3672 (void)SvOOK_off(sv);
3680 SvREFCNT_dec(SvRV(sv));
3682 else if (SvPVX(sv) && SvLEN(sv))
3683 Safefree(SvPVX(sv));
3693 switch (SvTYPE(sv)) {
3709 del_XPVIV(SvANY(sv));
3712 del_XPVNV(SvANY(sv));
3715 del_XPVMG(SvANY(sv));
3718 del_XPVLV(SvANY(sv));
3721 del_XPVAV(SvANY(sv));
3724 del_XPVHV(SvANY(sv));
3727 del_XPVCV(SvANY(sv));
3730 del_XPVGV(SvANY(sv));
3731 /* code duplication for increased performance. */
3732 SvFLAGS(sv) &= SVf_BREAK;
3733 SvFLAGS(sv) |= SVTYPEMASK;
3734 /* decrease refcount of the stash that owns this GV, if any */
3736 SvREFCNT_dec(stash);
3737 return; /* not break, SvFLAGS reset already happened */
3739 del_XPVBM(SvANY(sv));
3742 del_XPVFM(SvANY(sv));
3745 del_XPVIO(SvANY(sv));
3748 SvFLAGS(sv) &= SVf_BREAK;
3749 SvFLAGS(sv) |= SVTYPEMASK;
3753 Perl_sv_newref(pTHX_ SV *sv)
3756 ATOMIC_INC(SvREFCNT(sv));
3761 Perl_sv_free(pTHX_ SV *sv)
3764 int refcount_is_zero;
3768 if (SvREFCNT(sv) == 0) {
3769 if (SvFLAGS(sv) & SVf_BREAK)
3771 if (PL_in_clean_all) /* All is fair */
3773 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3774 /* make sure SvREFCNT(sv)==0 happens very seldom */
3775 SvREFCNT(sv) = (~(U32)0)/2;
3778 if (ckWARN_d(WARN_INTERNAL))
3779 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3782 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3783 if (!refcount_is_zero)
3787 if (ckWARN_d(WARN_DEBUGGING))
3788 Perl_warner(aTHX_ WARN_DEBUGGING,
3789 "Attempt to free temp prematurely: SV 0x%"UVxf,
3794 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3795 /* make sure SvREFCNT(sv)==0 happens very seldom */
3796 SvREFCNT(sv) = (~(U32)0)/2;
3807 Returns the length of the string in the SV. See also C<SvCUR>.
3813 Perl_sv_len(pTHX_ register SV *sv)
3822 len = mg_length(sv);
3824 junk = SvPV(sv, len);
3829 Perl_sv_len_utf8(pTHX_ register SV *sv)
3840 len = mg_length(sv);
3843 s = (U8*)SvPV(sv, len);
3854 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3859 I32 uoffset = *offsetp;
3865 start = s = (U8*)SvPV(sv, len);
3867 while (s < send && uoffset--)
3871 *offsetp = s - start;
3875 while (s < send && ulen--)
3885 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3894 s = (U8*)SvPV(sv, len);
3896 Perl_croak(aTHX_ "panic: bad byte offset");
3897 send = s + *offsetp;
3905 if (ckWARN_d(WARN_UTF8))
3906 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3916 Returns a boolean indicating whether the strings in the two SVs are
3923 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3935 pv1 = SvPV(str1, cur1);
3940 if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3942 sv_utf8_upgrade(str2);
3945 sv_utf8_upgrade(str1);
3949 pv2 = SvPV(str2, cur2);
3954 return memEQ(pv1, pv2, cur1);
3960 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3961 string in C<sv1> is less than, equal to, or greater than the string in
3968 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3975 pv1 = SvPV(str1, cur1);
3983 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3984 /* must upgrade other to UTF8 first */
3986 sv_utf8_upgrade(str2);
3989 sv_utf8_upgrade(str1);
3990 /* refresh pointer and length */
3999 pv2 = sv_2pv(str2, &cur2);
4007 return cur2 ? -1 : 0;
4012 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4015 return retval < 0 ? -1 : 1;
4020 return cur1 < cur2 ? -1 : 1;
4024 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4026 #ifdef USE_LOCALE_COLLATE
4032 if (PL_collation_standard)
4036 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4038 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4040 if (!pv1 || !len1) {
4051 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4054 return retval < 0 ? -1 : 1;
4057 * When the result of collation is equality, that doesn't mean
4058 * that there are no differences -- some locales exclude some
4059 * characters from consideration. So to avoid false equalities,
4060 * we use the raw string as a tiebreaker.
4066 #endif /* USE_LOCALE_COLLATE */
4068 return sv_cmp(sv1, sv2);
4071 #ifdef USE_LOCALE_COLLATE
4073 * Any scalar variable may carry an 'o' magic that contains the
4074 * scalar data of the variable transformed to such a format that
4075 * a normal memory comparison can be used to compare the data
4076 * according to the locale settings.
4079 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4083 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4084 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4089 Safefree(mg->mg_ptr);
4091 if ((xf = mem_collxfrm(s, len, &xlen))) {
4092 if (SvREADONLY(sv)) {
4095 return xf + sizeof(PL_collation_ix);
4098 sv_magic(sv, 0, 'o', 0, 0);
4099 mg = mg_find(sv, 'o');
4112 if (mg && mg->mg_ptr) {
4114 return mg->mg_ptr + sizeof(PL_collation_ix);
4122 #endif /* USE_LOCALE_COLLATE */
4125 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4130 register STDCHAR rslast;
4131 register STDCHAR *bp;
4135 SV_CHECK_THINKFIRST(sv);
4136 (void)SvUPGRADE(sv, SVt_PV);
4140 if (RsSNARF(PL_rs)) {
4144 else if (RsRECORD(PL_rs)) {
4145 I32 recsize, bytesread;
4148 /* Grab the size of the record we're getting */
4149 recsize = SvIV(SvRV(PL_rs));
4150 (void)SvPOK_only(sv); /* Validate pointer */
4151 buffer = SvGROW(sv, recsize + 1);
4154 /* VMS wants read instead of fread, because fread doesn't respect */
4155 /* RMS record boundaries. This is not necessarily a good thing to be */
4156 /* doing, but we've got no other real choice */
4157 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4159 bytesread = PerlIO_read(fp, buffer, recsize);
4161 SvCUR_set(sv, bytesread);
4162 buffer[bytesread] = '\0';
4163 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4165 else if (RsPARA(PL_rs)) {
4170 rsptr = SvPV(PL_rs, rslen);
4171 rslast = rslen ? rsptr[rslen - 1] : '\0';
4173 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4174 do { /* to make sure file boundaries work right */
4177 i = PerlIO_getc(fp);
4181 PerlIO_ungetc(fp,i);
4187 /* See if we know enough about I/O mechanism to cheat it ! */
4189 /* This used to be #ifdef test - it is made run-time test for ease
4190 of abstracting out stdio interface. One call should be cheap
4191 enough here - and may even be a macro allowing compile
4195 if (PerlIO_fast_gets(fp)) {
4198 * We're going to steal some values from the stdio struct
4199 * and put EVERYTHING in the innermost loop into registers.
4201 register STDCHAR *ptr;
4205 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4206 /* An ungetc()d char is handled separately from the regular
4207 * buffer, so we getc() it back out and stuff it in the buffer.
4209 i = PerlIO_getc(fp);
4210 if (i == EOF) return 0;
4211 *(--((*fp)->_ptr)) = (unsigned char) i;
4215 /* Here is some breathtakingly efficient cheating */
4217 cnt = PerlIO_get_cnt(fp); /* get count into register */
4218 (void)SvPOK_only(sv); /* validate pointer */
4219 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4220 if (cnt > 80 && SvLEN(sv) > append) {
4221 shortbuffered = cnt - SvLEN(sv) + append + 1;
4222 cnt -= shortbuffered;
4226 /* remember that cnt can be negative */
4227 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4232 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4233 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4234 DEBUG_P(PerlIO_printf(Perl_debug_log,
4235 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4236 DEBUG_P(PerlIO_printf(Perl_debug_log,
4237 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4238 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4239 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4244 while (cnt > 0) { /* this | eat */
4246 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4247 goto thats_all_folks; /* screams | sed :-) */
4251 Copy(ptr, bp, cnt, char); /* this | eat */
4252 bp += cnt; /* screams | dust */
4253 ptr += cnt; /* louder | sed :-) */
4258 if (shortbuffered) { /* oh well, must extend */
4259 cnt = shortbuffered;
4261 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4263 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4264 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4268 DEBUG_P(PerlIO_printf(Perl_debug_log,
4269 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4270 PTR2UV(ptr),(long)cnt));
4271 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4272 DEBUG_P(PerlIO_printf(Perl_debug_log,
4273 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4274 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4275 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4276 /* This used to call 'filbuf' in stdio form, but as that behaves like
4277 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4278 another abstraction. */
4279 i = PerlIO_getc(fp); /* get more characters */
4280 DEBUG_P(PerlIO_printf(Perl_debug_log,
4281 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4282 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4283 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4284 cnt = PerlIO_get_cnt(fp);
4285 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4286 DEBUG_P(PerlIO_printf(Perl_debug_log,
4287 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4289 if (i == EOF) /* all done for ever? */
4290 goto thats_really_all_folks;
4292 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4294 SvGROW(sv, bpx + cnt + 2);
4295 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4297 *bp++ = i; /* store character from PerlIO_getc */
4299 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4300 goto thats_all_folks;
4304 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4305 memNE((char*)bp - rslen, rsptr, rslen))
4306 goto screamer; /* go back to the fray */
4307 thats_really_all_folks:
4309 cnt += shortbuffered;
4310 DEBUG_P(PerlIO_printf(Perl_debug_log,
4311 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4312 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4313 DEBUG_P(PerlIO_printf(Perl_debug_log,
4314 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4315 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4316 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4318 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4319 DEBUG_P(PerlIO_printf(Perl_debug_log,
4320 "Screamer: done, len=%ld, string=|%.*s|\n",
4321 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4326 /*The big, slow, and stupid way */
4329 /* Need to work around EPOC SDK features */
4330 /* On WINS: MS VC5 generates calls to _chkstk, */
4331 /* if a `large' stack frame is allocated */
4332 /* gcc on MARM does not generate calls like these */
4338 register STDCHAR *bpe = buf + sizeof(buf);
4340 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4341 ; /* keep reading */
4345 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4346 /* Accomodate broken VAXC compiler, which applies U8 cast to
4347 * both args of ?: operator, causing EOF to change into 255
4349 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4353 sv_catpvn(sv, (char *) buf, cnt);
4355 sv_setpvn(sv, (char *) buf, cnt);
4357 if (i != EOF && /* joy */
4359 SvCUR(sv) < rslen ||
4360 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4364 * If we're reading from a TTY and we get a short read,
4365 * indicating that the user hit his EOF character, we need
4366 * to notice it now, because if we try to read from the TTY
4367 * again, the EOF condition will disappear.
4369 * The comparison of cnt to sizeof(buf) is an optimization
4370 * that prevents unnecessary calls to feof().
4374 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4379 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4380 while (i != EOF) { /* to make sure file boundaries work right */
4381 i = PerlIO_getc(fp);
4383 PerlIO_ungetc(fp,i);
4389 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4396 Auto-increment of the value in the SV.
4402 Perl_sv_inc(pTHX_ register SV *sv)
4411 if (SvTHINKFIRST(sv)) {
4412 if (SvREADONLY(sv)) {
4414 if (PL_curcop != &PL_compiling)
4415 Perl_croak(aTHX_ PL_no_modify);
4419 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4421 i = PTR2IV(SvRV(sv));
4426 flags = SvFLAGS(sv);
4427 if (flags & SVp_NOK) {
4428 (void)SvNOK_only(sv);
4432 if (flags & SVp_IOK) {
4434 if (SvUVX(sv) == UV_MAX)
4435 sv_setnv(sv, (NV)UV_MAX + 1.0);
4437 (void)SvIOK_only_UV(sv);
4440 if (SvIVX(sv) == IV_MAX)
4441 sv_setnv(sv, (NV)IV_MAX + 1.0);
4443 (void)SvIOK_only(sv);
4449 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4450 if ((flags & SVTYPEMASK) < SVt_PVNV)
4451 sv_upgrade(sv, SVt_NV);
4453 (void)SvNOK_only(sv);
4457 while (isALPHA(*d)) d++;
4458 while (isDIGIT(*d)) d++;
4460 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4464 while (d >= SvPVX(sv)) {
4472 /* MKS: The original code here died if letters weren't consecutive.
4473 * at least it didn't have to worry about non-C locales. The
4474 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4475 * arranged in order (although not consecutively) and that only
4476 * [A-Za-z] are accepted by isALPHA in the C locale.
4478 if (*d != 'z' && *d != 'Z') {
4479 do { ++*d; } while (!isALPHA(*d));
4482 *(d--) -= 'z' - 'a';
4487 *(d--) -= 'z' - 'a' + 1;
4491 /* oh,oh, the number grew */
4492 SvGROW(sv, SvCUR(sv) + 2);
4494 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4505 Auto-decrement of the value in the SV.
4511 Perl_sv_dec(pTHX_ register SV *sv)
4519 if (SvTHINKFIRST(sv)) {
4520 if (SvREADONLY(sv)) {
4522 if (PL_curcop != &PL_compiling)
4523 Perl_croak(aTHX_ PL_no_modify);
4527 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4529 i = PTR2IV(SvRV(sv));
4534 flags = SvFLAGS(sv);
4535 if (flags & SVp_NOK) {
4537 (void)SvNOK_only(sv);
4540 if (flags & SVp_IOK) {
4542 if (SvUVX(sv) == 0) {
4543 (void)SvIOK_only(sv);
4547 (void)SvIOK_only_UV(sv);
4551 if (SvIVX(sv) == IV_MIN)
4552 sv_setnv(sv, (NV)IV_MIN - 1.0);
4554 (void)SvIOK_only(sv);
4560 if (!(flags & SVp_POK)) {
4561 if ((flags & SVTYPEMASK) < SVt_PVNV)
4562 sv_upgrade(sv, SVt_NV);
4564 (void)SvNOK_only(sv);
4567 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4571 =for apidoc sv_mortalcopy
4573 Creates a new SV which is a copy of the original SV. The new SV is marked
4579 /* Make a string that will exist for the duration of the expression
4580 * evaluation. Actually, it may have to last longer than that, but
4581 * hopefully we won't free it until it has been assigned to a
4582 * permanent location. */
4585 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4591 sv_setsv(sv,oldstr);
4593 PL_tmps_stack[++PL_tmps_ix] = sv;
4599 =for apidoc sv_newmortal
4601 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4607 Perl_sv_newmortal(pTHX)
4613 SvFLAGS(sv) = SVs_TEMP;
4615 PL_tmps_stack[++PL_tmps_ix] = sv;
4620 =for apidoc sv_2mortal
4622 Marks an SV as mortal. The SV will be destroyed when the current context
4628 /* same thing without the copying */
4631 Perl_sv_2mortal(pTHX_ register SV *sv)
4636 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4639 PL_tmps_stack[++PL_tmps_ix] = sv;
4647 Creates a new SV and copies a string into it. The reference count for the
4648 SV is set to 1. If C<len> is zero, Perl will compute the length using
4649 strlen(). For efficiency, consider using C<newSVpvn> instead.
4655 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4662 sv_setpvn(sv,s,len);
4667 =for apidoc newSVpvn
4669 Creates a new SV and copies a string into it. The reference count for the
4670 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4671 string. You are responsible for ensuring that the source string is at least
4678 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4683 sv_setpvn(sv,s,len);
4687 #if defined(PERL_IMPLICIT_CONTEXT)
4689 Perl_newSVpvf_nocontext(const char* pat, ...)
4694 va_start(args, pat);
4695 sv = vnewSVpvf(pat, &args);
4702 =for apidoc newSVpvf
4704 Creates a new SV an initialize it with the string formatted like
4711 Perl_newSVpvf(pTHX_ const char* pat, ...)
4715 va_start(args, pat);
4716 sv = vnewSVpvf(pat, &args);
4722 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4726 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4733 Creates a new SV and copies a floating point value into it.
4734 The reference count for the SV is set to 1.
4740 Perl_newSVnv(pTHX_ NV n)
4752 Creates a new SV and copies an integer into it. The reference count for the
4759 Perl_newSViv(pTHX_ IV i)
4771 Creates a new SV and copies an unsigned integer into it.
4772 The reference count for the SV is set to 1.
4778 Perl_newSVuv(pTHX_ UV u)
4788 =for apidoc newRV_noinc
4790 Creates an RV wrapper for an SV. The reference count for the original
4791 SV is B<not> incremented.
4797 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4803 sv_upgrade(sv, SVt_RV);
4810 /* newRV_inc is #defined to newRV in sv.h */
4812 Perl_newRV(pTHX_ SV *tmpRef)
4814 return newRV_noinc(SvREFCNT_inc(tmpRef));
4820 Creates a new SV which is an exact duplicate of the original SV.
4825 /* make an exact duplicate of old */
4828 Perl_newSVsv(pTHX_ register SV *old)
4835 if (SvTYPE(old) == SVTYPEMASK) {
4836 if (ckWARN_d(WARN_INTERNAL))
4837 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4852 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4860 char todo[PERL_UCHAR_MAX+1];
4865 if (!*s) { /* reset ?? searches */
4866 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4867 pm->op_pmdynflags &= ~PMdf_USED;
4872 /* reset variables */
4874 if (!HvARRAY(stash))
4877 Zero(todo, 256, char);
4879 i = (unsigned char)*s;
4883 max = (unsigned char)*s++;
4884 for ( ; i <= max; i++) {
4887 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4888 for (entry = HvARRAY(stash)[i];
4890 entry = HeNEXT(entry))
4892 if (!todo[(U8)*HeKEY(entry)])
4894 gv = (GV*)HeVAL(entry);
4896 if (SvTHINKFIRST(sv)) {
4897 if (!SvREADONLY(sv) && SvROK(sv))
4902 if (SvTYPE(sv) >= SVt_PV) {
4904 if (SvPVX(sv) != Nullch)
4911 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4913 #ifndef VMS /* VMS has no environ array */
4915 environ[0] = Nullch;
4924 Perl_sv_2io(pTHX_ SV *sv)
4930 switch (SvTYPE(sv)) {
4938 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4942 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4944 return sv_2io(SvRV(sv));
4945 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4951 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4958 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4965 return *gvp = Nullgv, Nullcv;
4966 switch (SvTYPE(sv)) {
4986 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4987 tryAMAGICunDEREF(to_cv);
4990 if (SvTYPE(sv) == SVt_PVCV) {
4999 Perl_croak(aTHX_ "Not a subroutine reference");
5004 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5010 if (lref && !GvCVu(gv)) {
5013 tmpsv = NEWSV(704,0);
5014 gv_efullname3(tmpsv, gv, Nullch);
5015 /* XXX this is probably not what they think they're getting.
5016 * It has the same effect as "sub name;", i.e. just a forward
5018 newSUB(start_subparse(FALSE, 0),
5019 newSVOP(OP_CONST, 0, tmpsv),
5024 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5031 Perl_sv_true(pTHX_ register SV *sv)
5038 if ((tXpv = (XPV*)SvANY(sv)) &&
5039 (tXpv->xpv_cur > 1 ||
5040 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5047 return SvIVX(sv) != 0;
5050 return SvNVX(sv) != 0.0;
5052 return sv_2bool(sv);
5058 Perl_sv_iv(pTHX_ register SV *sv)
5062 return (IV)SvUVX(sv);
5069 Perl_sv_uv(pTHX_ register SV *sv)
5074 return (UV)SvIVX(sv);
5080 Perl_sv_nv(pTHX_ register SV *sv)
5088 Perl_sv_pv(pTHX_ SV *sv)
5095 return sv_2pv(sv, &n_a);
5099 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5105 return sv_2pv(sv, lp);
5109 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5113 if (SvTHINKFIRST(sv) && !SvROK(sv))
5114 sv_force_normal(sv);
5120 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5122 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5123 PL_op_name[PL_op->op_type]);
5127 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5132 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5133 SvGROW(sv, len + 1);
5134 Move(s,SvPVX(sv),len,char);
5139 SvPOK_on(sv); /* validate pointer */
5141 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5142 PTR2UV(sv),SvPVX(sv)));
5149 Perl_sv_pvbyte(pTHX_ SV *sv)
5155 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5157 return sv_pvn(sv,lp);
5161 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5163 return sv_pvn_force(sv,lp);
5167 Perl_sv_pvutf8(pTHX_ SV *sv)
5169 sv_utf8_upgrade(sv);
5174 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5176 sv_utf8_upgrade(sv);
5177 return sv_pvn(sv,lp);
5181 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5183 sv_utf8_upgrade(sv);
5184 return sv_pvn_force(sv,lp);
5188 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5190 if (ob && SvOBJECT(sv))
5191 return HvNAME(SvSTASH(sv));
5193 switch (SvTYPE(sv)) {
5207 case SVt_PVLV: return "LVALUE";
5208 case SVt_PVAV: return "ARRAY";
5209 case SVt_PVHV: return "HASH";
5210 case SVt_PVCV: return "CODE";
5211 case SVt_PVGV: return "GLOB";
5212 case SVt_PVFM: return "FORMAT";
5213 case SVt_PVIO: return "IO";
5214 default: return "UNKNOWN";
5220 =for apidoc sv_isobject
5222 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5223 object. If the SV is not an RV, or if the object is not blessed, then this
5230 Perl_sv_isobject(pTHX_ SV *sv)
5247 Returns a boolean indicating whether the SV is blessed into the specified
5248 class. This does not check for subtypes; use C<sv_derived_from> to verify
5249 an inheritance relationship.
5255 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5267 return strEQ(HvNAME(SvSTASH(sv)), name);
5273 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5274 it will be upgraded to one. If C<classname> is non-null then the new SV will
5275 be blessed in the specified package. The new SV is returned and its
5276 reference count is 1.
5282 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5289 SV_CHECK_THINKFIRST(rv);
5292 if (SvTYPE(rv) < SVt_RV)
5293 sv_upgrade(rv, SVt_RV);
5300 HV* stash = gv_stashpv(classname, TRUE);
5301 (void)sv_bless(rv, stash);
5307 =for apidoc sv_setref_pv
5309 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5310 argument will be upgraded to an RV. That RV will be modified to point to
5311 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5312 into the SV. The C<classname> argument indicates the package for the
5313 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5314 will be returned and will have a reference count of 1.
5316 Do not use with other Perl types such as HV, AV, SV, CV, because those
5317 objects will become corrupted by the pointer copy process.
5319 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5325 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5328 sv_setsv(rv, &PL_sv_undef);
5332 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5337 =for apidoc sv_setref_iv
5339 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5340 argument will be upgraded to an RV. That RV will be modified to point to
5341 the new SV. The C<classname> argument indicates the package for the
5342 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5343 will be returned and will have a reference count of 1.
5349 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5351 sv_setiv(newSVrv(rv,classname), iv);
5356 =for apidoc sv_setref_nv
5358 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5359 argument will be upgraded to an RV. That RV will be modified to point to
5360 the new SV. The C<classname> argument indicates the package for the
5361 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5362 will be returned and will have a reference count of 1.
5368 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5370 sv_setnv(newSVrv(rv,classname), nv);
5375 =for apidoc sv_setref_pvn
5377 Copies a string into a new SV, optionally blessing the SV. The length of the
5378 string must be specified with C<n>. The C<rv> argument will be upgraded to
5379 an RV. That RV will be modified to point to the new SV. The C<classname>
5380 argument indicates the package for the blessing. Set C<classname> to
5381 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5382 a reference count of 1.
5384 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5390 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5392 sv_setpvn(newSVrv(rv,classname), pv, n);
5397 =for apidoc sv_bless
5399 Blesses an SV into a specified package. The SV must be an RV. The package
5400 must be designated by its stash (see C<gv_stashpv()>). The reference count
5401 of the SV is unaffected.
5407 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5412 Perl_croak(aTHX_ "Can't bless non-reference value");
5414 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5415 if (SvREADONLY(tmpRef))
5416 Perl_croak(aTHX_ PL_no_modify);
5417 if (SvOBJECT(tmpRef)) {
5418 if (SvTYPE(tmpRef) != SVt_PVIO)
5420 SvREFCNT_dec(SvSTASH(tmpRef));
5423 SvOBJECT_on(tmpRef);
5424 if (SvTYPE(tmpRef) != SVt_PVIO)
5426 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5427 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5438 S_sv_unglob(pTHX_ SV *sv)
5442 assert(SvTYPE(sv) == SVt_PVGV);
5447 SvREFCNT_dec(GvSTASH(sv));
5448 GvSTASH(sv) = Nullhv;
5450 sv_unmagic(sv, '*');
5451 Safefree(GvNAME(sv));
5454 /* need to keep SvANY(sv) in the right arena */
5455 xpvmg = new_XPVMG();
5456 StructCopy(SvANY(sv), xpvmg, XPVMG);
5457 del_XPVGV(SvANY(sv));
5460 SvFLAGS(sv) &= ~SVTYPEMASK;
5461 SvFLAGS(sv) |= SVt_PVMG;
5465 =for apidoc sv_unref
5467 Unsets the RV status of the SV, and decrements the reference count of
5468 whatever was being referenced by the RV. This can almost be thought of
5469 as a reversal of C<newSVrv>. See C<SvROK_off>.
5475 Perl_sv_unref(pTHX_ SV *sv)
5479 if (SvWEAKREF(sv)) {
5487 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5490 sv_2mortal(rv); /* Schedule for freeing later */
5494 Perl_sv_taint(pTHX_ SV *sv)
5496 sv_magic((sv), Nullsv, 't', Nullch, 0);
5500 Perl_sv_untaint(pTHX_ SV *sv)
5502 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5503 MAGIC *mg = mg_find(sv, 't');
5510 Perl_sv_tainted(pTHX_ SV *sv)
5512 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5513 MAGIC *mg = mg_find(sv, 't');
5514 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5521 =for apidoc sv_setpviv
5523 Copies an integer into the given SV, also updating its string value.
5524 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5530 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5532 char buf[TYPE_CHARS(UV)];
5534 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5536 sv_setpvn(sv, ptr, ebuf - ptr);
5541 =for apidoc sv_setpviv_mg
5543 Like C<sv_setpviv>, but also handles 'set' magic.
5549 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5551 char buf[TYPE_CHARS(UV)];
5553 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5555 sv_setpvn(sv, ptr, ebuf - ptr);
5559 #if defined(PERL_IMPLICIT_CONTEXT)
5561 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5565 va_start(args, pat);
5566 sv_vsetpvf(sv, pat, &args);
5572 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5576 va_start(args, pat);
5577 sv_vsetpvf_mg(sv, pat, &args);
5583 =for apidoc sv_setpvf
5585 Processes its arguments like C<sprintf> and sets an SV to the formatted
5586 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5592 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5595 va_start(args, pat);
5596 sv_vsetpvf(sv, pat, &args);
5601 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5603 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5607 =for apidoc sv_setpvf_mg
5609 Like C<sv_setpvf>, but also handles 'set' magic.
5615 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5618 va_start(args, pat);
5619 sv_vsetpvf_mg(sv, pat, &args);
5624 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5626 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5630 #if defined(PERL_IMPLICIT_CONTEXT)
5632 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5636 va_start(args, pat);
5637 sv_vcatpvf(sv, pat, &args);
5642 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5646 va_start(args, pat);
5647 sv_vcatpvf_mg(sv, pat, &args);
5653 =for apidoc sv_catpvf
5655 Processes its arguments like C<sprintf> and appends the formatted output
5656 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5657 typically be called after calling this function to handle 'set' magic.
5663 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5666 va_start(args, pat);
5667 sv_vcatpvf(sv, pat, &args);
5672 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5674 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5678 =for apidoc sv_catpvf_mg
5680 Like C<sv_catpvf>, but also handles 'set' magic.
5686 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5689 va_start(args, pat);
5690 sv_vcatpvf_mg(sv, pat, &args);
5695 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5697 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5702 =for apidoc sv_vsetpvfn
5704 Works like C<vcatpvfn> but copies the text into the SV instead of
5711 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5713 sv_setpvn(sv, "", 0);
5714 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5718 =for apidoc sv_vcatpvfn
5720 Processes its arguments like C<vsprintf> and appends the formatted output
5721 to an SV. Uses an array of SVs if the C style variable argument list is
5722 missing (NULL). When running with taint checks enabled, indicates via
5723 C<maybe_tainted> if results are untrustworthy (often due to the use of
5730 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5738 static char nullstr[] = "(null)";
5741 /* no matter what, this is a string now */
5742 (void)SvPV_force(sv, origlen);
5744 /* special-case "", "%s", and "%_" */
5747 if (patlen == 2 && pat[0] == '%') {
5751 char *s = va_arg(*args, char*);
5752 sv_catpv(sv, s ? s : nullstr);
5754 else if (svix < svmax) {
5755 sv_catsv(sv, *svargs);
5756 if (DO_UTF8(*svargs))
5762 argsv = va_arg(*args, SV*);
5763 sv_catsv(sv, argsv);
5768 /* See comment on '_' below */
5773 patend = (char*)pat + patlen;
5774 for (p = (char*)pat; p < patend; p = q) {
5777 bool vectorize = FALSE;
5784 bool has_precis = FALSE;
5786 bool is_utf = FALSE;
5789 U8 utf8buf[UTF8_MAXLEN];
5790 STRLEN esignlen = 0;
5792 char *eptr = Nullch;
5794 /* Times 4: a decimal digit takes more than 3 binary digits.
5795 * NV_DIG: mantissa takes than many decimal digits.
5796 * Plus 32: Playing safe. */
5797 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5798 /* large enough for "%#.#f" --chip */
5799 /* what about long double NVs? --jhi */
5802 U8 *vecstr = Null(U8*);
5814 STRLEN dotstrlen = 1;
5816 for (q = p; q < patend && *q != '%'; ++q) ;
5818 sv_catpvn(sv, p, q - p);
5847 case '*': /* printf("%*vX",":",$ipv6addr) */
5852 vecsv = va_arg(*args, SV*);
5853 else if (svix < svmax)
5854 vecsv = svargs[svix++];
5857 dotstr = SvPVx(vecsv,dotstrlen);
5866 vecsv = va_arg(*args, SV*);
5867 else if (svix < svmax)
5868 vecsv = svargs[svix++];
5874 vecstr = (U8*)SvPVx(vecsv,veclen);
5875 utf = DO_UTF8(vecsv);
5887 case '1': case '2': case '3':
5888 case '4': case '5': case '6':
5889 case '7': case '8': case '9':
5892 width = width * 10 + (*q++ - '0');
5897 i = va_arg(*args, int);
5899 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5901 width = (i < 0) ? -i : i;
5912 i = va_arg(*args, int);
5914 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5915 precis = (i < 0) ? 0 : i;
5921 precis = precis * 10 + (*q++ - '0');
5938 if (*(q + 1) == 'l') { /* lld */
5965 uv = va_arg(*args, int);
5967 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5968 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5969 eptr = (char*)utf8buf;
5970 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5982 eptr = va_arg(*args, char*);
5984 #ifdef MACOS_TRADITIONAL
5985 /* On MacOS, %#s format is used for Pascal strings */
5990 elen = strlen(eptr);
5993 elen = sizeof nullstr - 1;
5996 else if (svix < svmax) {
5997 argsv = svargs[svix++];
5998 eptr = SvPVx(argsv, elen);
5999 if (DO_UTF8(argsv)) {
6000 if (has_precis && precis < elen) {
6002 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6005 if (width) { /* fudge width (can't fudge elen) */
6006 width += elen - sv_len_utf8(argsv);
6015 * The "%_" hack might have to be changed someday,
6016 * if ISO or ANSI decide to use '_' for something.
6017 * So we keep it hidden from users' code.
6021 argsv = va_arg(*args,SV*);
6022 eptr = SvPVx(argsv, elen);
6028 if (has_precis && elen > precis)
6036 uv = PTR2UV(va_arg(*args, void*));
6038 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6058 iv = (IV)utf8_to_uv(vecstr, &ulen);
6068 case 'h': iv = (short)va_arg(*args, int); break;
6069 default: iv = va_arg(*args, int); break;
6070 case 'l': iv = va_arg(*args, long); break;
6071 case 'V': iv = va_arg(*args, IV); break;
6073 case 'q': iv = va_arg(*args, Quad_t); break;
6078 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6080 case 'h': iv = (short)iv; break;
6082 case 'l': iv = (long)iv; break;
6085 case 'q': iv = (Quad_t)iv; break;
6092 esignbuf[esignlen++] = plus;
6096 esignbuf[esignlen++] = '-';
6140 uv = utf8_to_uv(vecstr, &ulen);
6150 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6151 default: uv = va_arg(*args, unsigned); break;
6152 case 'l': uv = va_arg(*args, unsigned long); break;
6153 case 'V': uv = va_arg(*args, UV); break;
6155 case 'q': uv = va_arg(*args, Quad_t); break;
6160 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6162 case 'h': uv = (unsigned short)uv; break;
6164 case 'l': uv = (unsigned long)uv; break;
6167 case 'q': uv = (Quad_t)uv; break;
6173 eptr = ebuf + sizeof ebuf;
6179 p = (char*)((c == 'X')
6180 ? "0123456789ABCDEF" : "0123456789abcdef");
6186 esignbuf[esignlen++] = '0';
6187 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6193 *--eptr = '0' + dig;
6195 if (alt && *eptr != '0')
6201 *--eptr = '0' + dig;
6204 esignbuf[esignlen++] = '0';
6205 esignbuf[esignlen++] = 'b';
6208 default: /* it had better be ten or less */
6209 #if defined(PERL_Y2KWARN)
6210 if (ckWARN(WARN_Y2K)) {
6212 char *s = SvPV(sv,n);
6213 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6214 && (n == 2 || !isDIGIT(s[n-3])))
6216 Perl_warner(aTHX_ WARN_Y2K,
6217 "Possible Y2K bug: %%%c %s",
6218 c, "format string following '19'");
6224 *--eptr = '0' + dig;
6225 } while (uv /= base);
6228 elen = (ebuf + sizeof ebuf) - eptr;
6231 zeros = precis - elen;
6232 else if (precis == 0 && elen == 1 && *eptr == '0')
6237 /* FLOATING POINT */
6240 c = 'f'; /* maybe %F isn't supported here */
6246 /* This is evil, but floating point is even more evil */
6250 nv = va_arg(*args, NV);
6252 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6255 if (c != 'e' && c != 'E') {
6257 (void)Perl_frexp(nv, &i);
6258 if (i == PERL_INT_MIN)
6259 Perl_die(aTHX_ "panic: frexp");
6261 need = BIT_DIGITS(i);
6263 need += has_precis ? precis : 6; /* known default */
6267 need += 20; /* fudge factor */
6268 if (PL_efloatsize < need) {
6269 Safefree(PL_efloatbuf);
6270 PL_efloatsize = need + 20; /* more fudge */
6271 New(906, PL_efloatbuf, PL_efloatsize, char);
6272 PL_efloatbuf[0] = '\0';
6275 eptr = ebuf + sizeof ebuf;
6278 #ifdef USE_LONG_DOUBLE
6280 static char const my_prifldbl[] = PERL_PRIfldbl;
6281 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6282 while (p >= my_prifldbl) { *--eptr = *p--; }
6287 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6292 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6305 RESTORE_NUMERIC_STANDARD();
6306 (void)sprintf(PL_efloatbuf, eptr, nv);
6307 RESTORE_NUMERIC_LOCAL();
6310 eptr = PL_efloatbuf;
6311 elen = strlen(PL_efloatbuf);
6318 i = SvCUR(sv) - origlen;
6321 case 'h': *(va_arg(*args, short*)) = i; break;
6322 default: *(va_arg(*args, int*)) = i; break;
6323 case 'l': *(va_arg(*args, long*)) = i; break;
6324 case 'V': *(va_arg(*args, IV*)) = i; break;
6326 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6330 else if (svix < svmax)
6331 sv_setuv(svargs[svix++], (UV)i);
6332 continue; /* not "break" */
6339 if (!args && ckWARN(WARN_PRINTF) &&
6340 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6341 SV *msg = sv_newmortal();
6342 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6343 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6346 Perl_sv_catpvf(aTHX_ msg,
6347 "\"%%%c\"", c & 0xFF);
6349 Perl_sv_catpvf(aTHX_ msg,
6350 "\"%%\\%03"UVof"\"",
6353 sv_catpv(msg, "end of string");
6354 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6357 /* output mangled stuff ... */
6363 /* ... right here, because formatting flags should not apply */
6364 SvGROW(sv, SvCUR(sv) + elen + 1);
6366 memcpy(p, eptr, elen);
6369 SvCUR(sv) = p - SvPVX(sv);
6370 continue; /* not "break" */
6373 have = esignlen + zeros + elen;
6374 need = (have > width ? have : width);
6377 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6379 if (esignlen && fill == '0') {
6380 for (i = 0; i < esignlen; i++)
6384 memset(p, fill, gap);
6387 if (esignlen && fill != '0') {
6388 for (i = 0; i < esignlen; i++)
6392 for (i = zeros; i; i--)
6396 memcpy(p, eptr, elen);
6400 memset(p, ' ', gap);
6405 memcpy(p, dotstr, dotstrlen);
6409 vectorize = FALSE; /* done iterating over vecstr */
6414 SvCUR(sv) = p - SvPVX(sv);
6422 #if defined(USE_ITHREADS)
6424 #if defined(USE_THREADS)
6425 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6428 #ifndef GpREFCNT_inc
6429 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6433 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6434 #define av_dup(s) (AV*)sv_dup((SV*)s)
6435 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6436 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6437 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6438 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6439 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6440 #define io_dup(s) (IO*)sv_dup((SV*)s)
6441 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6442 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6443 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6444 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6445 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6448 Perl_re_dup(pTHX_ REGEXP *r)
6450 /* XXX fix when pmop->op_pmregexp becomes shared */
6451 return ReREFCNT_inc(r);
6455 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6459 return (PerlIO*)NULL;
6461 /* look for it in the table first */
6462 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6466 /* create anew and remember what it is */
6467 ret = PerlIO_fdupopen(fp);
6468 ptr_table_store(PL_ptr_table, fp, ret);
6473 Perl_dirp_dup(pTHX_ DIR *dp)
6482 Perl_gp_dup(pTHX_ GP *gp)
6487 /* look for it in the table first */
6488 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6492 /* create anew and remember what it is */
6493 Newz(0, ret, 1, GP);
6494 ptr_table_store(PL_ptr_table, gp, ret);
6497 ret->gp_refcnt = 0; /* must be before any other dups! */
6498 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6499 ret->gp_io = io_dup_inc(gp->gp_io);
6500 ret->gp_form = cv_dup_inc(gp->gp_form);
6501 ret->gp_av = av_dup_inc(gp->gp_av);
6502 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6503 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6504 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6505 ret->gp_cvgen = gp->gp_cvgen;
6506 ret->gp_flags = gp->gp_flags;
6507 ret->gp_line = gp->gp_line;
6508 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6513 Perl_mg_dup(pTHX_ MAGIC *mg)
6515 MAGIC *mgret = (MAGIC*)NULL;
6518 return (MAGIC*)NULL;
6519 /* look for it in the table first */
6520 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6524 for (; mg; mg = mg->mg_moremagic) {
6526 Newz(0, nmg, 1, MAGIC);
6530 mgprev->mg_moremagic = nmg;
6531 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6532 nmg->mg_private = mg->mg_private;
6533 nmg->mg_type = mg->mg_type;
6534 nmg->mg_flags = mg->mg_flags;
6535 if (mg->mg_type == 'r') {
6536 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6539 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6540 ? sv_dup_inc(mg->mg_obj)
6541 : sv_dup(mg->mg_obj);
6543 nmg->mg_len = mg->mg_len;
6544 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6545 if (mg->mg_ptr && mg->mg_type != 'g') {
6546 if (mg->mg_len >= 0) {
6547 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6548 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6549 AMT *amtp = (AMT*)mg->mg_ptr;
6550 AMT *namtp = (AMT*)nmg->mg_ptr;
6552 for (i = 1; i < NofAMmeth; i++) {
6553 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6557 else if (mg->mg_len == HEf_SVKEY)
6558 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6566 Perl_ptr_table_new(pTHX)
6569 Newz(0, tbl, 1, PTR_TBL_t);
6572 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6577 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6579 PTR_TBL_ENT_t *tblent;
6580 UV hash = PTR2UV(sv);
6582 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6583 for (; tblent; tblent = tblent->next) {
6584 if (tblent->oldval == sv)
6585 return tblent->newval;
6591 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6593 PTR_TBL_ENT_t *tblent, **otblent;
6594 /* XXX this may be pessimal on platforms where pointers aren't good
6595 * hash values e.g. if they grow faster in the most significant
6597 UV hash = PTR2UV(oldv);
6601 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6602 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6603 if (tblent->oldval == oldv) {
6604 tblent->newval = newv;
6609 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6610 tblent->oldval = oldv;
6611 tblent->newval = newv;
6612 tblent->next = *otblent;
6615 if (i && tbl->tbl_items > tbl->tbl_max)
6616 ptr_table_split(tbl);
6620 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6622 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6623 UV oldsize = tbl->tbl_max + 1;
6624 UV newsize = oldsize * 2;
6627 Renew(ary, newsize, PTR_TBL_ENT_t*);
6628 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6629 tbl->tbl_max = --newsize;
6631 for (i=0; i < oldsize; i++, ary++) {
6632 PTR_TBL_ENT_t **curentp, **entp, *ent;
6635 curentp = ary + oldsize;
6636 for (entp = ary, ent = *ary; ent; ent = *entp) {
6637 if ((newsize & PTR2UV(ent->oldval)) != i) {
6639 ent->next = *curentp;
6654 Perl_sv_dup(pTHX_ SV *sstr)
6658 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6660 /* look for it in the table first */
6661 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6665 /* create anew and remember what it is */
6667 ptr_table_store(PL_ptr_table, sstr, dstr);
6670 SvFLAGS(dstr) = SvFLAGS(sstr);
6671 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6672 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6675 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6676 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6677 PL_watch_pvx, SvPVX(sstr));
6680 switch (SvTYPE(sstr)) {
6685 SvANY(dstr) = new_XIV();
6686 SvIVX(dstr) = SvIVX(sstr);
6689 SvANY(dstr) = new_XNV();
6690 SvNVX(dstr) = SvNVX(sstr);
6693 SvANY(dstr) = new_XRV();
6694 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6697 SvANY(dstr) = new_XPV();
6698 SvCUR(dstr) = SvCUR(sstr);
6699 SvLEN(dstr) = SvLEN(sstr);
6701 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6702 else if (SvPVX(sstr) && SvLEN(sstr))
6703 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6705 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6708 SvANY(dstr) = new_XPVIV();
6709 SvCUR(dstr) = SvCUR(sstr);
6710 SvLEN(dstr) = SvLEN(sstr);
6711 SvIVX(dstr) = SvIVX(sstr);
6713 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6714 else if (SvPVX(sstr) && SvLEN(sstr))
6715 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6717 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6720 SvANY(dstr) = new_XPVNV();
6721 SvCUR(dstr) = SvCUR(sstr);
6722 SvLEN(dstr) = SvLEN(sstr);
6723 SvIVX(dstr) = SvIVX(sstr);
6724 SvNVX(dstr) = SvNVX(sstr);
6726 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6727 else if (SvPVX(sstr) && SvLEN(sstr))
6728 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6730 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6733 SvANY(dstr) = new_XPVMG();
6734 SvCUR(dstr) = SvCUR(sstr);
6735 SvLEN(dstr) = SvLEN(sstr);
6736 SvIVX(dstr) = SvIVX(sstr);
6737 SvNVX(dstr) = SvNVX(sstr);
6738 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6739 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6741 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6742 else if (SvPVX(sstr) && SvLEN(sstr))
6743 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6745 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6748 SvANY(dstr) = new_XPVBM();
6749 SvCUR(dstr) = SvCUR(sstr);
6750 SvLEN(dstr) = SvLEN(sstr);
6751 SvIVX(dstr) = SvIVX(sstr);
6752 SvNVX(dstr) = SvNVX(sstr);
6753 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6754 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6756 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6757 else if (SvPVX(sstr) && SvLEN(sstr))
6758 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6760 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6761 BmRARE(dstr) = BmRARE(sstr);
6762 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6763 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6766 SvANY(dstr) = new_XPVLV();
6767 SvCUR(dstr) = SvCUR(sstr);
6768 SvLEN(dstr) = SvLEN(sstr);
6769 SvIVX(dstr) = SvIVX(sstr);
6770 SvNVX(dstr) = SvNVX(sstr);
6771 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6772 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6774 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6775 else if (SvPVX(sstr) && SvLEN(sstr))
6776 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6778 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6779 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6780 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6781 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6782 LvTYPE(dstr) = LvTYPE(sstr);
6785 SvANY(dstr) = new_XPVGV();
6786 SvCUR(dstr) = SvCUR(sstr);
6787 SvLEN(dstr) = SvLEN(sstr);
6788 SvIVX(dstr) = SvIVX(sstr);
6789 SvNVX(dstr) = SvNVX(sstr);
6790 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6791 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6793 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6794 else if (SvPVX(sstr) && SvLEN(sstr))
6795 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6797 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6798 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6799 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6800 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6801 GvFLAGS(dstr) = GvFLAGS(sstr);
6802 GvGP(dstr) = gp_dup(GvGP(sstr));
6803 (void)GpREFCNT_inc(GvGP(dstr));
6806 SvANY(dstr) = new_XPVIO();
6807 SvCUR(dstr) = SvCUR(sstr);
6808 SvLEN(dstr) = SvLEN(sstr);
6809 SvIVX(dstr) = SvIVX(sstr);
6810 SvNVX(dstr) = SvNVX(sstr);
6811 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6812 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6814 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6815 else if (SvPVX(sstr) && SvLEN(sstr))
6816 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6818 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6819 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6820 if (IoOFP(sstr) == IoIFP(sstr))
6821 IoOFP(dstr) = IoIFP(dstr);
6823 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6824 /* PL_rsfp_filters entries have fake IoDIRP() */
6825 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6826 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6828 IoDIRP(dstr) = IoDIRP(sstr);
6829 IoLINES(dstr) = IoLINES(sstr);
6830 IoPAGE(dstr) = IoPAGE(sstr);
6831 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6832 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6833 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6834 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6835 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6836 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6837 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6838 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6839 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6840 IoTYPE(dstr) = IoTYPE(sstr);
6841 IoFLAGS(dstr) = IoFLAGS(sstr);
6844 SvANY(dstr) = new_XPVAV();
6845 SvCUR(dstr) = SvCUR(sstr);
6846 SvLEN(dstr) = SvLEN(sstr);
6847 SvIVX(dstr) = SvIVX(sstr);
6848 SvNVX(dstr) = SvNVX(sstr);
6849 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6850 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6851 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6852 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6853 if (AvARRAY((AV*)sstr)) {
6854 SV **dst_ary, **src_ary;
6855 SSize_t items = AvFILLp((AV*)sstr) + 1;
6857 src_ary = AvARRAY((AV*)sstr);
6858 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6859 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6860 SvPVX(dstr) = (char*)dst_ary;
6861 AvALLOC((AV*)dstr) = dst_ary;
6862 if (AvREAL((AV*)sstr)) {
6864 *dst_ary++ = sv_dup_inc(*src_ary++);
6868 *dst_ary++ = sv_dup(*src_ary++);
6870 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6871 while (items-- > 0) {
6872 *dst_ary++ = &PL_sv_undef;
6876 SvPVX(dstr) = Nullch;
6877 AvALLOC((AV*)dstr) = (SV**)NULL;
6881 SvANY(dstr) = new_XPVHV();
6882 SvCUR(dstr) = SvCUR(sstr);
6883 SvLEN(dstr) = SvLEN(sstr);
6884 SvIVX(dstr) = SvIVX(sstr);
6885 SvNVX(dstr) = SvNVX(sstr);
6886 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6887 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6888 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6889 if (HvARRAY((HV*)sstr)) {
6891 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6892 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6893 Newz(0, dxhv->xhv_array,
6894 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6895 while (i <= sxhv->xhv_max) {
6896 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6897 !!HvSHAREKEYS(sstr));
6900 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6903 SvPVX(dstr) = Nullch;
6904 HvEITER((HV*)dstr) = (HE*)NULL;
6906 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6907 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6910 SvANY(dstr) = new_XPVFM();
6911 FmLINES(dstr) = FmLINES(sstr);
6915 SvANY(dstr) = new_XPVCV();
6917 SvCUR(dstr) = SvCUR(sstr);
6918 SvLEN(dstr) = SvLEN(sstr);
6919 SvIVX(dstr) = SvIVX(sstr);
6920 SvNVX(dstr) = SvNVX(sstr);
6921 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6922 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6923 if (SvPVX(sstr) && SvLEN(sstr))
6924 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6926 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6927 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6928 CvSTART(dstr) = CvSTART(sstr);
6929 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6930 CvXSUB(dstr) = CvXSUB(sstr);
6931 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6932 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6933 CvDEPTH(dstr) = CvDEPTH(sstr);
6934 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6935 /* XXX padlists are real, but pretend to be not */
6936 AvREAL_on(CvPADLIST(sstr));
6937 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6938 AvREAL_off(CvPADLIST(sstr));
6939 AvREAL_off(CvPADLIST(dstr));
6942 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6943 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6944 CvFLAGS(dstr) = CvFLAGS(sstr);
6947 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6951 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6958 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6963 return (PERL_CONTEXT*)NULL;
6965 /* look for it in the table first */
6966 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6970 /* create anew and remember what it is */
6971 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6972 ptr_table_store(PL_ptr_table, cxs, ncxs);
6975 PERL_CONTEXT *cx = &cxs[ix];
6976 PERL_CONTEXT *ncx = &ncxs[ix];
6977 ncx->cx_type = cx->cx_type;
6978 if (CxTYPE(cx) == CXt_SUBST) {
6979 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6982 ncx->blk_oldsp = cx->blk_oldsp;
6983 ncx->blk_oldcop = cx->blk_oldcop;
6984 ncx->blk_oldretsp = cx->blk_oldretsp;
6985 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6986 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6987 ncx->blk_oldpm = cx->blk_oldpm;
6988 ncx->blk_gimme = cx->blk_gimme;
6989 switch (CxTYPE(cx)) {
6991 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6992 ? cv_dup_inc(cx->blk_sub.cv)
6993 : cv_dup(cx->blk_sub.cv));
6994 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6995 ? av_dup_inc(cx->blk_sub.argarray)
6997 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6998 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6999 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7000 ncx->blk_sub.lval = cx->blk_sub.lval;
7003 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7004 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7005 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7006 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7007 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7010 ncx->blk_loop.label = cx->blk_loop.label;
7011 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7012 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7013 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7014 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7015 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7016 ? cx->blk_loop.iterdata
7017 : gv_dup((GV*)cx->blk_loop.iterdata));
7018 ncx->blk_loop.oldcurpad
7019 = (SV**)ptr_table_fetch(PL_ptr_table,
7020 cx->blk_loop.oldcurpad);
7021 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7022 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7023 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7024 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7025 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7028 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7029 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7030 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7031 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7044 Perl_si_dup(pTHX_ PERL_SI *si)
7049 return (PERL_SI*)NULL;
7051 /* look for it in the table first */
7052 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7056 /* create anew and remember what it is */
7057 Newz(56, nsi, 1, PERL_SI);
7058 ptr_table_store(PL_ptr_table, si, nsi);
7060 nsi->si_stack = av_dup_inc(si->si_stack);
7061 nsi->si_cxix = si->si_cxix;
7062 nsi->si_cxmax = si->si_cxmax;
7063 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7064 nsi->si_type = si->si_type;
7065 nsi->si_prev = si_dup(si->si_prev);
7066 nsi->si_next = si_dup(si->si_next);
7067 nsi->si_markoff = si->si_markoff;
7072 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7073 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7074 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7075 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7076 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7077 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7078 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7079 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7080 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7081 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7082 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7083 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7086 #define pv_dup_inc(p) SAVEPV(p)
7087 #define pv_dup(p) SAVEPV(p)
7088 #define svp_dup_inc(p,pp) any_dup(p,pp)
7091 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7098 /* look for it in the table first */
7099 ret = ptr_table_fetch(PL_ptr_table, v);
7103 /* see if it is part of the interpreter structure */
7104 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7105 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7113 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7115 ANY *ss = proto_perl->Tsavestack;
7116 I32 ix = proto_perl->Tsavestack_ix;
7117 I32 max = proto_perl->Tsavestack_max;
7130 void (*dptr) (void*);
7131 void (*dxptr) (pTHXo_ void*);
7134 Newz(54, nss, max, ANY);
7140 case SAVEt_ITEM: /* normal string */
7141 sv = (SV*)POPPTR(ss,ix);
7142 TOPPTR(nss,ix) = sv_dup_inc(sv);
7143 sv = (SV*)POPPTR(ss,ix);
7144 TOPPTR(nss,ix) = sv_dup_inc(sv);
7146 case SAVEt_SV: /* scalar reference */
7147 sv = (SV*)POPPTR(ss,ix);
7148 TOPPTR(nss,ix) = sv_dup_inc(sv);
7149 gv = (GV*)POPPTR(ss,ix);
7150 TOPPTR(nss,ix) = gv_dup_inc(gv);
7152 case SAVEt_GENERIC_SVREF: /* generic sv */
7153 case SAVEt_SVREF: /* scalar reference */
7154 sv = (SV*)POPPTR(ss,ix);
7155 TOPPTR(nss,ix) = sv_dup_inc(sv);
7156 ptr = POPPTR(ss,ix);
7157 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7159 case SAVEt_AV: /* array reference */
7160 av = (AV*)POPPTR(ss,ix);
7161 TOPPTR(nss,ix) = av_dup_inc(av);
7162 gv = (GV*)POPPTR(ss,ix);
7163 TOPPTR(nss,ix) = gv_dup(gv);
7165 case SAVEt_HV: /* hash reference */
7166 hv = (HV*)POPPTR(ss,ix);
7167 TOPPTR(nss,ix) = hv_dup_inc(hv);
7168 gv = (GV*)POPPTR(ss,ix);
7169 TOPPTR(nss,ix) = gv_dup(gv);
7171 case SAVEt_INT: /* int reference */
7172 ptr = POPPTR(ss,ix);
7173 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7174 intval = (int)POPINT(ss,ix);
7175 TOPINT(nss,ix) = intval;
7177 case SAVEt_LONG: /* long reference */
7178 ptr = POPPTR(ss,ix);
7179 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7180 longval = (long)POPLONG(ss,ix);
7181 TOPLONG(nss,ix) = longval;
7183 case SAVEt_I32: /* I32 reference */
7184 case SAVEt_I16: /* I16 reference */
7185 case SAVEt_I8: /* I8 reference */
7186 ptr = POPPTR(ss,ix);
7187 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7191 case SAVEt_IV: /* IV reference */
7192 ptr = POPPTR(ss,ix);
7193 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7197 case SAVEt_SPTR: /* SV* reference */
7198 ptr = POPPTR(ss,ix);
7199 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7200 sv = (SV*)POPPTR(ss,ix);
7201 TOPPTR(nss,ix) = sv_dup(sv);
7203 case SAVEt_VPTR: /* random* reference */
7204 ptr = POPPTR(ss,ix);
7205 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7206 ptr = POPPTR(ss,ix);
7207 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7209 case SAVEt_PPTR: /* char* reference */
7210 ptr = POPPTR(ss,ix);
7211 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7212 c = (char*)POPPTR(ss,ix);
7213 TOPPTR(nss,ix) = pv_dup(c);
7215 case SAVEt_HPTR: /* HV* reference */
7216 ptr = POPPTR(ss,ix);
7217 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7218 hv = (HV*)POPPTR(ss,ix);
7219 TOPPTR(nss,ix) = hv_dup(hv);
7221 case SAVEt_APTR: /* AV* reference */
7222 ptr = POPPTR(ss,ix);
7223 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7224 av = (AV*)POPPTR(ss,ix);
7225 TOPPTR(nss,ix) = av_dup(av);
7228 gv = (GV*)POPPTR(ss,ix);
7229 TOPPTR(nss,ix) = gv_dup(gv);
7231 case SAVEt_GP: /* scalar reference */
7232 gp = (GP*)POPPTR(ss,ix);
7233 TOPPTR(nss,ix) = gp = gp_dup(gp);
7234 (void)GpREFCNT_inc(gp);
7235 gv = (GV*)POPPTR(ss,ix);
7236 TOPPTR(nss,ix) = gv_dup_inc(c);
7237 c = (char*)POPPTR(ss,ix);
7238 TOPPTR(nss,ix) = pv_dup(c);
7245 sv = (SV*)POPPTR(ss,ix);
7246 TOPPTR(nss,ix) = sv_dup_inc(sv);
7249 ptr = POPPTR(ss,ix);
7250 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7251 /* these are assumed to be refcounted properly */
7252 switch (((OP*)ptr)->op_type) {
7259 TOPPTR(nss,ix) = ptr;
7264 TOPPTR(nss,ix) = Nullop;
7269 TOPPTR(nss,ix) = Nullop;
7272 c = (char*)POPPTR(ss,ix);
7273 TOPPTR(nss,ix) = pv_dup_inc(c);
7276 longval = POPLONG(ss,ix);
7277 TOPLONG(nss,ix) = longval;
7280 hv = (HV*)POPPTR(ss,ix);
7281 TOPPTR(nss,ix) = hv_dup_inc(hv);
7282 c = (char*)POPPTR(ss,ix);
7283 TOPPTR(nss,ix) = pv_dup_inc(c);
7287 case SAVEt_DESTRUCTOR:
7288 ptr = POPPTR(ss,ix);
7289 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7290 dptr = POPDPTR(ss,ix);
7291 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7293 case SAVEt_DESTRUCTOR_X:
7294 ptr = POPPTR(ss,ix);
7295 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7296 dxptr = POPDXPTR(ss,ix);
7297 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7299 case SAVEt_REGCONTEXT:
7305 case SAVEt_STACK_POS: /* Position on Perl stack */
7309 case SAVEt_AELEM: /* array element */
7310 sv = (SV*)POPPTR(ss,ix);
7311 TOPPTR(nss,ix) = sv_dup_inc(sv);
7314 av = (AV*)POPPTR(ss,ix);
7315 TOPPTR(nss,ix) = av_dup_inc(av);
7317 case SAVEt_HELEM: /* hash element */
7318 sv = (SV*)POPPTR(ss,ix);
7319 TOPPTR(nss,ix) = sv_dup_inc(sv);
7320 sv = (SV*)POPPTR(ss,ix);
7321 TOPPTR(nss,ix) = sv_dup_inc(sv);
7322 hv = (HV*)POPPTR(ss,ix);
7323 TOPPTR(nss,ix) = hv_dup_inc(hv);
7326 ptr = POPPTR(ss,ix);
7327 TOPPTR(nss,ix) = ptr;
7334 av = (AV*)POPPTR(ss,ix);
7335 TOPPTR(nss,ix) = av_dup(av);
7338 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7350 perl_clone(PerlInterpreter *proto_perl, UV flags)
7353 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7356 #ifdef PERL_IMPLICIT_SYS
7357 return perl_clone_using(proto_perl, flags,
7359 proto_perl->IMemShared,
7360 proto_perl->IMemParse,
7370 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7371 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7372 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7373 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7374 struct IPerlDir* ipD, struct IPerlSock* ipS,
7375 struct IPerlProc* ipP)
7377 /* XXX many of the string copies here can be optimized if they're
7378 * constants; they need to be allocated as common memory and just
7379 * their pointers copied. */
7383 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7385 PERL_SET_THX(pPerl);
7386 # else /* !PERL_OBJECT */
7387 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7388 PERL_SET_THX(my_perl);
7391 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7396 # else /* !DEBUGGING */
7397 Zero(my_perl, 1, PerlInterpreter);
7398 # endif /* DEBUGGING */
7402 PL_MemShared = ipMS;
7410 # endif /* PERL_OBJECT */
7411 #else /* !PERL_IMPLICIT_SYS */
7413 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7414 PERL_SET_THX(my_perl);
7417 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7422 # else /* !DEBUGGING */
7423 Zero(my_perl, 1, PerlInterpreter);
7424 # endif /* DEBUGGING */
7425 #endif /* PERL_IMPLICIT_SYS */
7428 PL_xiv_arenaroot = NULL;
7433 PL_xpviv_root = NULL;
7434 PL_xpvnv_root = NULL;
7435 PL_xpvcv_root = NULL;
7436 PL_xpvav_root = NULL;
7437 PL_xpvhv_root = NULL;
7438 PL_xpvmg_root = NULL;
7439 PL_xpvlv_root = NULL;
7440 PL_xpvbm_root = NULL;
7442 PL_nice_chunk = NULL;
7443 PL_nice_chunk_size = 0;
7446 PL_sv_root = Nullsv;
7447 PL_sv_arenaroot = Nullsv;
7449 PL_debug = proto_perl->Idebug;
7451 /* create SV map for pointer relocation */
7452 PL_ptr_table = ptr_table_new();
7454 /* initialize these special pointers as early as possible */
7455 SvANY(&PL_sv_undef) = NULL;
7456 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7457 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7458 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7461 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7463 SvANY(&PL_sv_no) = new_XPVNV();
7465 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7466 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7467 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7468 SvCUR(&PL_sv_no) = 0;
7469 SvLEN(&PL_sv_no) = 1;
7470 SvNVX(&PL_sv_no) = 0;
7471 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7474 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7476 SvANY(&PL_sv_yes) = new_XPVNV();
7478 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7479 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7480 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7481 SvCUR(&PL_sv_yes) = 1;
7482 SvLEN(&PL_sv_yes) = 2;
7483 SvNVX(&PL_sv_yes) = 1;
7484 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7486 /* create shared string table */
7487 PL_strtab = newHV();
7488 HvSHAREKEYS_off(PL_strtab);
7489 hv_ksplit(PL_strtab, 512);
7490 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7492 PL_compiling = proto_perl->Icompiling;
7493 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7494 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7495 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7496 if (!specialWARN(PL_compiling.cop_warnings))
7497 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7498 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7500 /* pseudo environmental stuff */
7501 PL_origargc = proto_perl->Iorigargc;
7503 New(0, PL_origargv, i+1, char*);
7504 PL_origargv[i] = '\0';
7506 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7508 PL_envgv = gv_dup(proto_perl->Ienvgv);
7509 PL_incgv = gv_dup(proto_perl->Iincgv);
7510 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7511 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7512 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7513 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7516 PL_minus_c = proto_perl->Iminus_c;
7517 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7518 PL_localpatches = proto_perl->Ilocalpatches;
7519 PL_splitstr = proto_perl->Isplitstr;
7520 PL_preprocess = proto_perl->Ipreprocess;
7521 PL_minus_n = proto_perl->Iminus_n;
7522 PL_minus_p = proto_perl->Iminus_p;
7523 PL_minus_l = proto_perl->Iminus_l;
7524 PL_minus_a = proto_perl->Iminus_a;
7525 PL_minus_F = proto_perl->Iminus_F;
7526 PL_doswitches = proto_perl->Idoswitches;
7527 PL_dowarn = proto_perl->Idowarn;
7528 PL_doextract = proto_perl->Idoextract;
7529 PL_sawampersand = proto_perl->Isawampersand;
7530 PL_unsafe = proto_perl->Iunsafe;
7531 PL_inplace = SAVEPV(proto_perl->Iinplace);
7532 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7533 PL_perldb = proto_perl->Iperldb;
7534 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7536 /* magical thingies */
7537 /* XXX time(&PL_basetime) when asked for? */
7538 PL_basetime = proto_perl->Ibasetime;
7539 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7541 PL_maxsysfd = proto_perl->Imaxsysfd;
7542 PL_multiline = proto_perl->Imultiline;
7543 PL_statusvalue = proto_perl->Istatusvalue;
7545 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7548 /* shortcuts to various I/O objects */
7549 PL_stdingv = gv_dup(proto_perl->Istdingv);
7550 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7551 PL_defgv = gv_dup(proto_perl->Idefgv);
7552 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7553 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7554 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7556 /* shortcuts to regexp stuff */
7557 PL_replgv = gv_dup(proto_perl->Ireplgv);
7559 /* shortcuts to misc objects */
7560 PL_errgv = gv_dup(proto_perl->Ierrgv);
7562 /* shortcuts to debugging objects */
7563 PL_DBgv = gv_dup(proto_perl->IDBgv);
7564 PL_DBline = gv_dup(proto_perl->IDBline);
7565 PL_DBsub = gv_dup(proto_perl->IDBsub);
7566 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7567 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7568 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7569 PL_lineary = av_dup(proto_perl->Ilineary);
7570 PL_dbargs = av_dup(proto_perl->Idbargs);
7573 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7574 PL_curstash = hv_dup(proto_perl->Tcurstash);
7575 PL_debstash = hv_dup(proto_perl->Idebstash);
7576 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7577 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7579 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7580 PL_endav = av_dup_inc(proto_perl->Iendav);
7581 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7582 PL_initav = av_dup_inc(proto_perl->Iinitav);
7584 PL_sub_generation = proto_perl->Isub_generation;
7586 /* funky return mechanisms */
7587 PL_forkprocess = proto_perl->Iforkprocess;
7589 /* subprocess state */
7590 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7592 /* internal state */
7593 PL_tainting = proto_perl->Itainting;
7594 PL_maxo = proto_perl->Imaxo;
7595 if (proto_perl->Iop_mask)
7596 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7598 PL_op_mask = Nullch;
7600 /* current interpreter roots */
7601 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7602 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7603 PL_main_start = proto_perl->Imain_start;
7604 PL_eval_root = proto_perl->Ieval_root;
7605 PL_eval_start = proto_perl->Ieval_start;
7607 /* runtime control stuff */
7608 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7609 PL_copline = proto_perl->Icopline;
7611 PL_filemode = proto_perl->Ifilemode;
7612 PL_lastfd = proto_perl->Ilastfd;
7613 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7616 PL_gensym = proto_perl->Igensym;
7617 PL_preambled = proto_perl->Ipreambled;
7618 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7619 PL_laststatval = proto_perl->Ilaststatval;
7620 PL_laststype = proto_perl->Ilaststype;
7621 PL_mess_sv = Nullsv;
7623 PL_orslen = proto_perl->Iorslen;
7624 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7625 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7627 /* interpreter atexit processing */
7628 PL_exitlistlen = proto_perl->Iexitlistlen;
7629 if (PL_exitlistlen) {
7630 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7631 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7634 PL_exitlist = (PerlExitListEntry*)NULL;
7635 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7637 PL_profiledata = NULL;
7638 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7639 /* PL_rsfp_filters entries have fake IoDIRP() */
7640 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7642 PL_compcv = cv_dup(proto_perl->Icompcv);
7643 PL_comppad = av_dup(proto_perl->Icomppad);
7644 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7645 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7646 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7647 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7648 proto_perl->Tcurpad);
7650 #ifdef HAVE_INTERP_INTERN
7651 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7654 /* more statics moved here */
7655 PL_generation = proto_perl->Igeneration;
7656 PL_DBcv = cv_dup(proto_perl->IDBcv);
7658 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7659 PL_in_clean_all = proto_perl->Iin_clean_all;
7661 PL_uid = proto_perl->Iuid;
7662 PL_euid = proto_perl->Ieuid;
7663 PL_gid = proto_perl->Igid;
7664 PL_egid = proto_perl->Iegid;
7665 PL_nomemok = proto_perl->Inomemok;
7666 PL_an = proto_perl->Ian;
7667 PL_cop_seqmax = proto_perl->Icop_seqmax;
7668 PL_op_seqmax = proto_perl->Iop_seqmax;
7669 PL_evalseq = proto_perl->Ievalseq;
7670 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7671 PL_origalen = proto_perl->Iorigalen;
7672 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7673 PL_osname = SAVEPV(proto_perl->Iosname);
7674 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7675 PL_sighandlerp = proto_perl->Isighandlerp;
7678 PL_runops = proto_perl->Irunops;
7680 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7683 PL_cshlen = proto_perl->Icshlen;
7684 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7687 PL_lex_state = proto_perl->Ilex_state;
7688 PL_lex_defer = proto_perl->Ilex_defer;
7689 PL_lex_expect = proto_perl->Ilex_expect;
7690 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7691 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7692 PL_lex_starts = proto_perl->Ilex_starts;
7693 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7694 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7695 PL_lex_op = proto_perl->Ilex_op;
7696 PL_lex_inpat = proto_perl->Ilex_inpat;
7697 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7698 PL_lex_brackets = proto_perl->Ilex_brackets;
7699 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7700 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7701 PL_lex_casemods = proto_perl->Ilex_casemods;
7702 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7703 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7705 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7706 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7707 PL_nexttoke = proto_perl->Inexttoke;
7709 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7710 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7711 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7712 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7713 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7714 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7715 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7716 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7717 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7718 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7719 PL_pending_ident = proto_perl->Ipending_ident;
7720 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7722 PL_expect = proto_perl->Iexpect;
7724 PL_multi_start = proto_perl->Imulti_start;
7725 PL_multi_end = proto_perl->Imulti_end;
7726 PL_multi_open = proto_perl->Imulti_open;
7727 PL_multi_close = proto_perl->Imulti_close;
7729 PL_error_count = proto_perl->Ierror_count;
7730 PL_subline = proto_perl->Isubline;
7731 PL_subname = sv_dup_inc(proto_perl->Isubname);
7733 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7734 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7735 PL_padix = proto_perl->Ipadix;
7736 PL_padix_floor = proto_perl->Ipadix_floor;
7737 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7739 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7740 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7741 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7742 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7743 PL_last_lop_op = proto_perl->Ilast_lop_op;
7744 PL_in_my = proto_perl->Iin_my;
7745 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7747 PL_cryptseen = proto_perl->Icryptseen;
7750 PL_hints = proto_perl->Ihints;
7752 PL_amagic_generation = proto_perl->Iamagic_generation;
7754 #ifdef USE_LOCALE_COLLATE
7755 PL_collation_ix = proto_perl->Icollation_ix;
7756 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7757 PL_collation_standard = proto_perl->Icollation_standard;
7758 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7759 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7760 #endif /* USE_LOCALE_COLLATE */
7762 #ifdef USE_LOCALE_NUMERIC
7763 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7764 PL_numeric_standard = proto_perl->Inumeric_standard;
7765 PL_numeric_local = proto_perl->Inumeric_local;
7766 PL_numeric_radix = proto_perl->Inumeric_radix;
7767 #endif /* !USE_LOCALE_NUMERIC */
7769 /* utf8 character classes */
7770 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7771 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7772 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7773 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7774 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7775 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7776 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7777 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7778 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7779 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7780 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7781 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7782 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7783 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7784 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7785 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7786 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7789 PL_last_swash_hv = Nullhv; /* reinits on demand */
7790 PL_last_swash_klen = 0;
7791 PL_last_swash_key[0]= '\0';
7792 PL_last_swash_tmps = (U8*)NULL;
7793 PL_last_swash_slen = 0;
7795 /* perly.c globals */
7796 PL_yydebug = proto_perl->Iyydebug;
7797 PL_yynerrs = proto_perl->Iyynerrs;
7798 PL_yyerrflag = proto_perl->Iyyerrflag;
7799 PL_yychar = proto_perl->Iyychar;
7800 PL_yyval = proto_perl->Iyyval;
7801 PL_yylval = proto_perl->Iyylval;
7803 PL_glob_index = proto_perl->Iglob_index;
7804 PL_srand_called = proto_perl->Isrand_called;
7805 PL_uudmap['M'] = 0; /* reinits on demand */
7806 PL_bitcount = Nullch; /* reinits on demand */
7808 if (proto_perl->Ipsig_ptr) {
7809 int sig_num[] = { SIG_NUM };
7810 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7811 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7812 for (i = 1; PL_sig_name[i]; i++) {
7813 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7814 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7818 PL_psig_ptr = (SV**)NULL;
7819 PL_psig_name = (SV**)NULL;
7822 /* thrdvar.h stuff */
7825 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7826 PL_tmps_ix = proto_perl->Ttmps_ix;
7827 PL_tmps_max = proto_perl->Ttmps_max;
7828 PL_tmps_floor = proto_perl->Ttmps_floor;
7829 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7831 while (i <= PL_tmps_ix) {
7832 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7836 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7837 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7838 Newz(54, PL_markstack, i, I32);
7839 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7840 - proto_perl->Tmarkstack);
7841 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7842 - proto_perl->Tmarkstack);
7843 Copy(proto_perl->Tmarkstack, PL_markstack,
7844 PL_markstack_ptr - PL_markstack + 1, I32);
7846 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7847 * NOTE: unlike the others! */
7848 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7849 PL_scopestack_max = proto_perl->Tscopestack_max;
7850 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7851 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7853 /* next push_return() sets PL_retstack[PL_retstack_ix]
7854 * NOTE: unlike the others! */
7855 PL_retstack_ix = proto_perl->Tretstack_ix;
7856 PL_retstack_max = proto_perl->Tretstack_max;
7857 Newz(54, PL_retstack, PL_retstack_max, OP*);
7858 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7860 /* NOTE: si_dup() looks at PL_markstack */
7861 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7863 /* PL_curstack = PL_curstackinfo->si_stack; */
7864 PL_curstack = av_dup(proto_perl->Tcurstack);
7865 PL_mainstack = av_dup(proto_perl->Tmainstack);
7867 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7868 PL_stack_base = AvARRAY(PL_curstack);
7869 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7870 - proto_perl->Tstack_base);
7871 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7873 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7874 * NOTE: unlike the others! */
7875 PL_savestack_ix = proto_perl->Tsavestack_ix;
7876 PL_savestack_max = proto_perl->Tsavestack_max;
7877 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7878 PL_savestack = ss_dup(proto_perl);
7882 ENTER; /* perl_destruct() wants to LEAVE; */
7885 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7886 PL_top_env = &PL_start_env;
7888 PL_op = proto_perl->Top;
7891 PL_Xpv = (XPV*)NULL;
7892 PL_na = proto_perl->Tna;
7894 PL_statbuf = proto_perl->Tstatbuf;
7895 PL_statcache = proto_perl->Tstatcache;
7896 PL_statgv = gv_dup(proto_perl->Tstatgv);
7897 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7899 PL_timesbuf = proto_perl->Ttimesbuf;
7902 PL_tainted = proto_perl->Ttainted;
7903 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7904 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7905 PL_rs = sv_dup_inc(proto_perl->Trs);
7906 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7907 PL_ofslen = proto_perl->Tofslen;
7908 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7909 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7910 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7911 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7912 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7913 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7915 PL_restartop = proto_perl->Trestartop;
7916 PL_in_eval = proto_perl->Tin_eval;
7917 PL_delaymagic = proto_perl->Tdelaymagic;
7918 PL_dirty = proto_perl->Tdirty;
7919 PL_localizing = proto_perl->Tlocalizing;
7921 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7922 PL_protect = proto_perl->Tprotect;
7924 PL_errors = sv_dup_inc(proto_perl->Terrors);
7925 PL_av_fetch_sv = Nullsv;
7926 PL_hv_fetch_sv = Nullsv;
7927 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7928 PL_modcount = proto_perl->Tmodcount;
7929 PL_lastgotoprobe = Nullop;
7930 PL_dumpindent = proto_perl->Tdumpindent;
7932 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7933 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7934 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7935 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7936 PL_sortcxix = proto_perl->Tsortcxix;
7937 PL_efloatbuf = Nullch; /* reinits on demand */
7938 PL_efloatsize = 0; /* reinits on demand */
7942 PL_screamfirst = NULL;
7943 PL_screamnext = NULL;
7944 PL_maxscream = -1; /* reinits on demand */
7945 PL_lastscream = Nullsv;
7947 PL_watchaddr = NULL;
7948 PL_watchok = Nullch;
7950 PL_regdummy = proto_perl->Tregdummy;
7951 PL_regcomp_parse = Nullch;
7952 PL_regxend = Nullch;
7953 PL_regcode = (regnode*)NULL;
7956 PL_regprecomp = Nullch;
7961 PL_seen_zerolen = 0;
7963 PL_regcomp_rx = (regexp*)NULL;
7965 PL_colorset = 0; /* reinits PL_colors[] */
7966 /*PL_colors[6] = {0,0,0,0,0,0};*/
7967 PL_reg_whilem_seen = 0;
7968 PL_reginput = Nullch;
7971 PL_regstartp = (I32*)NULL;
7972 PL_regendp = (I32*)NULL;
7973 PL_reglastparen = (U32*)NULL;
7974 PL_regtill = Nullch;
7976 PL_reg_start_tmp = (char**)NULL;
7977 PL_reg_start_tmpl = 0;
7978 PL_regdata = (struct reg_data*)NULL;
7981 PL_reg_eval_set = 0;
7983 PL_regprogram = (regnode*)NULL;
7985 PL_regcc = (CURCUR*)NULL;
7986 PL_reg_call_cc = (struct re_cc_state*)NULL;
7987 PL_reg_re = (regexp*)NULL;
7988 PL_reg_ganch = Nullch;
7990 PL_reg_magic = (MAGIC*)NULL;
7992 PL_reg_oldcurpm = (PMOP*)NULL;
7993 PL_reg_curpm = (PMOP*)NULL;
7994 PL_reg_oldsaved = Nullch;
7995 PL_reg_oldsavedlen = 0;
7997 PL_reg_leftiter = 0;
7998 PL_reg_poscache = Nullch;
7999 PL_reg_poscache_size= 0;
8001 /* RE engine - function pointers */
8002 PL_regcompp = proto_perl->Tregcompp;
8003 PL_regexecp = proto_perl->Tregexecp;
8004 PL_regint_start = proto_perl->Tregint_start;
8005 PL_regint_string = proto_perl->Tregint_string;
8006 PL_regfree = proto_perl->Tregfree;
8008 PL_reginterp_cnt = 0;
8009 PL_reg_starttry = 0;
8012 return (PerlInterpreter*)pPerl;
8018 #else /* !USE_ITHREADS */
8024 #endif /* USE_ITHREADS */
8027 do_report_used(pTHXo_ SV *sv)
8029 if (SvTYPE(sv) != SVTYPEMASK) {
8030 PerlIO_printf(Perl_debug_log, "****\n");
8036 do_clean_objs(pTHXo_ SV *sv)
8040 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8041 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8047 /* XXX Might want to check arrays, etc. */
8050 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8052 do_clean_named_objs(pTHXo_ SV *sv)
8054 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8055 if ( SvOBJECT(GvSV(sv)) ||
8056 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8057 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8058 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8059 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8061 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8069 do_clean_all(pTHXo_ SV *sv)
8071 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8072 SvFLAGS(sv) |= SVf_BREAK;