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(sva, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
207 Safefree((void *)sva);
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
219 Perl_report_uninit(pTHX)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
237 * See comment in more_xiv() -- RAM.
239 PL_xiv_root = *(IV**)xiv;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
245 S_del_xiv(pTHX_ XPVIV *p)
247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
249 *(IV**)xiv = PL_xiv_root;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
268 while (xiv < xivend) {
269 *(IV**)xiv = (IV *)(xiv + 1);
283 PL_xnv_root = *(NV**)xnv;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
289 S_del_xnv(pTHX_ XPVNV *p)
291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
293 *(NV**)xnv = PL_xnv_root;
303 New(711, xnv, 1008/sizeof(NV), NV);
304 xnvend = &xnv[1008 / sizeof(NV) - 1];
305 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
307 while (xnv < xnvend) {
308 *(NV**)xnv = (NV*)(xnv + 1);
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
328 S_del_xrv(pTHX_ XRV *p)
331 p->xrv_rv = (SV*)PL_xrv_root;
340 register XRV* xrvend;
341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
365 S_del_xpv(pTHX_ XPV *p)
368 p->xpv_pv = (char*)PL_xpv_root;
377 register XPV* xpvend;
378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
402 S_del_xpviv(pTHX_ XPVIV *p)
405 p->xpv_pv = (char*)PL_xpviv_root;
414 register XPVIV* xpviv;
415 register XPVIV* xpvivend;
416 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417 xpviv = PL_xpviv_root;
418 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419 while (xpviv < xpvivend) {
420 xpviv->xpv_pv = (char*)(xpviv + 1);
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
441 S_del_xpvnv(pTHX_ XPVNV *p)
444 p->xpv_pv = (char*)PL_xpvnv_root;
453 register XPVNV* xpvnv;
454 register XPVNV* xpvnvend;
455 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456 xpvnv = PL_xpvnv_root;
457 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458 while (xpvnv < xpvnvend) {
459 xpvnv->xpv_pv = (char*)(xpvnv + 1);
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
481 S_del_xpvcv(pTHX_ XPVCV *p)
484 p->xpv_pv = (char*)PL_xpvcv_root;
493 register XPVCV* xpvcv;
494 register XPVCV* xpvcvend;
495 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496 xpvcv = PL_xpvcv_root;
497 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498 while (xpvcv < xpvcvend) {
499 xpvcv->xpv_pv = (char*)(xpvcv + 1);
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
521 S_del_xpvav(pTHX_ XPVAV *p)
524 p->xav_array = (char*)PL_xpvav_root;
533 register XPVAV* xpvav;
534 register XPVAV* xpvavend;
535 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536 xpvav = PL_xpvav_root;
537 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538 while (xpvav < xpvavend) {
539 xpvav->xav_array = (char*)(xpvav + 1);
542 xpvav->xav_array = 0;
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
561 S_del_xpvhv(pTHX_ XPVHV *p)
564 p->xhv_array = (char*)PL_xpvhv_root;
573 register XPVHV* xpvhv;
574 register XPVHV* xpvhvend;
575 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576 xpvhv = PL_xpvhv_root;
577 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578 while (xpvhv < xpvhvend) {
579 xpvhv->xhv_array = (char*)(xpvhv + 1);
582 xpvhv->xhv_array = 0;
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
600 S_del_xpvmg(pTHX_ XPVMG *p)
603 p->xpv_pv = (char*)PL_xpvmg_root;
612 register XPVMG* xpvmg;
613 register XPVMG* xpvmgend;
614 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615 xpvmg = PL_xpvmg_root;
616 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617 while (xpvmg < xpvmgend) {
618 xpvmg->xpv_pv = (char*)(xpvmg + 1);
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
640 S_del_xpvlv(pTHX_ XPVLV *p)
643 p->xpv_pv = (char*)PL_xpvlv_root;
652 register XPVLV* xpvlv;
653 register XPVLV* xpvlvend;
654 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655 xpvlv = PL_xpvlv_root;
656 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657 while (xpvlv < xpvlvend) {
658 xpvlv->xpv_pv = (char*)(xpvlv + 1);
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
679 S_del_xpvbm(pTHX_ XPVBM *p)
682 p->xpv_pv = (char*)PL_xpvbm_root;
691 register XPVBM* xpvbm;
692 register XPVBM* xpvbmend;
693 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694 xpvbm = PL_xpvbm_root;
695 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696 while (xpvbm < xpvbmend) {
697 xpvbm->xpv_pv = (char*)(xpvbm + 1);
704 # define my_safemalloc(s) (void*)safexmalloc(717,s)
705 # define my_safefree(p) safexfree((char*)p)
707 # define my_safemalloc(s) (void*)safemalloc(s)
708 # define my_safefree(p) safefree((char*)p)
713 #define new_XIV() my_safemalloc(sizeof(XPVIV))
714 #define del_XIV(p) my_safefree(p)
716 #define new_XNV() my_safemalloc(sizeof(XPVNV))
717 #define del_XNV(p) my_safefree(p)
719 #define new_XRV() my_safemalloc(sizeof(XRV))
720 #define del_XRV(p) my_safefree(p)
722 #define new_XPV() my_safemalloc(sizeof(XPV))
723 #define del_XPV(p) my_safefree(p)
725 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726 #define del_XPVIV(p) my_safefree(p)
728 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729 #define del_XPVNV(p) my_safefree(p)
731 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732 #define del_XPVCV(p) my_safefree(p)
734 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735 #define del_XPVAV(p) my_safefree(p)
737 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738 #define del_XPVHV(p) my_safefree(p)
740 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741 #define del_XPVMG(p) my_safefree(p)
743 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744 #define del_XPVLV(p) my_safefree(p)
746 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747 #define del_XPVBM(p) my_safefree(p)
751 #define new_XIV() (void*)new_xiv()
752 #define del_XIV(p) del_xiv((XPVIV*) p)
754 #define new_XNV() (void*)new_xnv()
755 #define del_XNV(p) del_xnv((XPVNV*) p)
757 #define new_XRV() (void*)new_xrv()
758 #define del_XRV(p) del_xrv((XRV*) p)
760 #define new_XPV() (void*)new_xpv()
761 #define del_XPV(p) del_xpv((XPV *)p)
763 #define new_XPVIV() (void*)new_xpviv()
764 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
766 #define new_XPVNV() (void*)new_xpvnv()
767 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
769 #define new_XPVCV() (void*)new_xpvcv()
770 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
772 #define new_XPVAV() (void*)new_xpvav()
773 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
775 #define new_XPVHV() (void*)new_xpvhv()
776 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
778 #define new_XPVMG() (void*)new_xpvmg()
779 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
781 #define new_XPVLV() (void*)new_xpvlv()
782 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
784 #define new_XPVBM() (void*)new_xpvbm()
785 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
789 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790 #define del_XPVGV(p) my_safefree(p)
792 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793 #define del_XPVFM(p) my_safefree(p)
795 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796 #define del_XPVIO(p) my_safefree(p)
799 =for apidoc sv_upgrade
801 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
808 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
818 if (SvTYPE(sv) == mt)
824 switch (SvTYPE(sv)) {
845 else if (mt < SVt_PVIV)
862 pv = (char*)SvRV(sv);
882 else if (mt == SVt_NV)
893 del_XPVIV(SvANY(sv));
903 del_XPVNV(SvANY(sv));
913 del_XPVMG(SvANY(sv));
916 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
921 Perl_croak(aTHX_ "Can't upgrade to undef");
923 SvANY(sv) = new_XIV();
927 SvANY(sv) = new_XNV();
931 SvANY(sv) = new_XRV();
935 SvANY(sv) = new_XPV();
941 SvANY(sv) = new_XPVIV();
951 SvANY(sv) = new_XPVNV();
959 SvANY(sv) = new_XPVMG();
969 SvANY(sv) = new_XPVLV();
983 SvANY(sv) = new_XPVAV();
998 SvANY(sv) = new_XPVHV();
1006 SvMAGIC(sv) = magic;
1007 SvSTASH(sv) = stash;
1014 SvANY(sv) = new_XPVCV();
1015 Zero(SvANY(sv), 1, XPVCV);
1021 SvMAGIC(sv) = magic;
1022 SvSTASH(sv) = stash;
1025 SvANY(sv) = new_XPVGV();
1031 SvMAGIC(sv) = magic;
1032 SvSTASH(sv) = stash;
1040 SvANY(sv) = new_XPVBM();
1046 SvMAGIC(sv) = magic;
1047 SvSTASH(sv) = stash;
1053 SvANY(sv) = new_XPVFM();
1054 Zero(SvANY(sv), 1, XPVFM);
1060 SvMAGIC(sv) = magic;
1061 SvSTASH(sv) = stash;
1064 SvANY(sv) = new_XPVIO();
1065 Zero(SvANY(sv), 1, XPVIO);
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
1073 IoPAGE_LEN(sv) = 60;
1076 SvFLAGS(sv) &= ~SVTYPEMASK;
1082 Perl_sv_backoff(pTHX_ register SV *sv)
1086 char *s = SvPVX(sv);
1087 SvLEN(sv) += SvIVX(sv);
1088 SvPVX(sv) -= SvIVX(sv);
1090 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1092 SvFLAGS(sv) &= ~SVf_OOK;
1099 Expands the character buffer in the SV. This will use C<sv_unref> and will
1100 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1107 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1111 #ifdef HAS_64K_LIMIT
1112 if (newlen >= 0x10000) {
1113 PerlIO_printf(Perl_debug_log,
1114 "Allocation too large: %"UVxf"\n", (UV)newlen);
1117 #endif /* HAS_64K_LIMIT */
1120 if (SvTYPE(sv) < SVt_PV) {
1121 sv_upgrade(sv, SVt_PV);
1124 else if (SvOOK(sv)) { /* pv is offset? */
1127 if (newlen > SvLEN(sv))
1128 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129 #ifdef HAS_64K_LIMIT
1130 if (newlen >= 0x10000)
1136 if (newlen > SvLEN(sv)) { /* need more room? */
1137 if (SvLEN(sv) && s) {
1138 #if defined(MYMALLOC) && !defined(LEAKTEST)
1139 STRLEN l = malloced_size((void*)SvPVX(sv));
1145 Renew(s,newlen,char);
1148 New(703,s,newlen,char);
1150 SvLEN_set(sv, newlen);
1156 =for apidoc sv_setiv
1158 Copies an integer into the given SV. Does not handle 'set' magic. See
1165 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1167 SV_CHECK_THINKFIRST(sv);
1168 switch (SvTYPE(sv)) {
1170 sv_upgrade(sv, SVt_IV);
1173 sv_upgrade(sv, SVt_PVNV);
1177 sv_upgrade(sv, SVt_PVIV);
1188 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189 PL_op_desc[PL_op->op_type]);
1192 (void)SvIOK_only(sv); /* validate number */
1198 =for apidoc sv_setiv_mg
1200 Like C<sv_setiv>, but also handles 'set' magic.
1206 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1213 =for apidoc sv_setuv
1215 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1222 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1230 =for apidoc sv_setuv_mg
1232 Like C<sv_setuv>, but also handles 'set' magic.
1238 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1245 =for apidoc sv_setnv
1247 Copies a double into the given SV. Does not handle 'set' magic. See
1254 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1256 SV_CHECK_THINKFIRST(sv);
1257 switch (SvTYPE(sv)) {
1260 sv_upgrade(sv, SVt_NV);
1265 sv_upgrade(sv, SVt_PVNV);
1276 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277 PL_op_name[PL_op->op_type]);
1281 (void)SvNOK_only(sv); /* validate number */
1286 =for apidoc sv_setnv_mg
1288 Like C<sv_setnv>, but also handles 'set' magic.
1294 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1301 S_not_a_number(pTHX_ SV *sv)
1307 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308 /* each *s can expand to 4 chars + "...\0",
1309 i.e. need room for 8 chars */
1311 for (s = SvPVX(sv); *s && d < limit; s++) {
1313 if (ch & 128 && !isPRINT_LC(ch)) {
1322 else if (ch == '\r') {
1326 else if (ch == '\f') {
1330 else if (ch == '\\') {
1334 else if (isPRINT_LC(ch))
1349 Perl_warner(aTHX_ WARN_NUMERIC,
1350 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351 PL_op_desc[PL_op->op_type]);
1353 Perl_warner(aTHX_ WARN_NUMERIC,
1354 "Argument \"%s\" isn't numeric", tmpbuf);
1357 /* the number can be converted to integer with atol() or atoll() */
1358 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1363 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1364 until proven guilty, assume that things are not that bad... */
1367 Perl_sv_2iv(pTHX_ register SV *sv)
1371 if (SvGMAGICAL(sv)) {
1376 return I_V(SvNVX(sv));
1378 if (SvPOKp(sv) && SvLEN(sv))
1381 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1383 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1389 if (SvTHINKFIRST(sv)) {
1392 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1393 return SvIV(tmpstr);
1394 return PTR2IV(SvRV(sv));
1396 if (SvREADONLY(sv) && !SvOK(sv)) {
1398 if (ckWARN(WARN_UNINITIALIZED))
1405 return (IV)(SvUVX(sv));
1412 /* We can cache the IV/UV value even if it not good enough
1413 * to reconstruct NV, since the conversion to PV will prefer
1417 if (SvTYPE(sv) == SVt_NV)
1418 sv_upgrade(sv, SVt_PVNV);
1421 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1422 SvIVX(sv) = I_V(SvNVX(sv));
1424 SvUVX(sv) = U_V(SvNVX(sv));
1427 DEBUG_c(PerlIO_printf(Perl_debug_log,
1428 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1432 return (IV)SvUVX(sv);
1435 else if (SvPOKp(sv) && SvLEN(sv)) {
1436 I32 numtype = looks_like_number(sv);
1438 /* We want to avoid a possible problem when we cache an IV which
1439 may be later translated to an NV, and the resulting NV is not
1440 the translation of the initial data.
1442 This means that if we cache such an IV, we need to cache the
1443 NV as well. Moreover, we trade speed for space, and do not
1444 cache the NV if not needed.
1446 if (numtype & IS_NUMBER_NOT_IV) {
1447 /* May be not an integer. Need to cache NV if we cache IV
1448 * - otherwise future conversion to NV will be wrong. */
1451 d = Atof(SvPVX(sv));
1453 if (SvTYPE(sv) < SVt_PVNV)
1454 sv_upgrade(sv, SVt_PVNV);
1458 #if defined(USE_LONG_DOUBLE)
1459 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1460 PTR2UV(sv), SvNVX(sv)));
1462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1463 PTR2UV(sv), SvNVX(sv)));
1465 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1466 SvIVX(sv) = I_V(SvNVX(sv));
1468 SvUVX(sv) = U_V(SvNVX(sv));
1474 /* The NV may be reconstructed from IV - safe to cache IV,
1475 which may be calculated by atol(). */
1476 if (SvTYPE(sv) == SVt_PV)
1477 sv_upgrade(sv, SVt_PVIV);
1479 SvIVX(sv) = Atol(SvPVX(sv));
1481 else { /* Not a number. Cache 0. */
1484 if (SvTYPE(sv) < SVt_PVIV)
1485 sv_upgrade(sv, SVt_PVIV);
1488 if (ckWARN(WARN_NUMERIC))
1494 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1496 if (SvTYPE(sv) < SVt_IV)
1497 /* Typically the caller expects that sv_any is not NULL now. */
1498 sv_upgrade(sv, SVt_IV);
1501 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1502 PTR2UV(sv),SvIVX(sv)));
1503 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1507 Perl_sv_2uv(pTHX_ register SV *sv)
1511 if (SvGMAGICAL(sv)) {
1516 return U_V(SvNVX(sv));
1517 if (SvPOKp(sv) && SvLEN(sv))
1520 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1522 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1528 if (SvTHINKFIRST(sv)) {
1531 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1532 return SvUV(tmpstr);
1533 return PTR2UV(SvRV(sv));
1535 if (SvREADONLY(sv) && !SvOK(sv)) {
1537 if (ckWARN(WARN_UNINITIALIZED))
1547 return (UV)SvIVX(sv);
1551 /* We can cache the IV/UV value even if it not good enough
1552 * to reconstruct NV, since the conversion to PV will prefer
1555 if (SvTYPE(sv) == SVt_NV)
1556 sv_upgrade(sv, SVt_PVNV);
1558 if (SvNVX(sv) >= -0.5) {
1560 SvUVX(sv) = U_V(SvNVX(sv));
1563 SvIVX(sv) = I_V(SvNVX(sv));
1565 DEBUG_c(PerlIO_printf(Perl_debug_log,
1566 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1569 (IV)(UV)SvIVX(sv)));
1570 return (UV)SvIVX(sv);
1573 else if (SvPOKp(sv) && SvLEN(sv)) {
1574 I32 numtype = looks_like_number(sv);
1576 /* We want to avoid a possible problem when we cache a UV which
1577 may be later translated to an NV, and the resulting NV is not
1578 the translation of the initial data.
1580 This means that if we cache such a UV, we need to cache the
1581 NV as well. Moreover, we trade speed for space, and do not
1582 cache the NV if not needed.
1584 if (numtype & IS_NUMBER_NOT_IV) {
1585 /* May be not an integer. Need to cache NV if we cache IV
1586 * - otherwise future conversion to NV will be wrong. */
1589 d = Atof(SvPVX(sv));
1591 if (SvTYPE(sv) < SVt_PVNV)
1592 sv_upgrade(sv, SVt_PVNV);
1596 #if defined(USE_LONG_DOUBLE)
1597 DEBUG_c(PerlIO_printf(Perl_debug_log,
1598 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1599 PTR2UV(sv), SvNVX(sv)));
1601 DEBUG_c(PerlIO_printf(Perl_debug_log,
1602 "0x%"UVxf" 2nv(%g)\n",
1603 PTR2UV(sv), SvNVX(sv)));
1605 if (SvNVX(sv) < -0.5) {
1606 SvIVX(sv) = I_V(SvNVX(sv));
1609 SvUVX(sv) = U_V(SvNVX(sv));
1613 else if (numtype & IS_NUMBER_NEG) {
1614 /* The NV may be reconstructed from IV - safe to cache IV,
1615 which may be calculated by atol(). */
1616 if (SvTYPE(sv) == SVt_PV)
1617 sv_upgrade(sv, SVt_PVIV);
1619 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1621 else if (numtype) { /* Non-negative */
1622 /* The NV may be reconstructed from UV - safe to cache UV,
1623 which may be calculated by strtoul()/atol. */
1624 if (SvTYPE(sv) == SVt_PV)
1625 sv_upgrade(sv, SVt_PVIV);
1627 (void)SvIsUV_on(sv);
1629 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1630 #else /* no atou(), but we know the number fits into IV... */
1631 /* The only problem may be if it is negative... */
1632 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1635 else { /* Not a number. Cache 0. */
1638 if (SvTYPE(sv) < SVt_PVIV)
1639 sv_upgrade(sv, SVt_PVIV);
1640 SvUVX(sv) = 0; /* We assume that 0s have the
1641 same bitmap in IV and UV. */
1643 (void)SvIsUV_on(sv);
1644 if (ckWARN(WARN_NUMERIC))
1649 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1651 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1654 if (SvTYPE(sv) < SVt_IV)
1655 /* Typically the caller expects that sv_any is not NULL now. */
1656 sv_upgrade(sv, SVt_IV);
1660 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1661 PTR2UV(sv),SvUVX(sv)));
1662 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1666 Perl_sv_2nv(pTHX_ register SV *sv)
1670 if (SvGMAGICAL(sv)) {
1674 if (SvPOKp(sv) && SvLEN(sv)) {
1676 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1678 return Atof(SvPVX(sv));
1682 return (NV)SvUVX(sv);
1684 return (NV)SvIVX(sv);
1687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1689 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1695 if (SvTHINKFIRST(sv)) {
1698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1699 return SvNV(tmpstr);
1700 return PTR2NV(SvRV(sv));
1702 if (SvREADONLY(sv) && !SvOK(sv)) {
1704 if (ckWARN(WARN_UNINITIALIZED))
1709 if (SvTYPE(sv) < SVt_NV) {
1710 if (SvTYPE(sv) == SVt_IV)
1711 sv_upgrade(sv, SVt_PVNV);
1713 sv_upgrade(sv, SVt_NV);
1714 #if defined(USE_LONG_DOUBLE)
1716 RESTORE_NUMERIC_STANDARD();
1717 PerlIO_printf(Perl_debug_log,
1718 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1719 PTR2UV(sv), SvNVX(sv));
1720 RESTORE_NUMERIC_LOCAL();
1724 RESTORE_NUMERIC_STANDARD();
1725 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1726 PTR2UV(sv), SvNVX(sv));
1727 RESTORE_NUMERIC_LOCAL();
1731 else if (SvTYPE(sv) < SVt_PVNV)
1732 sv_upgrade(sv, SVt_PVNV);
1734 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1736 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1738 else if (SvPOKp(sv) && SvLEN(sv)) {
1740 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1742 SvNVX(sv) = Atof(SvPVX(sv));
1746 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1748 if (SvTYPE(sv) < SVt_NV)
1749 /* Typically the caller expects that sv_any is not NULL now. */
1750 sv_upgrade(sv, SVt_NV);
1754 #if defined(USE_LONG_DOUBLE)
1756 RESTORE_NUMERIC_STANDARD();
1757 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1758 PTR2UV(sv), SvNVX(sv));
1759 RESTORE_NUMERIC_LOCAL();
1763 RESTORE_NUMERIC_STANDARD();
1764 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1765 PTR2UV(sv), SvNVX(sv));
1766 RESTORE_NUMERIC_LOCAL();
1773 S_asIV(pTHX_ SV *sv)
1775 I32 numtype = looks_like_number(sv);
1778 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1779 return Atol(SvPVX(sv));
1782 if (ckWARN(WARN_NUMERIC))
1785 d = Atof(SvPVX(sv));
1790 S_asUV(pTHX_ SV *sv)
1792 I32 numtype = looks_like_number(sv);
1795 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1796 return Strtoul(SvPVX(sv), Null(char**), 10);
1800 if (ckWARN(WARN_NUMERIC))
1803 return U_V(Atof(SvPVX(sv)));
1807 * Returns a combination of (advisory only - can get false negatives)
1808 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1810 * 0 if does not look like number.
1812 * In fact possible values are 0 and
1813 * IS_NUMBER_TO_INT_BY_ATOL 123
1814 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1815 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1816 * with a possible addition of IS_NUMBER_NEG.
1820 =for apidoc looks_like_number
1822 Test if an the content of an SV looks like a number (or is a
1829 Perl_looks_like_number(pTHX_ SV *sv)
1832 register char *send;
1833 register char *sbegin;
1834 register char *nbegin;
1842 else if (SvPOKp(sv))
1843 sbegin = SvPV(sv, len);
1846 send = sbegin + len;
1853 numtype = IS_NUMBER_NEG;
1860 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1861 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1865 /* next must be digit or the radix separator */
1869 } while (isDIGIT(*s));
1871 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1872 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1874 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1877 #ifdef USE_LOCALE_NUMERIC
1878 || IS_NUMERIC_RADIX(*s)
1882 numtype |= IS_NUMBER_NOT_IV;
1883 while (isDIGIT(*s)) /* optional digits after the radix */
1888 #ifdef USE_LOCALE_NUMERIC
1889 || IS_NUMERIC_RADIX(*s)
1893 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1894 /* no digits before the radix means we need digits after it */
1898 } while (isDIGIT(*s));
1906 /* we can have an optional exponent part */
1907 if (*s == 'e' || *s == 'E') {
1908 numtype &= ~IS_NUMBER_NEG;
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1911 if (*s == '+' || *s == '-')
1916 } while (isDIGIT(*s));
1925 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1926 return IS_NUMBER_TO_INT_BY_ATOL;
1931 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1934 return sv_2pv(sv, &n_a);
1937 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1939 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1942 char *ptr = buf + TYPE_CHARS(UV);
1957 *--ptr = '0' + (uv % 10);
1966 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1971 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1972 char *tmpbuf = tbuf;
1978 if (SvGMAGICAL(sv)) {
1986 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
1988 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
1993 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1998 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2000 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2007 if (SvTHINKFIRST(sv)) {
2010 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2011 return SvPV(tmpstr,*lp);
2018 switch (SvTYPE(sv)) {
2020 if ( ((SvFLAGS(sv) &
2021 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2022 == (SVs_OBJECT|SVs_RMG))
2023 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2024 && (mg = mg_find(sv, 'r'))) {
2026 regexp *re = (regexp *)mg->mg_obj;
2029 char *fptr = "msix";
2034 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2036 while(ch = *fptr++) {
2038 reflags[left++] = ch;
2041 reflags[right--] = ch;
2046 reflags[left] = '-';
2050 mg->mg_len = re->prelen + 4 + left;
2051 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2052 Copy("(?", mg->mg_ptr, 2, char);
2053 Copy(reflags, mg->mg_ptr+2, left, char);
2054 Copy(":", mg->mg_ptr+left+2, 1, char);
2055 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2056 mg->mg_ptr[mg->mg_len - 1] = ')';
2057 mg->mg_ptr[mg->mg_len] = 0;
2059 PL_reginterp_cnt += re->program[0].next_off;
2071 case SVt_PVBM: s = "SCALAR"; break;
2072 case SVt_PVLV: s = "LVALUE"; break;
2073 case SVt_PVAV: s = "ARRAY"; break;
2074 case SVt_PVHV: s = "HASH"; break;
2075 case SVt_PVCV: s = "CODE"; break;
2076 case SVt_PVGV: s = "GLOB"; break;
2077 case SVt_PVFM: s = "FORMAT"; break;
2078 case SVt_PVIO: s = "IO"; break;
2079 default: s = "UNKNOWN"; break;
2083 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2086 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2092 if (SvREADONLY(sv) && !SvOK(sv)) {
2094 if (ckWARN(WARN_UNINITIALIZED))
2100 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2101 /* XXXX 64-bit? IV may have better precision... */
2102 /* I tried changing this for to be 64-bit-aware and
2103 * the t/op/numconvert.t became very, very, angry.
2105 if (SvTYPE(sv) < SVt_PVNV)
2106 sv_upgrade(sv, SVt_PVNV);
2109 olderrno = errno; /* some Xenix systems wipe out errno here */
2111 if (SvNVX(sv) == 0.0)
2112 (void)strcpy(s,"0");
2116 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2119 #ifdef FIXNEGATIVEZERO
2120 if (*s == '-' && s[1] == '0' && !s[2])
2129 else if (SvIOKp(sv)) {
2130 U32 isIOK = SvIOK(sv);
2131 U32 isUIOK = SvIsUV(sv);
2132 char buf[TYPE_CHARS(UV)];
2135 if (SvTYPE(sv) < SVt_PVIV)
2136 sv_upgrade(sv, SVt_PVIV);
2138 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2140 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2141 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2142 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2143 SvCUR_set(sv, ebuf - ptr);
2156 if (ckWARN(WARN_UNINITIALIZED)
2157 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2162 if (SvTYPE(sv) < SVt_PV)
2163 /* Typically the caller expects that sv_any is not NULL now. */
2164 sv_upgrade(sv, SVt_PV);
2167 *lp = s - SvPVX(sv);
2170 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2171 PTR2UV(sv),SvPVX(sv)));
2175 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2176 /* Sneaky stuff here */
2180 tsv = newSVpv(tmpbuf, 0);
2196 len = strlen(tmpbuf);
2198 #ifdef FIXNEGATIVEZERO
2199 if (len == 2 && t[0] == '-' && t[1] == '0') {
2204 (void)SvUPGRADE(sv, SVt_PV);
2206 s = SvGROW(sv, len + 1);
2215 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2218 return sv_2pvbyte(sv, &n_a);
2222 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2224 return sv_2pv(sv,lp);
2228 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2231 return sv_2pvutf8(sv, &n_a);
2235 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2237 sv_utf8_upgrade(sv);
2238 return sv_2pv(sv,lp);
2241 /* This function is only called on magical items */
2243 Perl_sv_2bool(pTHX_ register SV *sv)
2253 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2254 return SvTRUE(tmpsv);
2255 return SvRV(sv) != 0;
2258 register XPV* Xpvtmp;
2259 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2260 (*Xpvtmp->xpv_pv > '0' ||
2261 Xpvtmp->xpv_cur > 1 ||
2262 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2269 return SvIVX(sv) != 0;
2272 return SvNVX(sv) != 0.0;
2280 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2285 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2288 /* This function could be much more efficient if we had a FLAG
2289 * to signal if there are any hibit chars in the string
2292 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2299 SvGROW(sv, SvCUR(sv) + hicount + 1);
2301 src = SvEND(sv) - 1;
2302 SvCUR_set(sv, SvCUR(sv) + hicount);
2303 dst = SvEND(sv) - 1;
2308 uv_to_utf8((U8*)dst, (U8)*src--);
2321 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2323 if (SvPOK(sv) && SvUTF8(sv)) {
2324 char *c = SvPVX(sv);
2326 /* need to figure out if this is possible at all first */
2327 while (c < SvEND(sv)) {
2330 UV uv = utf8_to_uv(c, &len);
2335 /* XXX might want to make a callback here instead */
2349 char *src = first_hi;
2350 char *dst = first_hi;
2351 while (src < SvEND(sv)) {
2354 U8 u = (U8)utf8_to_uv(src, &len);
2362 SvCUR_set(sv, dst - SvPVX(sv));
2370 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2372 sv_utf8_upgrade(sv);
2377 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2381 bool has_utf = FALSE;
2382 if (!sv_utf8_downgrade(sv, TRUE))
2385 /* it is actually just a matter of turning the utf8 flag on, but
2386 * we want to make sure everything inside is valid utf8 first.
2389 while (c < SvEND(sv)) {
2392 (void)utf8_to_uv((U8*)c, &len);
2412 /* Note: sv_setsv() should not be called with a source string that needs
2413 * to be reused, since it may destroy the source string if it is marked
2418 =for apidoc sv_setsv
2420 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2421 The source SV may be destroyed if it is mortal. Does not handle 'set'
2422 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2429 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2432 register U32 sflags;
2438 SV_CHECK_THINKFIRST(dstr);
2440 sstr = &PL_sv_undef;
2441 stype = SvTYPE(sstr);
2442 dtype = SvTYPE(dstr);
2446 /* There's a lot of redundancy below but we're going for speed here */
2451 if (dtype != SVt_PVGV) {
2452 (void)SvOK_off(dstr);
2460 sv_upgrade(dstr, SVt_IV);
2463 sv_upgrade(dstr, SVt_PVNV);
2467 sv_upgrade(dstr, SVt_PVIV);
2470 (void)SvIOK_only(dstr);
2471 SvIVX(dstr) = SvIVX(sstr);
2484 sv_upgrade(dstr, SVt_NV);
2489 sv_upgrade(dstr, SVt_PVNV);
2492 SvNVX(dstr) = SvNVX(sstr);
2493 (void)SvNOK_only(dstr);
2501 sv_upgrade(dstr, SVt_RV);
2502 else if (dtype == SVt_PVGV &&
2503 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2506 if (GvIMPORTED(dstr) != GVf_IMPORTED
2507 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2509 GvIMPORTED_on(dstr);
2520 sv_upgrade(dstr, SVt_PV);
2523 if (dtype < SVt_PVIV)
2524 sv_upgrade(dstr, SVt_PVIV);
2527 if (dtype < SVt_PVNV)
2528 sv_upgrade(dstr, SVt_PVNV);
2535 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2536 PL_op_name[PL_op->op_type]);
2538 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2542 if (dtype <= SVt_PVGV) {
2544 if (dtype != SVt_PVGV) {
2545 char *name = GvNAME(sstr);
2546 STRLEN len = GvNAMELEN(sstr);
2547 sv_upgrade(dstr, SVt_PVGV);
2548 sv_magic(dstr, dstr, '*', name, len);
2549 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2550 GvNAME(dstr) = savepvn(name, len);
2551 GvNAMELEN(dstr) = len;
2552 SvFAKE_on(dstr); /* can coerce to non-glob */
2554 /* ahem, death to those who redefine active sort subs */
2555 else if (PL_curstackinfo->si_type == PERLSI_SORT
2556 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2557 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2559 (void)SvOK_off(dstr);
2560 GvINTRO_off(dstr); /* one-shot flag */
2562 GvGP(dstr) = gp_ref(GvGP(sstr));
2564 if (GvIMPORTED(dstr) != GVf_IMPORTED
2565 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2567 GvIMPORTED_on(dstr);
2575 if (SvGMAGICAL(sstr)) {
2577 if (SvTYPE(sstr) != stype) {
2578 stype = SvTYPE(sstr);
2579 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2583 if (stype == SVt_PVLV)
2584 (void)SvUPGRADE(dstr, SVt_PVNV);
2586 (void)SvUPGRADE(dstr, stype);
2589 sflags = SvFLAGS(sstr);
2591 if (sflags & SVf_ROK) {
2592 if (dtype >= SVt_PV) {
2593 if (dtype == SVt_PVGV) {
2594 SV *sref = SvREFCNT_inc(SvRV(sstr));
2596 int intro = GvINTRO(dstr);
2601 GvINTRO_off(dstr); /* one-shot flag */
2602 Newz(602,gp, 1, GP);
2603 GvGP(dstr) = gp_ref(gp);
2604 GvSV(dstr) = NEWSV(72,0);
2605 GvLINE(dstr) = CopLINE(PL_curcop);
2606 GvEGV(dstr) = (GV*)dstr;
2609 switch (SvTYPE(sref)) {
2612 SAVESPTR(GvAV(dstr));
2614 dref = (SV*)GvAV(dstr);
2615 GvAV(dstr) = (AV*)sref;
2616 if (GvIMPORTED_AV_off(dstr)
2617 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2619 GvIMPORTED_AV_on(dstr);
2624 SAVESPTR(GvHV(dstr));
2626 dref = (SV*)GvHV(dstr);
2627 GvHV(dstr) = (HV*)sref;
2628 if (GvIMPORTED_HV_off(dstr)
2629 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2631 GvIMPORTED_HV_on(dstr);
2636 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2637 SvREFCNT_dec(GvCV(dstr));
2638 GvCV(dstr) = Nullcv;
2639 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2640 PL_sub_generation++;
2642 SAVESPTR(GvCV(dstr));
2645 dref = (SV*)GvCV(dstr);
2646 if (GvCV(dstr) != (CV*)sref) {
2647 CV* cv = GvCV(dstr);
2649 if (!GvCVGEN((GV*)dstr) &&
2650 (CvROOT(cv) || CvXSUB(cv)))
2652 SV *const_sv = cv_const_sv(cv);
2653 bool const_changed = TRUE;
2655 const_changed = sv_cmp(const_sv,
2656 op_const_sv(CvSTART((CV*)sref),
2658 /* ahem, death to those who redefine
2659 * active sort subs */
2660 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2661 PL_sortcop == CvSTART(cv))
2663 "Can't redefine active sort subroutine %s",
2664 GvENAME((GV*)dstr));
2665 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2666 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2667 && HvNAME(GvSTASH(CvGV(cv)))
2668 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2670 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2671 "Constant subroutine %s redefined"
2672 : "Subroutine %s redefined",
2673 GvENAME((GV*)dstr));
2676 cv_ckproto(cv, (GV*)dstr,
2677 SvPOK(sref) ? SvPVX(sref) : Nullch);
2679 GvCV(dstr) = (CV*)sref;
2680 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2681 GvASSUMECV_on(dstr);
2682 PL_sub_generation++;
2684 if (GvIMPORTED_CV_off(dstr)
2685 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2687 GvIMPORTED_CV_on(dstr);
2692 SAVESPTR(GvIOp(dstr));
2694 dref = (SV*)GvIOp(dstr);
2695 GvIOp(dstr) = (IO*)sref;
2699 SAVESPTR(GvSV(dstr));
2701 dref = (SV*)GvSV(dstr);
2703 if (GvIMPORTED_SV_off(dstr)
2704 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2706 GvIMPORTED_SV_on(dstr);
2718 (void)SvOOK_off(dstr); /* backoff */
2720 Safefree(SvPVX(dstr));
2721 SvLEN(dstr)=SvCUR(dstr)=0;
2724 (void)SvOK_off(dstr);
2725 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2727 if (sflags & SVp_NOK) {
2729 SvNVX(dstr) = SvNVX(sstr);
2731 if (sflags & SVp_IOK) {
2732 (void)SvIOK_on(dstr);
2733 SvIVX(dstr) = SvIVX(sstr);
2737 if (SvAMAGIC(sstr)) {
2741 else if (sflags & SVp_POK) {
2744 * Check to see if we can just swipe the string. If so, it's a
2745 * possible small lose on short strings, but a big win on long ones.
2746 * It might even be a win on short strings if SvPVX(dstr)
2747 * has to be allocated and SvPVX(sstr) has to be freed.
2750 if (SvTEMP(sstr) && /* slated for free anyway? */
2751 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2752 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2754 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2756 SvFLAGS(dstr) &= ~SVf_OOK;
2757 Safefree(SvPVX(dstr) - SvIVX(dstr));
2759 else if (SvLEN(dstr))
2760 Safefree(SvPVX(dstr));
2762 (void)SvPOK_only(dstr);
2763 SvPV_set(dstr, SvPVX(sstr));
2764 SvLEN_set(dstr, SvLEN(sstr));
2765 SvCUR_set(dstr, SvCUR(sstr));
2767 (void)SvOK_off(sstr);
2768 SvPV_set(sstr, Nullch);
2773 else { /* have to copy actual string */
2774 STRLEN len = SvCUR(sstr);
2776 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2777 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2778 SvCUR_set(dstr, len);
2779 *SvEND(dstr) = '\0';
2780 (void)SvPOK_only(dstr);
2785 if (sflags & SVp_NOK) {
2787 SvNVX(dstr) = SvNVX(sstr);
2789 if (sflags & SVp_IOK) {
2790 (void)SvIOK_on(dstr);
2791 SvIVX(dstr) = SvIVX(sstr);
2796 else if (sflags & SVp_NOK) {
2797 SvNVX(dstr) = SvNVX(sstr);
2798 (void)SvNOK_only(dstr);
2800 (void)SvIOK_on(dstr);
2801 SvIVX(dstr) = SvIVX(sstr);
2802 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2807 else if (sflags & SVp_IOK) {
2808 (void)SvIOK_only(dstr);
2809 SvIVX(dstr) = SvIVX(sstr);
2814 if (dtype == SVt_PVGV) {
2815 if (ckWARN(WARN_UNSAFE))
2816 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2819 (void)SvOK_off(dstr);
2825 =for apidoc sv_setsv_mg
2827 Like C<sv_setsv>, but also handles 'set' magic.
2833 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2835 sv_setsv(dstr,sstr);
2840 =for apidoc sv_setpvn
2842 Copies a string into an SV. The C<len> parameter indicates the number of
2843 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2849 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2851 register char *dptr;
2852 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2853 elicit a warning, but it won't hurt. */
2854 SV_CHECK_THINKFIRST(sv);
2859 (void)SvUPGRADE(sv, SVt_PV);
2861 SvGROW(sv, len + 1);
2863 Move(ptr,dptr,len,char);
2866 (void)SvPOK_only(sv); /* validate pointer */
2871 =for apidoc sv_setpvn_mg
2873 Like C<sv_setpvn>, but also handles 'set' magic.
2879 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2881 sv_setpvn(sv,ptr,len);
2886 =for apidoc sv_setpv
2888 Copies a string into an SV. The string must be null-terminated. Does not
2889 handle 'set' magic. See C<sv_setpv_mg>.
2895 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2897 register STRLEN len;
2899 SV_CHECK_THINKFIRST(sv);
2905 (void)SvUPGRADE(sv, SVt_PV);
2907 SvGROW(sv, len + 1);
2908 Move(ptr,SvPVX(sv),len+1,char);
2910 (void)SvPOK_only(sv); /* validate pointer */
2915 =for apidoc sv_setpv_mg
2917 Like C<sv_setpv>, but also handles 'set' magic.
2923 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2930 =for apidoc sv_usepvn
2932 Tells an SV to use C<ptr> to find its string value. Normally the string is
2933 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2934 The C<ptr> should point to memory that was allocated by C<malloc>. The
2935 string length, C<len>, must be supplied. This function will realloc the
2936 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2937 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2938 See C<sv_usepvn_mg>.
2944 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2946 SV_CHECK_THINKFIRST(sv);
2947 (void)SvUPGRADE(sv, SVt_PV);
2952 (void)SvOOK_off(sv);
2953 if (SvPVX(sv) && SvLEN(sv))
2954 Safefree(SvPVX(sv));
2955 Renew(ptr, len+1, char);
2958 SvLEN_set(sv, len+1);
2960 (void)SvPOK_only(sv); /* validate pointer */
2965 =for apidoc sv_usepvn_mg
2967 Like C<sv_usepvn>, but also handles 'set' magic.
2973 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2975 sv_usepvn(sv,ptr,len);
2980 Perl_sv_force_normal(pTHX_ register SV *sv)
2982 if (SvREADONLY(sv)) {
2984 if (PL_curcop != &PL_compiling)
2985 Perl_croak(aTHX_ PL_no_modify);
2989 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2996 Efficient removal of characters from the beginning of the string buffer.
2997 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2998 the string buffer. The C<ptr> becomes the first character of the adjusted
3005 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3009 register STRLEN delta;
3011 if (!ptr || !SvPOKp(sv))
3013 SV_CHECK_THINKFIRST(sv);
3014 if (SvTYPE(sv) < SVt_PVIV)
3015 sv_upgrade(sv,SVt_PVIV);
3018 if (!SvLEN(sv)) { /* make copy of shared string */
3019 char *pvx = SvPVX(sv);
3020 STRLEN len = SvCUR(sv);
3021 SvGROW(sv, len + 1);
3022 Move(pvx,SvPVX(sv),len,char);
3026 SvFLAGS(sv) |= SVf_OOK;
3028 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3029 delta = ptr - SvPVX(sv);
3037 =for apidoc sv_catpvn
3039 Concatenates the string onto the end of the string which is in the SV. The
3040 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3041 'set' magic. See C<sv_catpvn_mg>.
3047 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3052 junk = SvPV_force(sv, tlen);
3053 SvGROW(sv, tlen + len + 1);
3056 Move(ptr,SvPVX(sv)+tlen,len,char);
3059 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3064 =for apidoc sv_catpvn_mg
3066 Like C<sv_catpvn>, but also handles 'set' magic.
3072 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3074 sv_catpvn(sv,ptr,len);
3079 =for apidoc sv_catsv
3081 Concatenates the string from SV C<ssv> onto the end of the string in SV
3082 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3088 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3094 if (s = SvPV(sstr, len)) {
3096 sv_utf8_upgrade(dstr);
3097 sv_catpvn(dstr,s,len);
3104 =for apidoc sv_catsv_mg
3106 Like C<sv_catsv>, but also handles 'set' magic.
3112 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3114 sv_catsv(dstr,sstr);
3119 =for apidoc sv_catpv
3121 Concatenates the string onto the end of the string which is in the SV.
3122 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3128 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3130 register STRLEN len;
3136 junk = SvPV_force(sv, tlen);
3138 SvGROW(sv, tlen + len + 1);
3141 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3143 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3148 =for apidoc sv_catpv_mg
3150 Like C<sv_catpv>, but also handles 'set' magic.
3156 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3163 Perl_newSV(pTHX_ STRLEN len)
3169 sv_upgrade(sv, SVt_PV);
3170 SvGROW(sv, len + 1);
3175 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3178 =for apidoc sv_magic
3180 Adds magic to an SV.
3186 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3190 if (SvREADONLY(sv)) {
3192 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3193 Perl_croak(aTHX_ PL_no_modify);
3195 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3196 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3203 (void)SvUPGRADE(sv, SVt_PVMG);
3205 Newz(702,mg, 1, MAGIC);
3206 mg->mg_moremagic = SvMAGIC(sv);
3209 if (!obj || obj == sv || how == '#' || how == 'r')
3213 mg->mg_obj = SvREFCNT_inc(obj);
3214 mg->mg_flags |= MGf_REFCOUNTED;
3217 mg->mg_len = namlen;
3220 mg->mg_ptr = savepvn(name, namlen);
3221 else if (namlen == HEf_SVKEY)
3222 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3226 mg->mg_virtual = &PL_vtbl_sv;
3229 mg->mg_virtual = &PL_vtbl_amagic;
3232 mg->mg_virtual = &PL_vtbl_amagicelem;
3238 mg->mg_virtual = &PL_vtbl_bm;
3241 mg->mg_virtual = &PL_vtbl_regdata;
3244 mg->mg_virtual = &PL_vtbl_regdatum;
3247 mg->mg_virtual = &PL_vtbl_env;
3250 mg->mg_virtual = &PL_vtbl_fm;
3253 mg->mg_virtual = &PL_vtbl_envelem;
3256 mg->mg_virtual = &PL_vtbl_mglob;
3259 mg->mg_virtual = &PL_vtbl_isa;
3262 mg->mg_virtual = &PL_vtbl_isaelem;
3265 mg->mg_virtual = &PL_vtbl_nkeys;
3272 mg->mg_virtual = &PL_vtbl_dbline;
3276 mg->mg_virtual = &PL_vtbl_mutex;
3278 #endif /* USE_THREADS */
3279 #ifdef USE_LOCALE_COLLATE
3281 mg->mg_virtual = &PL_vtbl_collxfrm;
3283 #endif /* USE_LOCALE_COLLATE */
3285 mg->mg_virtual = &PL_vtbl_pack;
3289 mg->mg_virtual = &PL_vtbl_packelem;
3292 mg->mg_virtual = &PL_vtbl_regexp;
3295 mg->mg_virtual = &PL_vtbl_sig;
3298 mg->mg_virtual = &PL_vtbl_sigelem;
3301 mg->mg_virtual = &PL_vtbl_taint;
3305 mg->mg_virtual = &PL_vtbl_uvar;
3308 mg->mg_virtual = &PL_vtbl_vec;
3311 mg->mg_virtual = &PL_vtbl_substr;
3314 mg->mg_virtual = &PL_vtbl_defelem;
3317 mg->mg_virtual = &PL_vtbl_glob;
3320 mg->mg_virtual = &PL_vtbl_arylen;
3323 mg->mg_virtual = &PL_vtbl_pos;
3326 mg->mg_virtual = &PL_vtbl_backref;
3328 case '~': /* Reserved for use by extensions not perl internals. */
3329 /* Useful for attaching extension internal data to perl vars. */
3330 /* Note that multiple extensions may clash if magical scalars */
3331 /* etc holding private data from one are passed to another. */
3335 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3339 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3343 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3347 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3350 for (mg = *mgp; mg; mg = *mgp) {
3351 if (mg->mg_type == type) {
3352 MGVTBL* vtbl = mg->mg_virtual;
3353 *mgp = mg->mg_moremagic;
3354 if (vtbl && vtbl->svt_free)
3355 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3356 if (mg->mg_ptr && mg->mg_type != 'g')
3357 if (mg->mg_len >= 0)
3358 Safefree(mg->mg_ptr);
3359 else if (mg->mg_len == HEf_SVKEY)
3360 SvREFCNT_dec((SV*)mg->mg_ptr);
3361 if (mg->mg_flags & MGf_REFCOUNTED)
3362 SvREFCNT_dec(mg->mg_obj);
3366 mgp = &mg->mg_moremagic;
3370 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3377 Perl_sv_rvweaken(pTHX_ SV *sv)
3380 if (!SvOK(sv)) /* let undefs pass */
3383 Perl_croak(aTHX_ "Can't weaken a nonreference");
3384 else if (SvWEAKREF(sv)) {
3386 if (ckWARN(WARN_MISC))
3387 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3391 sv_add_backref(tsv, sv);
3398 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3402 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3403 av = (AV*)mg->mg_obj;
3406 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3407 SvREFCNT_dec(av); /* for sv_magic */
3413 S_sv_del_backref(pTHX_ SV *sv)
3420 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3421 Perl_croak(aTHX_ "panic: del_backref");
3422 av = (AV *)mg->mg_obj;
3427 svp[i] = &PL_sv_undef; /* XXX */
3434 =for apidoc sv_insert
3436 Inserts a string at the specified offset/length within the SV. Similar to
3437 the Perl substr() function.
3443 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3447 register char *midend;
3448 register char *bigend;
3454 Perl_croak(aTHX_ "Can't modify non-existent substring");
3455 SvPV_force(bigstr, curlen);
3456 if (offset + len > curlen) {
3457 SvGROW(bigstr, offset+len+1);
3458 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3459 SvCUR_set(bigstr, offset+len);
3463 i = littlelen - len;
3464 if (i > 0) { /* string might grow */
3465 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3466 mid = big + offset + len;
3467 midend = bigend = big + SvCUR(bigstr);
3470 while (midend > mid) /* shove everything down */
3471 *--bigend = *--midend;
3472 Move(little,big+offset,littlelen,char);
3478 Move(little,SvPVX(bigstr)+offset,len,char);
3483 big = SvPVX(bigstr);
3486 bigend = big + SvCUR(bigstr);
3488 if (midend > bigend)
3489 Perl_croak(aTHX_ "panic: sv_insert");
3491 if (mid - big > bigend - midend) { /* faster to shorten from end */
3493 Move(little, mid, littlelen,char);
3496 i = bigend - midend;
3498 Move(midend, mid, i,char);
3502 SvCUR_set(bigstr, mid - big);
3505 else if (i = mid - big) { /* faster from front */
3506 midend -= littlelen;
3508 sv_chop(bigstr,midend-i);
3513 Move(little, mid, littlelen,char);
3515 else if (littlelen) {
3516 midend -= littlelen;
3517 sv_chop(bigstr,midend);
3518 Move(little,midend,littlelen,char);
3521 sv_chop(bigstr,midend);
3526 /* make sv point to what nstr did */
3529 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3532 U32 refcnt = SvREFCNT(sv);
3533 SV_CHECK_THINKFIRST(sv);
3534 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3535 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3536 if (SvMAGICAL(sv)) {
3540 sv_upgrade(nsv, SVt_PVMG);
3541 SvMAGIC(nsv) = SvMAGIC(sv);
3542 SvFLAGS(nsv) |= SvMAGICAL(sv);
3548 assert(!SvREFCNT(sv));
3549 StructCopy(nsv,sv,SV);
3550 SvREFCNT(sv) = refcnt;
3551 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3556 Perl_sv_clear(pTHX_ register SV *sv)
3560 assert(SvREFCNT(sv) == 0);
3564 if (PL_defstash) { /* Still have a symbol table? */
3569 Zero(&tmpref, 1, SV);
3570 sv_upgrade(&tmpref, SVt_RV);
3572 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3573 SvREFCNT(&tmpref) = 1;
3576 stash = SvSTASH(sv);
3577 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3580 PUSHSTACKi(PERLSI_DESTROY);
3581 SvRV(&tmpref) = SvREFCNT_inc(sv);
3586 call_sv((SV*)GvCV(destructor),
3587 G_DISCARD|G_EVAL|G_KEEPERR);
3593 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3595 del_XRV(SvANY(&tmpref));
3598 if (PL_in_clean_objs)
3599 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3601 /* DESTROY gave object new lease on life */
3607 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3608 SvOBJECT_off(sv); /* Curse the object. */
3609 if (SvTYPE(sv) != SVt_PVIO)
3610 --PL_sv_objcount; /* XXX Might want something more general */
3613 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3616 switch (SvTYPE(sv)) {
3619 IoIFP(sv) != PerlIO_stdin() &&
3620 IoIFP(sv) != PerlIO_stdout() &&
3621 IoIFP(sv) != PerlIO_stderr())
3623 io_close((IO*)sv, FALSE);
3625 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3626 PerlDir_close(IoDIRP(sv));
3627 IoDIRP(sv) = (DIR*)NULL;
3628 Safefree(IoTOP_NAME(sv));
3629 Safefree(IoFMT_NAME(sv));
3630 Safefree(IoBOTTOM_NAME(sv));
3645 SvREFCNT_dec(LvTARG(sv));
3649 Safefree(GvNAME(sv));
3650 /* cannot decrease stash refcount yet, as we might recursively delete
3651 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3652 of stash until current sv is completely gone.
3653 -- JohnPC, 27 Mar 1998 */
3654 stash = GvSTASH(sv);
3660 (void)SvOOK_off(sv);
3668 SvREFCNT_dec(SvRV(sv));
3670 else if (SvPVX(sv) && SvLEN(sv))
3671 Safefree(SvPVX(sv));
3681 switch (SvTYPE(sv)) {
3697 del_XPVIV(SvANY(sv));
3700 del_XPVNV(SvANY(sv));
3703 del_XPVMG(SvANY(sv));
3706 del_XPVLV(SvANY(sv));
3709 del_XPVAV(SvANY(sv));
3712 del_XPVHV(SvANY(sv));
3715 del_XPVCV(SvANY(sv));
3718 del_XPVGV(SvANY(sv));
3719 /* code duplication for increased performance. */
3720 SvFLAGS(sv) &= SVf_BREAK;
3721 SvFLAGS(sv) |= SVTYPEMASK;
3722 /* decrease refcount of the stash that owns this GV, if any */
3724 SvREFCNT_dec(stash);
3725 return; /* not break, SvFLAGS reset already happened */
3727 del_XPVBM(SvANY(sv));
3730 del_XPVFM(SvANY(sv));
3733 del_XPVIO(SvANY(sv));
3736 SvFLAGS(sv) &= SVf_BREAK;
3737 SvFLAGS(sv) |= SVTYPEMASK;
3741 Perl_sv_newref(pTHX_ SV *sv)
3744 ATOMIC_INC(SvREFCNT(sv));
3749 Perl_sv_free(pTHX_ SV *sv)
3752 int refcount_is_zero;
3756 if (SvREFCNT(sv) == 0) {
3757 if (SvFLAGS(sv) & SVf_BREAK)
3759 if (PL_in_clean_all) /* All is fair */
3761 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3762 /* make sure SvREFCNT(sv)==0 happens very seldom */
3763 SvREFCNT(sv) = (~(U32)0)/2;
3766 if (ckWARN_d(WARN_INTERNAL))
3767 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3770 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3771 if (!refcount_is_zero)
3775 if (ckWARN_d(WARN_DEBUGGING))
3776 Perl_warner(aTHX_ WARN_DEBUGGING,
3777 "Attempt to free temp prematurely: SV 0x%"UVxf,
3782 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3783 /* make sure SvREFCNT(sv)==0 happens very seldom */
3784 SvREFCNT(sv) = (~(U32)0)/2;
3795 Returns the length of the string in the SV. See also C<SvCUR>.
3801 Perl_sv_len(pTHX_ register SV *sv)
3810 len = mg_length(sv);
3812 junk = SvPV(sv, len);
3817 Perl_sv_len_utf8(pTHX_ register SV *sv)
3828 len = mg_length(sv);
3831 s = (U8*)SvPV(sv, len);
3842 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3847 I32 uoffset = *offsetp;
3853 start = s = (U8*)SvPV(sv, len);
3855 while (s < send && uoffset--)
3859 *offsetp = s - start;
3863 while (s < send && ulen--)
3873 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3882 s = (U8*)SvPV(sv, len);
3884 Perl_croak(aTHX_ "panic: bad byte offset");
3885 send = s + *offsetp;
3893 if (ckWARN_d(WARN_UTF8))
3894 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3904 Returns a boolean indicating whether the strings in the two SVs are
3911 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3923 pv1 = SvPV(str1, cur1);
3928 pv2 = SvPV(str2, cur2);
3933 return memEQ(pv1, pv2, cur1);
3939 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3940 string in C<sv1> is less than, equal to, or greater than the string in
3947 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3955 pv1 = SvPV(str1, cur1);
3963 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3964 /* must upgrade other to UTF8 first */
3966 sv_utf8_upgrade(str2);
3969 sv_utf8_upgrade(str1);
3970 /* refresh pointer and length */
3979 pv2 = sv_2pv(str2, &cur2);
3987 return cur2 ? -1 : 0;
3992 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3995 return retval < 0 ? -1 : 1;
4000 return cur1 < cur2 ? -1 : 1;
4004 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4006 #ifdef USE_LOCALE_COLLATE
4012 if (PL_collation_standard)
4016 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4018 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4020 if (!pv1 || !len1) {
4031 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4034 return retval < 0 ? -1 : 1;
4037 * When the result of collation is equality, that doesn't mean
4038 * that there are no differences -- some locales exclude some
4039 * characters from consideration. So to avoid false equalities,
4040 * we use the raw string as a tiebreaker.
4046 #endif /* USE_LOCALE_COLLATE */
4048 return sv_cmp(sv1, sv2);
4051 #ifdef USE_LOCALE_COLLATE
4053 * Any scalar variable may carry an 'o' magic that contains the
4054 * scalar data of the variable transformed to such a format that
4055 * a normal memory comparison can be used to compare the data
4056 * according to the locale settings.
4059 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4063 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4064 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4069 Safefree(mg->mg_ptr);
4071 if ((xf = mem_collxfrm(s, len, &xlen))) {
4072 if (SvREADONLY(sv)) {
4075 return xf + sizeof(PL_collation_ix);
4078 sv_magic(sv, 0, 'o', 0, 0);
4079 mg = mg_find(sv, 'o');
4092 if (mg && mg->mg_ptr) {
4094 return mg->mg_ptr + sizeof(PL_collation_ix);
4102 #endif /* USE_LOCALE_COLLATE */
4105 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4110 register STDCHAR rslast;
4111 register STDCHAR *bp;
4115 SV_CHECK_THINKFIRST(sv);
4116 (void)SvUPGRADE(sv, SVt_PV);
4120 if (RsSNARF(PL_rs)) {
4124 else if (RsRECORD(PL_rs)) {
4125 I32 recsize, bytesread;
4128 /* Grab the size of the record we're getting */
4129 recsize = SvIV(SvRV(PL_rs));
4130 (void)SvPOK_only(sv); /* Validate pointer */
4131 buffer = SvGROW(sv, recsize + 1);
4134 /* VMS wants read instead of fread, because fread doesn't respect */
4135 /* RMS record boundaries. This is not necessarily a good thing to be */
4136 /* doing, but we've got no other real choice */
4137 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4139 bytesread = PerlIO_read(fp, buffer, recsize);
4141 SvCUR_set(sv, bytesread);
4142 buffer[bytesread] = '\0';
4143 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4145 else if (RsPARA(PL_rs)) {
4150 rsptr = SvPV(PL_rs, rslen);
4151 rslast = rslen ? rsptr[rslen - 1] : '\0';
4153 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4154 do { /* to make sure file boundaries work right */
4157 i = PerlIO_getc(fp);
4161 PerlIO_ungetc(fp,i);
4167 /* See if we know enough about I/O mechanism to cheat it ! */
4169 /* This used to be #ifdef test - it is made run-time test for ease
4170 of abstracting out stdio interface. One call should be cheap
4171 enough here - and may even be a macro allowing compile
4175 if (PerlIO_fast_gets(fp)) {
4178 * We're going to steal some values from the stdio struct
4179 * and put EVERYTHING in the innermost loop into registers.
4181 register STDCHAR *ptr;
4185 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4186 /* An ungetc()d char is handled separately from the regular
4187 * buffer, so we getc() it back out and stuff it in the buffer.
4189 i = PerlIO_getc(fp);
4190 if (i == EOF) return 0;
4191 *(--((*fp)->_ptr)) = (unsigned char) i;
4195 /* Here is some breathtakingly efficient cheating */
4197 cnt = PerlIO_get_cnt(fp); /* get count into register */
4198 (void)SvPOK_only(sv); /* validate pointer */
4199 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4200 if (cnt > 80 && SvLEN(sv) > append) {
4201 shortbuffered = cnt - SvLEN(sv) + append + 1;
4202 cnt -= shortbuffered;
4206 /* remember that cnt can be negative */
4207 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4212 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4213 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4214 DEBUG_P(PerlIO_printf(Perl_debug_log,
4215 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4216 DEBUG_P(PerlIO_printf(Perl_debug_log,
4217 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4218 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4219 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4224 while (cnt > 0) { /* this | eat */
4226 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4227 goto thats_all_folks; /* screams | sed :-) */
4231 Copy(ptr, bp, cnt, char); /* this | eat */
4232 bp += cnt; /* screams | dust */
4233 ptr += cnt; /* louder | sed :-) */
4238 if (shortbuffered) { /* oh well, must extend */
4239 cnt = shortbuffered;
4241 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4243 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4244 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4248 DEBUG_P(PerlIO_printf(Perl_debug_log,
4249 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4250 PTR2UV(ptr),(long)cnt));
4251 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4252 DEBUG_P(PerlIO_printf(Perl_debug_log,
4253 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4254 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4255 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4256 /* This used to call 'filbuf' in stdio form, but as that behaves like
4257 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4258 another abstraction. */
4259 i = PerlIO_getc(fp); /* get more characters */
4260 DEBUG_P(PerlIO_printf(Perl_debug_log,
4261 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4262 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4263 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4264 cnt = PerlIO_get_cnt(fp);
4265 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4266 DEBUG_P(PerlIO_printf(Perl_debug_log,
4267 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4269 if (i == EOF) /* all done for ever? */
4270 goto thats_really_all_folks;
4272 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4274 SvGROW(sv, bpx + cnt + 2);
4275 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4277 *bp++ = i; /* store character from PerlIO_getc */
4279 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4280 goto thats_all_folks;
4284 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4285 memNE((char*)bp - rslen, rsptr, rslen))
4286 goto screamer; /* go back to the fray */
4287 thats_really_all_folks:
4289 cnt += shortbuffered;
4290 DEBUG_P(PerlIO_printf(Perl_debug_log,
4291 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4292 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4293 DEBUG_P(PerlIO_printf(Perl_debug_log,
4294 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4295 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4296 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4298 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4299 DEBUG_P(PerlIO_printf(Perl_debug_log,
4300 "Screamer: done, len=%ld, string=|%.*s|\n",
4301 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4306 /*The big, slow, and stupid way */
4309 /* Need to work around EPOC SDK features */
4310 /* On WINS: MS VC5 generates calls to _chkstk, */
4311 /* if a `large' stack frame is allocated */
4312 /* gcc on MARM does not generate calls like these */
4318 register STDCHAR *bpe = buf + sizeof(buf);
4320 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4321 ; /* keep reading */
4325 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4326 /* Accomodate broken VAXC compiler, which applies U8 cast to
4327 * both args of ?: operator, causing EOF to change into 255
4329 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4333 sv_catpvn(sv, (char *) buf, cnt);
4335 sv_setpvn(sv, (char *) buf, cnt);
4337 if (i != EOF && /* joy */
4339 SvCUR(sv) < rslen ||
4340 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4344 * If we're reading from a TTY and we get a short read,
4345 * indicating that the user hit his EOF character, we need
4346 * to notice it now, because if we try to read from the TTY
4347 * again, the EOF condition will disappear.
4349 * The comparison of cnt to sizeof(buf) is an optimization
4350 * that prevents unnecessary calls to feof().
4354 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4359 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4360 while (i != EOF) { /* to make sure file boundaries work right */
4361 i = PerlIO_getc(fp);
4363 PerlIO_ungetc(fp,i);
4369 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4376 Auto-increment of the value in the SV.
4382 Perl_sv_inc(pTHX_ register SV *sv)
4391 if (SvTHINKFIRST(sv)) {
4392 if (SvREADONLY(sv)) {
4394 if (PL_curcop != &PL_compiling)
4395 Perl_croak(aTHX_ PL_no_modify);
4399 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4401 i = PTR2IV(SvRV(sv));
4406 flags = SvFLAGS(sv);
4407 if (flags & SVp_NOK) {
4408 (void)SvNOK_only(sv);
4412 if (flags & SVp_IOK) {
4414 if (SvUVX(sv) == UV_MAX)
4415 sv_setnv(sv, (NV)UV_MAX + 1.0);
4417 (void)SvIOK_only_UV(sv);
4420 if (SvIVX(sv) == IV_MAX)
4421 sv_setnv(sv, (NV)IV_MAX + 1.0);
4423 (void)SvIOK_only(sv);
4429 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4430 if ((flags & SVTYPEMASK) < SVt_PVNV)
4431 sv_upgrade(sv, SVt_NV);
4433 (void)SvNOK_only(sv);
4437 while (isALPHA(*d)) d++;
4438 while (isDIGIT(*d)) d++;
4440 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4444 while (d >= SvPVX(sv)) {
4452 /* MKS: The original code here died if letters weren't consecutive.
4453 * at least it didn't have to worry about non-C locales. The
4454 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4455 * arranged in order (although not consecutively) and that only
4456 * [A-Za-z] are accepted by isALPHA in the C locale.
4458 if (*d != 'z' && *d != 'Z') {
4459 do { ++*d; } while (!isALPHA(*d));
4462 *(d--) -= 'z' - 'a';
4467 *(d--) -= 'z' - 'a' + 1;
4471 /* oh,oh, the number grew */
4472 SvGROW(sv, SvCUR(sv) + 2);
4474 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4485 Auto-decrement of the value in the SV.
4491 Perl_sv_dec(pTHX_ register SV *sv)
4499 if (SvTHINKFIRST(sv)) {
4500 if (SvREADONLY(sv)) {
4502 if (PL_curcop != &PL_compiling)
4503 Perl_croak(aTHX_ PL_no_modify);
4507 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4509 i = PTR2IV(SvRV(sv));
4514 flags = SvFLAGS(sv);
4515 if (flags & SVp_NOK) {
4517 (void)SvNOK_only(sv);
4520 if (flags & SVp_IOK) {
4522 if (SvUVX(sv) == 0) {
4523 (void)SvIOK_only(sv);
4527 (void)SvIOK_only_UV(sv);
4531 if (SvIVX(sv) == IV_MIN)
4532 sv_setnv(sv, (NV)IV_MIN - 1.0);
4534 (void)SvIOK_only(sv);
4540 if (!(flags & SVp_POK)) {
4541 if ((flags & SVTYPEMASK) < SVt_PVNV)
4542 sv_upgrade(sv, SVt_NV);
4544 (void)SvNOK_only(sv);
4547 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4551 =for apidoc sv_mortalcopy
4553 Creates a new SV which is a copy of the original SV. The new SV is marked
4559 /* Make a string that will exist for the duration of the expression
4560 * evaluation. Actually, it may have to last longer than that, but
4561 * hopefully we won't free it until it has been assigned to a
4562 * permanent location. */
4565 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4571 sv_setsv(sv,oldstr);
4573 PL_tmps_stack[++PL_tmps_ix] = sv;
4579 =for apidoc sv_newmortal
4581 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4587 Perl_sv_newmortal(pTHX)
4593 SvFLAGS(sv) = SVs_TEMP;
4595 PL_tmps_stack[++PL_tmps_ix] = sv;
4600 =for apidoc sv_2mortal
4602 Marks an SV as mortal. The SV will be destroyed when the current context
4608 /* same thing without the copying */
4611 Perl_sv_2mortal(pTHX_ register SV *sv)
4616 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4619 PL_tmps_stack[++PL_tmps_ix] = sv;
4627 Creates a new SV and copies a string into it. The reference count for the
4628 SV is set to 1. If C<len> is zero, Perl will compute the length using
4629 strlen(). For efficiency, consider using C<newSVpvn> instead.
4635 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4642 sv_setpvn(sv,s,len);
4647 =for apidoc newSVpvn
4649 Creates a new SV and copies a string into it. The reference count for the
4650 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4651 string. You are responsible for ensuring that the source string is at least
4658 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4663 sv_setpvn(sv,s,len);
4667 #if defined(PERL_IMPLICIT_CONTEXT)
4669 Perl_newSVpvf_nocontext(const char* pat, ...)
4674 va_start(args, pat);
4675 sv = vnewSVpvf(pat, &args);
4682 =for apidoc newSVpvf
4684 Creates a new SV an initialize it with the string formatted like
4691 Perl_newSVpvf(pTHX_ const char* pat, ...)
4695 va_start(args, pat);
4696 sv = vnewSVpvf(pat, &args);
4702 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4706 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4713 Creates a new SV and copies a floating point value into it.
4714 The reference count for the SV is set to 1.
4720 Perl_newSVnv(pTHX_ NV n)
4732 Creates a new SV and copies an integer into it. The reference count for the
4739 Perl_newSViv(pTHX_ IV i)
4749 =for apidoc newRV_noinc
4751 Creates an RV wrapper for an SV. The reference count for the original
4752 SV is B<not> incremented.
4758 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4764 sv_upgrade(sv, SVt_RV);
4771 /* newRV_inc is #defined to newRV in sv.h */
4773 Perl_newRV(pTHX_ SV *tmpRef)
4775 return newRV_noinc(SvREFCNT_inc(tmpRef));
4781 Creates a new SV which is an exact duplicate of the original SV.
4786 /* make an exact duplicate of old */
4789 Perl_newSVsv(pTHX_ register SV *old)
4796 if (SvTYPE(old) == SVTYPEMASK) {
4797 if (ckWARN_d(WARN_INTERNAL))
4798 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4813 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4821 char todo[PERL_UCHAR_MAX+1];
4826 if (!*s) { /* reset ?? searches */
4827 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4828 pm->op_pmdynflags &= ~PMdf_USED;
4833 /* reset variables */
4835 if (!HvARRAY(stash))
4838 Zero(todo, 256, char);
4840 i = (unsigned char)*s;
4844 max = (unsigned char)*s++;
4845 for ( ; i <= max; i++) {
4848 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4849 for (entry = HvARRAY(stash)[i];
4851 entry = HeNEXT(entry))
4853 if (!todo[(U8)*HeKEY(entry)])
4855 gv = (GV*)HeVAL(entry);
4857 if (SvTHINKFIRST(sv)) {
4858 if (!SvREADONLY(sv) && SvROK(sv))
4863 if (SvTYPE(sv) >= SVt_PV) {
4865 if (SvPVX(sv) != Nullch)
4872 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4874 #ifndef VMS /* VMS has no environ array */
4876 environ[0] = Nullch;
4885 Perl_sv_2io(pTHX_ SV *sv)
4891 switch (SvTYPE(sv)) {
4899 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4903 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4905 return sv_2io(SvRV(sv));
4906 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4912 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4919 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4926 return *gvp = Nullgv, Nullcv;
4927 switch (SvTYPE(sv)) {
4947 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4948 tryAMAGICunDEREF(to_cv);
4951 if (SvTYPE(sv) == SVt_PVCV) {
4960 Perl_croak(aTHX_ "Not a subroutine reference");
4965 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4971 if (lref && !GvCVu(gv)) {
4974 tmpsv = NEWSV(704,0);
4975 gv_efullname3(tmpsv, gv, Nullch);
4976 /* XXX this is probably not what they think they're getting.
4977 * It has the same effect as "sub name;", i.e. just a forward
4979 newSUB(start_subparse(FALSE, 0),
4980 newSVOP(OP_CONST, 0, tmpsv),
4985 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4992 Perl_sv_true(pTHX_ register SV *sv)
4999 if ((tXpv = (XPV*)SvANY(sv)) &&
5000 (tXpv->xpv_cur > 1 ||
5001 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5008 return SvIVX(sv) != 0;
5011 return SvNVX(sv) != 0.0;
5013 return sv_2bool(sv);
5019 Perl_sv_iv(pTHX_ register SV *sv)
5023 return (IV)SvUVX(sv);
5030 Perl_sv_uv(pTHX_ register SV *sv)
5035 return (UV)SvIVX(sv);
5041 Perl_sv_nv(pTHX_ register SV *sv)
5049 Perl_sv_pv(pTHX_ SV *sv)
5056 return sv_2pv(sv, &n_a);
5060 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5066 return sv_2pv(sv, lp);
5070 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5074 if (SvTHINKFIRST(sv) && !SvROK(sv))
5075 sv_force_normal(sv);
5081 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5083 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5084 PL_op_name[PL_op->op_type]);
5088 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5093 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5094 SvGROW(sv, len + 1);
5095 Move(s,SvPVX(sv),len,char);
5100 SvPOK_on(sv); /* validate pointer */
5102 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5103 PTR2UV(sv),SvPVX(sv)));
5110 Perl_sv_pvbyte(pTHX_ SV *sv)
5116 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5118 return sv_pvn(sv,lp);
5122 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5124 return sv_pvn_force(sv,lp);
5128 Perl_sv_pvutf8(pTHX_ SV *sv)
5130 sv_utf8_upgrade(sv);
5135 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5137 sv_utf8_upgrade(sv);
5138 return sv_pvn(sv,lp);
5142 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5144 sv_utf8_upgrade(sv);
5145 return sv_pvn_force(sv,lp);
5149 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5151 if (ob && SvOBJECT(sv))
5152 return HvNAME(SvSTASH(sv));
5154 switch (SvTYPE(sv)) {
5168 case SVt_PVLV: return "LVALUE";
5169 case SVt_PVAV: return "ARRAY";
5170 case SVt_PVHV: return "HASH";
5171 case SVt_PVCV: return "CODE";
5172 case SVt_PVGV: return "GLOB";
5173 case SVt_PVFM: return "FORMAT";
5174 default: return "UNKNOWN";
5180 =for apidoc sv_isobject
5182 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5183 object. If the SV is not an RV, or if the object is not blessed, then this
5190 Perl_sv_isobject(pTHX_ SV *sv)
5207 Returns a boolean indicating whether the SV is blessed into the specified
5208 class. This does not check for subtypes; use C<sv_derived_from> to verify
5209 an inheritance relationship.
5215 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5227 return strEQ(HvNAME(SvSTASH(sv)), name);
5233 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5234 it will be upgraded to one. If C<classname> is non-null then the new SV will
5235 be blessed in the specified package. The new SV is returned and its
5236 reference count is 1.
5242 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5249 SV_CHECK_THINKFIRST(rv);
5252 if (SvTYPE(rv) < SVt_RV)
5253 sv_upgrade(rv, SVt_RV);
5260 HV* stash = gv_stashpv(classname, TRUE);
5261 (void)sv_bless(rv, stash);
5267 =for apidoc sv_setref_pv
5269 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5270 argument will be upgraded to an RV. That RV will be modified to point to
5271 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5272 into the SV. The C<classname> argument indicates the package for the
5273 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5274 will be returned and will have a reference count of 1.
5276 Do not use with other Perl types such as HV, AV, SV, CV, because those
5277 objects will become corrupted by the pointer copy process.
5279 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5285 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5288 sv_setsv(rv, &PL_sv_undef);
5292 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5297 =for apidoc sv_setref_iv
5299 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5300 argument will be upgraded to an RV. That RV will be modified to point to
5301 the new SV. The C<classname> argument indicates the package for the
5302 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5303 will be returned and will have a reference count of 1.
5309 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5311 sv_setiv(newSVrv(rv,classname), iv);
5316 =for apidoc sv_setref_nv
5318 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5319 argument will be upgraded to an RV. That RV will be modified to point to
5320 the new SV. The C<classname> argument indicates the package for the
5321 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5322 will be returned and will have a reference count of 1.
5328 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5330 sv_setnv(newSVrv(rv,classname), nv);
5335 =for apidoc sv_setref_pvn
5337 Copies a string into a new SV, optionally blessing the SV. The length of the
5338 string must be specified with C<n>. The C<rv> argument will be upgraded to
5339 an RV. That RV will be modified to point to the new SV. The C<classname>
5340 argument indicates the package for the blessing. Set C<classname> to
5341 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5342 a reference count of 1.
5344 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5350 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5352 sv_setpvn(newSVrv(rv,classname), pv, n);
5357 =for apidoc sv_bless
5359 Blesses an SV into a specified package. The SV must be an RV. The package
5360 must be designated by its stash (see C<gv_stashpv()>). The reference count
5361 of the SV is unaffected.
5367 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5372 Perl_croak(aTHX_ "Can't bless non-reference value");
5374 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5375 if (SvREADONLY(tmpRef))
5376 Perl_croak(aTHX_ PL_no_modify);
5377 if (SvOBJECT(tmpRef)) {
5378 if (SvTYPE(tmpRef) != SVt_PVIO)
5380 SvREFCNT_dec(SvSTASH(tmpRef));
5383 SvOBJECT_on(tmpRef);
5384 if (SvTYPE(tmpRef) != SVt_PVIO)
5386 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5387 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5398 S_sv_unglob(pTHX_ SV *sv)
5402 assert(SvTYPE(sv) == SVt_PVGV);
5407 SvREFCNT_dec(GvSTASH(sv));
5408 GvSTASH(sv) = Nullhv;
5410 sv_unmagic(sv, '*');
5411 Safefree(GvNAME(sv));
5414 /* need to keep SvANY(sv) in the right arena */
5415 xpvmg = new_XPVMG();
5416 StructCopy(SvANY(sv), xpvmg, XPVMG);
5417 del_XPVGV(SvANY(sv));
5420 SvFLAGS(sv) &= ~SVTYPEMASK;
5421 SvFLAGS(sv) |= SVt_PVMG;
5425 =for apidoc sv_unref
5427 Unsets the RV status of the SV, and decrements the reference count of
5428 whatever was being referenced by the RV. This can almost be thought of
5429 as a reversal of C<newSVrv>. See C<SvROK_off>.
5435 Perl_sv_unref(pTHX_ SV *sv)
5439 if (SvWEAKREF(sv)) {
5447 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5450 sv_2mortal(rv); /* Schedule for freeing later */
5454 Perl_sv_taint(pTHX_ SV *sv)
5456 sv_magic((sv), Nullsv, 't', Nullch, 0);
5460 Perl_sv_untaint(pTHX_ SV *sv)
5462 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5463 MAGIC *mg = mg_find(sv, 't');
5470 Perl_sv_tainted(pTHX_ SV *sv)
5472 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5473 MAGIC *mg = mg_find(sv, 't');
5474 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
5481 =for apidoc sv_setpviv
5483 Copies an integer into the given SV, also updating its string value.
5484 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5490 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5492 char buf[TYPE_CHARS(UV)];
5494 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5496 sv_setpvn(sv, ptr, ebuf - ptr);
5501 =for apidoc sv_setpviv_mg
5503 Like C<sv_setpviv>, but also handles 'set' magic.
5509 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5511 char buf[TYPE_CHARS(UV)];
5513 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5515 sv_setpvn(sv, ptr, ebuf - ptr);
5519 #if defined(PERL_IMPLICIT_CONTEXT)
5521 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5525 va_start(args, pat);
5526 sv_vsetpvf(sv, pat, &args);
5532 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5536 va_start(args, pat);
5537 sv_vsetpvf_mg(sv, pat, &args);
5543 =for apidoc sv_setpvf
5545 Processes its arguments like C<sprintf> and sets an SV to the formatted
5546 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5552 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5555 va_start(args, pat);
5556 sv_vsetpvf(sv, pat, &args);
5561 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5563 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5567 =for apidoc sv_setpvf_mg
5569 Like C<sv_setpvf>, but also handles 'set' magic.
5575 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5578 va_start(args, pat);
5579 sv_vsetpvf_mg(sv, pat, &args);
5584 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5586 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5590 #if defined(PERL_IMPLICIT_CONTEXT)
5592 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5596 va_start(args, pat);
5597 sv_vcatpvf(sv, pat, &args);
5602 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5606 va_start(args, pat);
5607 sv_vcatpvf_mg(sv, pat, &args);
5613 =for apidoc sv_catpvf
5615 Processes its arguments like C<sprintf> and appends the formatted output
5616 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5617 typically be called after calling this function to handle 'set' magic.
5623 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5626 va_start(args, pat);
5627 sv_vcatpvf(sv, pat, &args);
5632 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5634 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5638 =for apidoc sv_catpvf_mg
5640 Like C<sv_catpvf>, but also handles 'set' magic.
5646 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5649 va_start(args, pat);
5650 sv_vcatpvf_mg(sv, pat, &args);
5655 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5657 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5662 =for apidoc sv_vsetpvfn
5664 Works like C<vcatpvfn> but copies the text into the SV instead of
5671 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5673 sv_setpvn(sv, "", 0);
5674 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5678 =for apidoc sv_vcatpvfn
5680 Processes its arguments like C<vsprintf> and appends the formatted output
5681 to an SV. Uses an array of SVs if the C style variable argument list is
5682 missing (NULL). When running with taint checks enabled, indicates via
5683 C<maybe_tainted> if results are untrustworthy (often due to the use of
5690 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5698 static char nullstr[] = "(null)";
5701 /* no matter what, this is a string now */
5702 (void)SvPV_force(sv, origlen);
5704 /* special-case "", "%s", and "%_" */
5707 if (patlen == 2 && pat[0] == '%') {
5711 char *s = va_arg(*args, char*);
5712 sv_catpv(sv, s ? s : nullstr);
5714 else if (svix < svmax) {
5715 sv_catsv(sv, *svargs);
5716 if (DO_UTF8(*svargs))
5722 argsv = va_arg(*args, SV*);
5723 sv_catsv(sv, argsv);
5728 /* See comment on '_' below */
5733 patend = (char*)pat + patlen;
5734 for (p = (char*)pat; p < patend; p = q) {
5742 bool has_precis = FALSE;
5744 bool is_utf = FALSE;
5748 STRLEN esignlen = 0;
5750 char *eptr = Nullch;
5752 /* Times 4: a decimal digit takes more than 3 binary digits.
5753 * NV_DIG: mantissa takes than many decimal digits.
5754 * Plus 32: Playing safe. */
5755 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5756 /* large enough for "%#.#f" --chip */
5757 /* what about long double NVs? --jhi */
5768 for (q = p; q < patend && *q != '%'; ++q) ;
5770 sv_catpvn(sv, p, q - p);
5808 case '1': case '2': case '3':
5809 case '4': case '5': case '6':
5810 case '7': case '8': case '9':
5813 width = width * 10 + (*q++ - '0');
5818 i = va_arg(*args, int);
5820 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5822 width = (i < 0) ? -i : i;
5833 i = va_arg(*args, int);
5835 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5836 precis = (i < 0) ? 0 : i;
5842 precis = precis * 10 + (*q++ - '0');
5859 if (*(q + 1) == 'l') { /* lld */
5886 uv = va_arg(*args, int);
5888 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5889 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5890 eptr = (char*)utf8buf;
5891 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5903 eptr = va_arg(*args, char*);
5905 #ifdef MACOS_TRADITIONAL
5906 /* On MacOS, %#s format is used for Pascal strings */
5911 elen = strlen(eptr);
5914 elen = sizeof nullstr - 1;
5917 else if (svix < svmax) {
5918 argsv = svargs[svix++];
5919 eptr = SvPVx(argsv, elen);
5920 if (DO_UTF8(argsv)) {
5921 if (has_precis && precis < elen) {
5923 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5926 if (width) { /* fudge width (can't fudge elen) */
5927 width += elen - sv_len_utf8(argsv);
5936 argsv = va_arg(*args, SV*);
5937 else if (svix < svmax)
5938 argsv = svargs[svix++];
5941 U8 *str = (U8*)SvPVx(argsv,len);
5943 SV *vsv = NEWSV(73,vlen);
5946 U8 *vptr = (U8*)SvPVX(vsv);
5948 bool utf = DO_UTF8(argsv);
5956 uv = utf8_to_uv(str, &ulen);
5963 eptr = ebuf + sizeof ebuf;
5965 *--eptr = '0' + uv % 10;
5967 elen = (ebuf + sizeof ebuf) - eptr;
5968 while (elen >= vfree-1) {
5969 STRLEN off = vptr - (U8*)SvPVX(vsv);
5973 vptr = (U8*)SvPVX(vsv) + off;
5975 memcpy(vptr, eptr, elen);
5985 SvCUR_set(vsv,vcur);
5993 * The "%_" hack might have to be changed someday,
5994 * if ISO or ANSI decide to use '_' for something.
5995 * So we keep it hidden from users' code.
5999 argsv = va_arg(*args,SV*);
6000 eptr = SvPVx(argsv, elen);
6005 if (has_precis && elen > precis)
6013 uv = PTR2UV(va_arg(*args, void*));
6015 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6030 case 'h': iv = (short)va_arg(*args, int); break;
6031 default: iv = va_arg(*args, int); break;
6032 case 'l': iv = va_arg(*args, long); break;
6033 case 'V': iv = va_arg(*args, IV); break;
6035 case 'q': iv = va_arg(*args, Quad_t); break;
6040 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6042 case 'h': iv = (short)iv; break;
6043 default: iv = (int)iv; break;
6044 case 'l': iv = (long)iv; break;
6047 case 'q': iv = (Quad_t)iv; break;
6054 esignbuf[esignlen++] = plus;
6058 esignbuf[esignlen++] = '-';
6096 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6097 default: uv = va_arg(*args, unsigned); break;
6098 case 'l': uv = va_arg(*args, unsigned long); break;
6099 case 'V': uv = va_arg(*args, UV); break;
6101 case 'q': uv = va_arg(*args, Quad_t); break;
6106 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6108 case 'h': uv = (unsigned short)uv; break;
6109 default: uv = (unsigned)uv; break;
6110 case 'l': uv = (unsigned long)uv; break;
6113 case 'q': uv = (Quad_t)uv; break;
6119 eptr = ebuf + sizeof ebuf;
6125 p = (char*)((c == 'X')
6126 ? "0123456789ABCDEF" : "0123456789abcdef");
6132 esignbuf[esignlen++] = '0';
6133 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6139 *--eptr = '0' + dig;
6141 if (alt && *eptr != '0')
6147 *--eptr = '0' + dig;
6150 esignbuf[esignlen++] = '0';
6151 esignbuf[esignlen++] = 'b';
6154 default: /* it had better be ten or less */
6155 #if defined(PERL_Y2KWARN)
6156 if (ckWARN(WARN_MISC)) {
6158 char *s = SvPV(sv,n);
6159 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6160 && (n == 2 || !isDIGIT(s[n-3])))
6162 Perl_warner(aTHX_ WARN_MISC,
6163 "Possible Y2K bug: %%%c %s",
6164 c, "format string following '19'");
6170 *--eptr = '0' + dig;
6171 } while (uv /= base);
6174 elen = (ebuf + sizeof ebuf) - eptr;
6177 zeros = precis - elen;
6178 else if (precis == 0 && elen == 1 && *eptr == '0')
6183 /* FLOATING POINT */
6186 c = 'f'; /* maybe %F isn't supported here */
6192 /* This is evil, but floating point is even more evil */
6195 nv = va_arg(*args, NV);
6197 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6200 if (c != 'e' && c != 'E') {
6202 (void)frexp(nv, &i);
6203 if (i == PERL_INT_MIN)
6204 Perl_die(aTHX_ "panic: frexp");
6206 need = BIT_DIGITS(i);
6208 need += has_precis ? precis : 6; /* known default */
6212 need += 20; /* fudge factor */
6213 if (PL_efloatsize < need) {
6214 Safefree(PL_efloatbuf);
6215 PL_efloatsize = need + 20; /* more fudge */
6216 New(906, PL_efloatbuf, PL_efloatsize, char);
6217 PL_efloatbuf[0] = '\0';
6220 eptr = ebuf + sizeof ebuf;
6223 #ifdef USE_LONG_DOUBLE
6225 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6226 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6231 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6236 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6249 RESTORE_NUMERIC_STANDARD();
6250 (void)sprintf(PL_efloatbuf, eptr, nv);
6251 RESTORE_NUMERIC_LOCAL();
6254 eptr = PL_efloatbuf;
6255 elen = strlen(PL_efloatbuf);
6261 i = SvCUR(sv) - origlen;
6264 case 'h': *(va_arg(*args, short*)) = i; break;
6265 default: *(va_arg(*args, int*)) = i; break;
6266 case 'l': *(va_arg(*args, long*)) = i; break;
6267 case 'V': *(va_arg(*args, IV*)) = i; break;
6269 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6273 else if (svix < svmax)
6274 sv_setuv(svargs[svix++], (UV)i);
6275 continue; /* not "break" */
6281 if (!args && ckWARN(WARN_PRINTF) &&
6282 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6283 SV *msg = sv_newmortal();
6284 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6285 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6288 Perl_sv_catpvf(aTHX_ msg,
6289 "\"%%%c\"", c & 0xFF);
6291 Perl_sv_catpvf(aTHX_ msg,
6292 "\"%%\\%03"UVof"\"",
6295 sv_catpv(msg, "end of string");
6296 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6299 /* output mangled stuff ... */
6305 /* ... right here, because formatting flags should not apply */
6306 SvGROW(sv, SvCUR(sv) + elen + 1);
6308 memcpy(p, eptr, elen);
6311 SvCUR(sv) = p - SvPVX(sv);
6312 continue; /* not "break" */
6315 have = esignlen + zeros + elen;
6316 need = (have > width ? have : width);
6319 SvGROW(sv, SvCUR(sv) + need + 1);
6321 if (esignlen && fill == '0') {
6322 for (i = 0; i < esignlen; i++)
6326 memset(p, fill, gap);
6329 if (esignlen && fill != '0') {
6330 for (i = 0; i < esignlen; i++)
6334 for (i = zeros; i; i--)
6338 memcpy(p, eptr, elen);
6342 memset(p, ' ', gap);
6348 SvCUR(sv) = p - SvPVX(sv);
6352 #if defined(USE_ITHREADS)
6354 #if defined(USE_THREADS)
6355 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6358 #ifndef OpREFCNT_inc
6359 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
6362 #ifndef GpREFCNT_inc
6363 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6367 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6368 #define av_dup(s) (AV*)sv_dup((SV*)s)
6369 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6370 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6371 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6372 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6373 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6374 #define io_dup(s) (IO*)sv_dup((SV*)s)
6375 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6376 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6377 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6378 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6379 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6382 Perl_re_dup(pTHX_ REGEXP *r)
6384 /* XXX fix when pmop->op_pmregexp becomes shared */
6385 return ReREFCNT_inc(r);
6389 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6393 return (PerlIO*)NULL;
6395 /* look for it in the table first */
6396 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6400 /* create anew and remember what it is */
6401 ret = PerlIO_fdupopen(fp);
6402 ptr_table_store(PL_ptr_table, fp, ret);
6407 Perl_dirp_dup(pTHX_ DIR *dp)
6416 Perl_gp_dup(pTHX_ GP *gp)
6421 /* look for it in the table first */
6422 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6426 /* create anew and remember what it is */
6427 Newz(0, ret, 1, GP);
6428 ptr_table_store(PL_ptr_table, gp, ret);
6431 ret->gp_refcnt = 0; /* must be before any other dups! */
6432 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6433 ret->gp_io = io_dup_inc(gp->gp_io);
6434 ret->gp_form = cv_dup_inc(gp->gp_form);
6435 ret->gp_av = av_dup_inc(gp->gp_av);
6436 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6437 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6438 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6439 ret->gp_cvgen = gp->gp_cvgen;
6440 ret->gp_flags = gp->gp_flags;
6441 ret->gp_line = gp->gp_line;
6442 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6447 Perl_mg_dup(pTHX_ MAGIC *mg)
6449 MAGIC *mgret = (MAGIC*)NULL;
6452 return (MAGIC*)NULL;
6453 /* look for it in the table first */
6454 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6458 for (; mg; mg = mg->mg_moremagic) {
6460 Newz(0, nmg, 1, MAGIC);
6464 mgprev->mg_moremagic = nmg;
6465 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6466 nmg->mg_private = mg->mg_private;
6467 nmg->mg_type = mg->mg_type;
6468 nmg->mg_flags = mg->mg_flags;
6469 if (mg->mg_type == 'r') {
6470 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6473 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6474 ? sv_dup_inc(mg->mg_obj)
6475 : sv_dup(mg->mg_obj);
6477 nmg->mg_len = mg->mg_len;
6478 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6479 if (mg->mg_ptr && mg->mg_type != 'g') {
6480 if (mg->mg_len >= 0) {
6481 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6482 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6483 AMT *amtp = (AMT*)mg->mg_ptr;
6484 AMT *namtp = (AMT*)nmg->mg_ptr;
6486 for (i = 1; i < NofAMmeth; i++) {
6487 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6491 else if (mg->mg_len == HEf_SVKEY)
6492 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6500 Perl_ptr_table_new(pTHX)
6503 Newz(0, tbl, 1, PTR_TBL_t);
6506 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6511 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6513 PTR_TBL_ENT_t *tblent;
6514 UV hash = PTR2UV(sv);
6516 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6517 for (; tblent; tblent = tblent->next) {
6518 if (tblent->oldval == sv)
6519 return tblent->newval;
6525 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6527 PTR_TBL_ENT_t *tblent, **otblent;
6528 /* XXX this may be pessimal on platforms where pointers aren't good
6529 * hash values e.g. if they grow faster in the most significant
6531 UV hash = PTR2UV(oldv);
6535 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6536 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6537 if (tblent->oldval == oldv) {
6538 tblent->newval = newv;
6543 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6544 tblent->oldval = oldv;
6545 tblent->newval = newv;
6546 tblent->next = *otblent;
6549 if (i && tbl->tbl_items > tbl->tbl_max)
6550 ptr_table_split(tbl);
6554 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6556 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6557 UV oldsize = tbl->tbl_max + 1;
6558 UV newsize = oldsize * 2;
6561 Renew(ary, newsize, PTR_TBL_ENT_t*);
6562 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6563 tbl->tbl_max = --newsize;
6565 for (i=0; i < oldsize; i++, ary++) {
6566 PTR_TBL_ENT_t **curentp, **entp, *ent;
6569 curentp = ary + oldsize;
6570 for (entp = ary, ent = *ary; ent; ent = *entp) {
6571 if ((newsize & PTR2UV(ent->oldval)) != i) {
6573 ent->next = *curentp;
6588 Perl_sv_dup(pTHX_ SV *sstr)
6595 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6597 /* look for it in the table first */
6598 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6602 /* create anew and remember what it is */
6604 ptr_table_store(PL_ptr_table, sstr, dstr);
6607 SvFLAGS(dstr) = SvFLAGS(sstr);
6608 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6609 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6612 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6613 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6614 PL_watch_pvx, SvPVX(sstr));
6617 switch (SvTYPE(sstr)) {
6622 SvANY(dstr) = new_XIV();
6623 SvIVX(dstr) = SvIVX(sstr);
6626 SvANY(dstr) = new_XNV();
6627 SvNVX(dstr) = SvNVX(sstr);
6630 SvANY(dstr) = new_XRV();
6631 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6634 SvANY(dstr) = new_XPV();
6635 SvCUR(dstr) = SvCUR(sstr);
6636 SvLEN(dstr) = SvLEN(sstr);
6638 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6639 else if (SvPVX(sstr) && SvLEN(sstr))
6640 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6642 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6645 SvANY(dstr) = new_XPVIV();
6646 SvCUR(dstr) = SvCUR(sstr);
6647 SvLEN(dstr) = SvLEN(sstr);
6648 SvIVX(dstr) = SvIVX(sstr);
6650 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6651 else if (SvPVX(sstr) && SvLEN(sstr))
6652 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6654 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6657 SvANY(dstr) = new_XPVNV();
6658 SvCUR(dstr) = SvCUR(sstr);
6659 SvLEN(dstr) = SvLEN(sstr);
6660 SvIVX(dstr) = SvIVX(sstr);
6661 SvNVX(dstr) = SvNVX(sstr);
6663 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6664 else if (SvPVX(sstr) && SvLEN(sstr))
6665 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6667 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6670 SvANY(dstr) = new_XPVMG();
6671 SvCUR(dstr) = SvCUR(sstr);
6672 SvLEN(dstr) = SvLEN(sstr);
6673 SvIVX(dstr) = SvIVX(sstr);
6674 SvNVX(dstr) = SvNVX(sstr);
6675 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6676 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6678 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6679 else if (SvPVX(sstr) && SvLEN(sstr))
6680 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6682 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6685 SvANY(dstr) = new_XPVBM();
6686 SvCUR(dstr) = SvCUR(sstr);
6687 SvLEN(dstr) = SvLEN(sstr);
6688 SvIVX(dstr) = SvIVX(sstr);
6689 SvNVX(dstr) = SvNVX(sstr);
6690 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6691 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6693 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6694 else if (SvPVX(sstr) && SvLEN(sstr))
6695 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6697 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6698 BmRARE(dstr) = BmRARE(sstr);
6699 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6700 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6703 SvANY(dstr) = new_XPVLV();
6704 SvCUR(dstr) = SvCUR(sstr);
6705 SvLEN(dstr) = SvLEN(sstr);
6706 SvIVX(dstr) = SvIVX(sstr);
6707 SvNVX(dstr) = SvNVX(sstr);
6708 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6709 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6711 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6712 else if (SvPVX(sstr) && SvLEN(sstr))
6713 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6715 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6716 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6717 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6718 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6719 LvTYPE(dstr) = LvTYPE(sstr);
6722 SvANY(dstr) = new_XPVGV();
6723 SvCUR(dstr) = SvCUR(sstr);
6724 SvLEN(dstr) = SvLEN(sstr);
6725 SvIVX(dstr) = SvIVX(sstr);
6726 SvNVX(dstr) = SvNVX(sstr);
6727 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6728 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6730 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6731 else if (SvPVX(sstr) && SvLEN(sstr))
6732 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6734 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6735 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6736 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6737 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6738 GvFLAGS(dstr) = GvFLAGS(sstr);
6739 GvGP(dstr) = gp_dup(GvGP(sstr));
6740 (void)GpREFCNT_inc(GvGP(dstr));
6743 SvANY(dstr) = new_XPVIO();
6744 SvCUR(dstr) = SvCUR(sstr);
6745 SvLEN(dstr) = SvLEN(sstr);
6746 SvIVX(dstr) = SvIVX(sstr);
6747 SvNVX(dstr) = SvNVX(sstr);
6748 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6749 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6751 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6752 else if (SvPVX(sstr) && SvLEN(sstr))
6753 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6755 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6756 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6757 if (IoOFP(sstr) == IoIFP(sstr))
6758 IoOFP(dstr) = IoIFP(dstr);
6760 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6761 /* PL_rsfp_filters entries have fake IoDIRP() */
6762 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6763 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6765 IoDIRP(dstr) = IoDIRP(sstr);
6766 IoLINES(dstr) = IoLINES(sstr);
6767 IoPAGE(dstr) = IoPAGE(sstr);
6768 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6769 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6770 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6771 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6772 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6773 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6774 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6775 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6776 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6777 IoTYPE(dstr) = IoTYPE(sstr);
6778 IoFLAGS(dstr) = IoFLAGS(sstr);
6781 SvANY(dstr) = new_XPVAV();
6782 SvCUR(dstr) = SvCUR(sstr);
6783 SvLEN(dstr) = SvLEN(sstr);
6784 SvIVX(dstr) = SvIVX(sstr);
6785 SvNVX(dstr) = SvNVX(sstr);
6786 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6787 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6788 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6789 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6790 if (AvARRAY((AV*)sstr)) {
6791 SV **dst_ary, **src_ary;
6792 SSize_t items = AvFILLp((AV*)sstr) + 1;
6794 src_ary = AvARRAY((AV*)sstr);
6795 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6796 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6797 SvPVX(dstr) = (char*)dst_ary;
6798 AvALLOC((AV*)dstr) = dst_ary;
6799 if (AvREAL((AV*)sstr)) {
6801 *dst_ary++ = sv_dup_inc(*src_ary++);
6805 *dst_ary++ = sv_dup(*src_ary++);
6807 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6808 while (items-- > 0) {
6809 *dst_ary++ = &PL_sv_undef;
6813 SvPVX(dstr) = Nullch;
6814 AvALLOC((AV*)dstr) = (SV**)NULL;
6818 SvANY(dstr) = new_XPVHV();
6819 SvCUR(dstr) = SvCUR(sstr);
6820 SvLEN(dstr) = SvLEN(sstr);
6821 SvIVX(dstr) = SvIVX(sstr);
6822 SvNVX(dstr) = SvNVX(sstr);
6823 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6824 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6825 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6826 if (HvARRAY((HV*)sstr)) {
6829 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6830 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6831 Newz(0, dxhv->xhv_array,
6832 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6833 while (i <= sxhv->xhv_max) {
6834 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6835 !!HvSHAREKEYS(sstr));
6838 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6841 SvPVX(dstr) = Nullch;
6842 HvEITER((HV*)dstr) = (HE*)NULL;
6844 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6845 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6848 SvANY(dstr) = new_XPVFM();
6849 FmLINES(dstr) = FmLINES(sstr);
6853 SvANY(dstr) = new_XPVCV();
6855 SvCUR(dstr) = SvCUR(sstr);
6856 SvLEN(dstr) = SvLEN(sstr);
6857 SvIVX(dstr) = SvIVX(sstr);
6858 SvNVX(dstr) = SvNVX(sstr);
6859 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6860 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6861 if (SvPVX(sstr) && SvLEN(sstr))
6862 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6864 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6865 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6866 CvSTART(dstr) = CvSTART(sstr);
6867 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6868 CvXSUB(dstr) = CvXSUB(sstr);
6869 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6870 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6871 CvDEPTH(dstr) = CvDEPTH(sstr);
6872 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6873 /* XXX padlists are real, but pretend to be not */
6874 AvREAL_on(CvPADLIST(sstr));
6875 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6876 AvREAL_off(CvPADLIST(sstr));
6877 AvREAL_off(CvPADLIST(dstr));
6880 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6881 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6882 CvFLAGS(dstr) = CvFLAGS(sstr);
6885 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6889 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6896 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6901 return (PERL_CONTEXT*)NULL;
6903 /* look for it in the table first */
6904 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6908 /* create anew and remember what it is */
6909 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6910 ptr_table_store(PL_ptr_table, cxs, ncxs);
6913 PERL_CONTEXT *cx = &cxs[ix];
6914 PERL_CONTEXT *ncx = &ncxs[ix];
6915 ncx->cx_type = cx->cx_type;
6916 if (CxTYPE(cx) == CXt_SUBST) {
6917 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6920 ncx->blk_oldsp = cx->blk_oldsp;
6921 ncx->blk_oldcop = cx->blk_oldcop;
6922 ncx->blk_oldretsp = cx->blk_oldretsp;
6923 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6924 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6925 ncx->blk_oldpm = cx->blk_oldpm;
6926 ncx->blk_gimme = cx->blk_gimme;
6927 switch (CxTYPE(cx)) {
6929 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6930 ? cv_dup_inc(cx->blk_sub.cv)
6931 : cv_dup(cx->blk_sub.cv));
6932 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6933 ? av_dup_inc(cx->blk_sub.argarray)
6935 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6936 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6937 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6938 ncx->blk_sub.lval = cx->blk_sub.lval;
6941 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6942 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6943 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6944 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6945 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6948 ncx->blk_loop.label = cx->blk_loop.label;
6949 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6950 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6951 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6952 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6953 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6954 ? cx->blk_loop.iterdata
6955 : gv_dup((GV*)cx->blk_loop.iterdata));
6956 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6957 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6958 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6959 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6960 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6963 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6964 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6965 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6966 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6979 Perl_si_dup(pTHX_ PERL_SI *si)
6984 return (PERL_SI*)NULL;
6986 /* look for it in the table first */
6987 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6991 /* create anew and remember what it is */
6992 Newz(56, nsi, 1, PERL_SI);
6993 ptr_table_store(PL_ptr_table, si, nsi);
6995 nsi->si_stack = av_dup_inc(si->si_stack);
6996 nsi->si_cxix = si->si_cxix;
6997 nsi->si_cxmax = si->si_cxmax;
6998 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6999 nsi->si_type = si->si_type;
7000 nsi->si_prev = si_dup(si->si_prev);
7001 nsi->si_next = si_dup(si->si_next);
7002 nsi->si_markoff = si->si_markoff;
7007 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7008 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7009 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7010 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7011 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7012 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7013 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7014 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7015 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7016 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7017 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7018 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7021 #define pv_dup_inc(p) SAVEPV(p)
7022 #define pv_dup(p) SAVEPV(p)
7023 #define svp_dup_inc(p,pp) any_dup(p,pp)
7026 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7033 /* look for it in the table first */
7034 ret = ptr_table_fetch(PL_ptr_table, v);
7038 /* see if it is part of the interpreter structure */
7039 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7040 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7048 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7050 ANY *ss = proto_perl->Tsavestack;
7051 I32 ix = proto_perl->Tsavestack_ix;
7052 I32 max = proto_perl->Tsavestack_max;
7065 void (*dptr) (void*);
7066 void (*dxptr) (pTHXo_ void*);
7068 Newz(54, nss, max, ANY);
7074 case SAVEt_ITEM: /* normal string */
7075 sv = (SV*)POPPTR(ss,ix);
7076 TOPPTR(nss,ix) = sv_dup_inc(sv);
7077 sv = (SV*)POPPTR(ss,ix);
7078 TOPPTR(nss,ix) = sv_dup_inc(sv);
7080 case SAVEt_SV: /* scalar reference */
7081 sv = (SV*)POPPTR(ss,ix);
7082 TOPPTR(nss,ix) = sv_dup_inc(sv);
7083 gv = (GV*)POPPTR(ss,ix);
7084 TOPPTR(nss,ix) = gv_dup_inc(gv);
7086 case SAVEt_GENERIC_SVREF: /* generic sv */
7087 case SAVEt_SVREF: /* scalar reference */
7088 sv = (SV*)POPPTR(ss,ix);
7089 TOPPTR(nss,ix) = sv_dup_inc(sv);
7090 ptr = POPPTR(ss,ix);
7091 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7093 case SAVEt_AV: /* array reference */
7094 av = (AV*)POPPTR(ss,ix);
7095 TOPPTR(nss,ix) = av_dup_inc(av);
7096 gv = (GV*)POPPTR(ss,ix);
7097 TOPPTR(nss,ix) = gv_dup(gv);
7099 case SAVEt_HV: /* hash reference */
7100 hv = (HV*)POPPTR(ss,ix);
7101 TOPPTR(nss,ix) = hv_dup_inc(hv);
7102 gv = (GV*)POPPTR(ss,ix);
7103 TOPPTR(nss,ix) = gv_dup(gv);
7105 case SAVEt_INT: /* int reference */
7106 ptr = POPPTR(ss,ix);
7107 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7108 intval = (int)POPINT(ss,ix);
7109 TOPINT(nss,ix) = intval;
7111 case SAVEt_LONG: /* long reference */
7112 ptr = POPPTR(ss,ix);
7113 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7114 longval = (long)POPLONG(ss,ix);
7115 TOPLONG(nss,ix) = longval;
7117 case SAVEt_I32: /* I32 reference */
7118 case SAVEt_I16: /* I16 reference */
7119 case SAVEt_I8: /* I8 reference */
7120 ptr = POPPTR(ss,ix);
7121 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7125 case SAVEt_IV: /* IV reference */
7126 ptr = POPPTR(ss,ix);
7127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7131 case SAVEt_SPTR: /* SV* reference */
7132 ptr = POPPTR(ss,ix);
7133 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7134 sv = (SV*)POPPTR(ss,ix);
7135 TOPPTR(nss,ix) = sv_dup(sv);
7137 case SAVEt_VPTR: /* random* reference */
7138 ptr = POPPTR(ss,ix);
7139 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7140 ptr = POPPTR(ss,ix);
7141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7143 case SAVEt_PPTR: /* char* reference */
7144 ptr = POPPTR(ss,ix);
7145 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7146 c = (char*)POPPTR(ss,ix);
7147 TOPPTR(nss,ix) = pv_dup(c);
7149 case SAVEt_HPTR: /* HV* reference */
7150 ptr = POPPTR(ss,ix);
7151 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7152 hv = (HV*)POPPTR(ss,ix);
7153 TOPPTR(nss,ix) = hv_dup(hv);
7155 case SAVEt_APTR: /* AV* reference */
7156 ptr = POPPTR(ss,ix);
7157 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7158 av = (AV*)POPPTR(ss,ix);
7159 TOPPTR(nss,ix) = av_dup(av);
7162 gv = (GV*)POPPTR(ss,ix);
7163 TOPPTR(nss,ix) = gv_dup(gv);
7165 case SAVEt_GP: /* scalar reference */
7166 gp = (GP*)POPPTR(ss,ix);
7167 TOPPTR(nss,ix) = gp = gp_dup(gp);
7168 (void)GpREFCNT_inc(gp);
7169 gv = (GV*)POPPTR(ss,ix);
7170 TOPPTR(nss,ix) = gv_dup_inc(c);
7171 c = (char*)POPPTR(ss,ix);
7172 TOPPTR(nss,ix) = pv_dup(c);
7179 sv = (SV*)POPPTR(ss,ix);
7180 TOPPTR(nss,ix) = sv_dup_inc(sv);
7183 ptr = POPPTR(ss,ix);
7184 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7185 /* these are assumed to be refcounted properly */
7186 switch (((OP*)ptr)->op_type) {
7193 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7196 TOPPTR(nss,ix) = Nullop;
7201 TOPPTR(nss,ix) = Nullop;
7204 c = (char*)POPPTR(ss,ix);
7205 TOPPTR(nss,ix) = pv_dup_inc(c);
7208 longval = POPLONG(ss,ix);
7209 TOPLONG(nss,ix) = longval;
7212 hv = (HV*)POPPTR(ss,ix);
7213 TOPPTR(nss,ix) = hv_dup_inc(hv);
7214 c = (char*)POPPTR(ss,ix);
7215 TOPPTR(nss,ix) = pv_dup_inc(c);
7219 case SAVEt_DESTRUCTOR:
7220 ptr = POPPTR(ss,ix);
7221 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7222 dptr = POPDPTR(ss,ix);
7223 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7225 case SAVEt_DESTRUCTOR_X:
7226 ptr = POPPTR(ss,ix);
7227 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7228 dxptr = POPDXPTR(ss,ix);
7229 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7231 case SAVEt_REGCONTEXT:
7237 case SAVEt_STACK_POS: /* Position on Perl stack */
7241 case SAVEt_AELEM: /* array element */
7242 sv = (SV*)POPPTR(ss,ix);
7243 TOPPTR(nss,ix) = sv_dup_inc(sv);
7246 av = (AV*)POPPTR(ss,ix);
7247 TOPPTR(nss,ix) = av_dup_inc(av);
7249 case SAVEt_HELEM: /* hash element */
7250 sv = (SV*)POPPTR(ss,ix);
7251 TOPPTR(nss,ix) = sv_dup_inc(sv);
7252 sv = (SV*)POPPTR(ss,ix);
7253 TOPPTR(nss,ix) = sv_dup_inc(sv);
7254 hv = (HV*)POPPTR(ss,ix);
7255 TOPPTR(nss,ix) = hv_dup_inc(hv);
7258 ptr = POPPTR(ss,ix);
7259 TOPPTR(nss,ix) = ptr;
7266 av = (AV*)POPPTR(ss,ix);
7267 TOPPTR(nss,ix) = av_dup(av);
7270 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7282 perl_clone(PerlInterpreter *proto_perl, UV flags)
7285 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7288 #ifdef PERL_IMPLICIT_SYS
7289 return perl_clone_using(proto_perl, flags,
7291 proto_perl->IMemShared,
7292 proto_perl->IMemParse,
7302 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7303 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7304 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7305 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7306 struct IPerlDir* ipD, struct IPerlSock* ipS,
7307 struct IPerlProc* ipP)
7309 /* XXX many of the string copies here can be optimized if they're
7310 * constants; they need to be allocated as common memory and just
7311 * their pointers copied. */
7317 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7319 PERL_SET_INTERP(pPerl);
7320 # else /* !PERL_OBJECT */
7321 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7322 PERL_SET_INTERP(my_perl);
7325 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7330 # else /* !DEBUGGING */
7331 Zero(my_perl, 1, PerlInterpreter);
7332 # endif /* DEBUGGING */
7336 PL_MemShared = ipMS;
7344 # endif /* PERL_OBJECT */
7345 #else /* !PERL_IMPLICIT_SYS */
7349 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7350 PERL_SET_INTERP(my_perl);
7353 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7358 # else /* !DEBUGGING */
7359 Zero(my_perl, 1, PerlInterpreter);
7360 # endif /* DEBUGGING */
7361 #endif /* PERL_IMPLICIT_SYS */
7364 PL_xiv_arenaroot = NULL;
7369 PL_xpviv_root = NULL;
7370 PL_xpvnv_root = NULL;
7371 PL_xpvcv_root = NULL;
7372 PL_xpvav_root = NULL;
7373 PL_xpvhv_root = NULL;
7374 PL_xpvmg_root = NULL;
7375 PL_xpvlv_root = NULL;
7376 PL_xpvbm_root = NULL;
7378 PL_nice_chunk = NULL;
7379 PL_nice_chunk_size = 0;
7382 PL_sv_root = Nullsv;
7383 PL_sv_arenaroot = Nullsv;
7385 PL_debug = proto_perl->Idebug;
7387 /* create SV map for pointer relocation */
7388 PL_ptr_table = ptr_table_new();
7390 /* initialize these special pointers as early as possible */
7391 SvANY(&PL_sv_undef) = NULL;
7392 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7393 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7394 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7397 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7399 SvANY(&PL_sv_no) = new_XPVNV();
7401 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7402 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7403 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7404 SvCUR(&PL_sv_no) = 0;
7405 SvLEN(&PL_sv_no) = 1;
7406 SvNVX(&PL_sv_no) = 0;
7407 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7410 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7412 SvANY(&PL_sv_yes) = new_XPVNV();
7414 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7415 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7416 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7417 SvCUR(&PL_sv_yes) = 1;
7418 SvLEN(&PL_sv_yes) = 2;
7419 SvNVX(&PL_sv_yes) = 1;
7420 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7422 /* create shared string table */
7423 PL_strtab = newHV();
7424 HvSHAREKEYS_off(PL_strtab);
7425 hv_ksplit(PL_strtab, 512);
7426 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7428 PL_compiling = proto_perl->Icompiling;
7429 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7430 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7431 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7432 if (!specialWARN(PL_compiling.cop_warnings))
7433 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7434 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7436 /* pseudo environmental stuff */
7437 PL_origargc = proto_perl->Iorigargc;
7439 New(0, PL_origargv, i+1, char*);
7440 PL_origargv[i] = '\0';
7442 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7444 PL_envgv = gv_dup(proto_perl->Ienvgv);
7445 PL_incgv = gv_dup(proto_perl->Iincgv);
7446 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7447 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7448 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7449 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7452 PL_minus_c = proto_perl->Iminus_c;
7453 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7454 PL_localpatches = proto_perl->Ilocalpatches;
7455 PL_splitstr = proto_perl->Isplitstr;
7456 PL_preprocess = proto_perl->Ipreprocess;
7457 PL_minus_n = proto_perl->Iminus_n;
7458 PL_minus_p = proto_perl->Iminus_p;
7459 PL_minus_l = proto_perl->Iminus_l;
7460 PL_minus_a = proto_perl->Iminus_a;
7461 PL_minus_F = proto_perl->Iminus_F;
7462 PL_doswitches = proto_perl->Idoswitches;
7463 PL_dowarn = proto_perl->Idowarn;
7464 PL_doextract = proto_perl->Idoextract;
7465 PL_sawampersand = proto_perl->Isawampersand;
7466 PL_unsafe = proto_perl->Iunsafe;
7467 PL_inplace = SAVEPV(proto_perl->Iinplace);
7468 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7469 PL_perldb = proto_perl->Iperldb;
7470 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7472 /* magical thingies */
7473 /* XXX time(&PL_basetime) when asked for? */
7474 PL_basetime = proto_perl->Ibasetime;
7475 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7477 PL_maxsysfd = proto_perl->Imaxsysfd;
7478 PL_multiline = proto_perl->Imultiline;
7479 PL_statusvalue = proto_perl->Istatusvalue;
7481 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7484 /* shortcuts to various I/O objects */
7485 PL_stdingv = gv_dup(proto_perl->Istdingv);
7486 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7487 PL_defgv = gv_dup(proto_perl->Idefgv);
7488 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7489 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7490 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7492 /* shortcuts to regexp stuff */
7493 PL_replgv = gv_dup(proto_perl->Ireplgv);
7495 /* shortcuts to misc objects */
7496 PL_errgv = gv_dup(proto_perl->Ierrgv);
7498 /* shortcuts to debugging objects */
7499 PL_DBgv = gv_dup(proto_perl->IDBgv);
7500 PL_DBline = gv_dup(proto_perl->IDBline);
7501 PL_DBsub = gv_dup(proto_perl->IDBsub);
7502 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7503 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7504 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7505 PL_lineary = av_dup(proto_perl->Ilineary);
7506 PL_dbargs = av_dup(proto_perl->Idbargs);
7509 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7510 PL_curstash = hv_dup(proto_perl->Tcurstash);
7511 PL_debstash = hv_dup(proto_perl->Idebstash);
7512 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7513 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7515 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7516 PL_endav = av_dup_inc(proto_perl->Iendav);
7517 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7518 PL_initav = av_dup_inc(proto_perl->Iinitav);
7520 PL_sub_generation = proto_perl->Isub_generation;
7522 /* funky return mechanisms */
7523 PL_forkprocess = proto_perl->Iforkprocess;
7525 /* subprocess state */
7526 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7528 /* internal state */
7529 PL_tainting = proto_perl->Itainting;
7530 PL_maxo = proto_perl->Imaxo;
7531 if (proto_perl->Iop_mask)
7532 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7534 PL_op_mask = Nullch;
7536 /* current interpreter roots */
7537 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7538 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7539 PL_main_start = proto_perl->Imain_start;
7540 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
7541 PL_eval_start = proto_perl->Ieval_start;
7543 /* runtime control stuff */
7544 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7545 PL_copline = proto_perl->Icopline;
7547 PL_filemode = proto_perl->Ifilemode;
7548 PL_lastfd = proto_perl->Ilastfd;
7549 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7552 PL_gensym = proto_perl->Igensym;
7553 PL_preambled = proto_perl->Ipreambled;
7554 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7555 PL_laststatval = proto_perl->Ilaststatval;
7556 PL_laststype = proto_perl->Ilaststype;
7557 PL_mess_sv = Nullsv;
7559 PL_orslen = proto_perl->Iorslen;
7560 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7561 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7563 /* interpreter atexit processing */
7564 PL_exitlistlen = proto_perl->Iexitlistlen;
7565 if (PL_exitlistlen) {
7566 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7567 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7570 PL_exitlist = (PerlExitListEntry*)NULL;
7571 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7573 PL_profiledata = NULL;
7574 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7575 /* PL_rsfp_filters entries have fake IoDIRP() */
7576 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7578 PL_compcv = cv_dup(proto_perl->Icompcv);
7579 PL_comppad = av_dup(proto_perl->Icomppad);
7580 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7581 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7582 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7583 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7584 proto_perl->Tcurpad);
7586 #ifdef HAVE_INTERP_INTERN
7587 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7590 /* more statics moved here */
7591 PL_generation = proto_perl->Igeneration;
7592 PL_DBcv = cv_dup(proto_perl->IDBcv);
7594 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7595 PL_in_clean_all = proto_perl->Iin_clean_all;
7597 PL_uid = proto_perl->Iuid;
7598 PL_euid = proto_perl->Ieuid;
7599 PL_gid = proto_perl->Igid;
7600 PL_egid = proto_perl->Iegid;
7601 PL_nomemok = proto_perl->Inomemok;
7602 PL_an = proto_perl->Ian;
7603 PL_cop_seqmax = proto_perl->Icop_seqmax;
7604 PL_op_seqmax = proto_perl->Iop_seqmax;
7605 PL_evalseq = proto_perl->Ievalseq;
7606 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7607 PL_origalen = proto_perl->Iorigalen;
7608 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7609 PL_osname = SAVEPV(proto_perl->Iosname);
7610 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7611 PL_sighandlerp = proto_perl->Isighandlerp;
7614 PL_runops = proto_perl->Irunops;
7616 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7619 PL_cshlen = proto_perl->Icshlen;
7620 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7623 PL_lex_state = proto_perl->Ilex_state;
7624 PL_lex_defer = proto_perl->Ilex_defer;
7625 PL_lex_expect = proto_perl->Ilex_expect;
7626 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7627 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7628 PL_lex_starts = proto_perl->Ilex_starts;
7629 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7630 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7631 PL_lex_op = proto_perl->Ilex_op;
7632 PL_lex_inpat = proto_perl->Ilex_inpat;
7633 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7634 PL_lex_brackets = proto_perl->Ilex_brackets;
7635 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7636 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7637 PL_lex_casemods = proto_perl->Ilex_casemods;
7638 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7639 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7641 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7642 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7643 PL_nexttoke = proto_perl->Inexttoke;
7645 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7646 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7647 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7648 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7649 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7650 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7651 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7652 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7653 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7654 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7655 PL_pending_ident = proto_perl->Ipending_ident;
7656 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7658 PL_expect = proto_perl->Iexpect;
7660 PL_multi_start = proto_perl->Imulti_start;
7661 PL_multi_end = proto_perl->Imulti_end;
7662 PL_multi_open = proto_perl->Imulti_open;
7663 PL_multi_close = proto_perl->Imulti_close;
7665 PL_error_count = proto_perl->Ierror_count;
7666 PL_subline = proto_perl->Isubline;
7667 PL_subname = sv_dup_inc(proto_perl->Isubname);
7669 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7670 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7671 PL_padix = proto_perl->Ipadix;
7672 PL_padix_floor = proto_perl->Ipadix_floor;
7673 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7675 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7676 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7677 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7678 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7679 PL_last_lop_op = proto_perl->Ilast_lop_op;
7680 PL_in_my = proto_perl->Iin_my;
7681 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7683 PL_cryptseen = proto_perl->Icryptseen;
7686 PL_hints = proto_perl->Ihints;
7688 PL_amagic_generation = proto_perl->Iamagic_generation;
7690 #ifdef USE_LOCALE_COLLATE
7691 PL_collation_ix = proto_perl->Icollation_ix;
7692 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7693 PL_collation_standard = proto_perl->Icollation_standard;
7694 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7695 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7696 #endif /* USE_LOCALE_COLLATE */
7698 #ifdef USE_LOCALE_NUMERIC
7699 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7700 PL_numeric_standard = proto_perl->Inumeric_standard;
7701 PL_numeric_local = proto_perl->Inumeric_local;
7702 PL_numeric_radix = proto_perl->Inumeric_radix;
7703 #endif /* !USE_LOCALE_NUMERIC */
7705 /* utf8 character classes */
7706 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7707 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7708 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7709 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7710 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7711 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7712 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7713 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7714 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7715 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7716 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7717 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7718 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7719 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7720 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7721 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7722 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7725 PL_last_swash_hv = Nullhv; /* reinits on demand */
7726 PL_last_swash_klen = 0;
7727 PL_last_swash_key[0]= '\0';
7728 PL_last_swash_tmps = (U8*)NULL;
7729 PL_last_swash_slen = 0;
7731 /* perly.c globals */
7732 PL_yydebug = proto_perl->Iyydebug;
7733 PL_yynerrs = proto_perl->Iyynerrs;
7734 PL_yyerrflag = proto_perl->Iyyerrflag;
7735 PL_yychar = proto_perl->Iyychar;
7736 PL_yyval = proto_perl->Iyyval;
7737 PL_yylval = proto_perl->Iyylval;
7739 PL_glob_index = proto_perl->Iglob_index;
7740 PL_srand_called = proto_perl->Isrand_called;
7741 PL_uudmap['M'] = 0; /* reinits on demand */
7742 PL_bitcount = Nullch; /* reinits on demand */
7744 if (proto_perl->Ipsig_ptr) {
7745 int sig_num[] = { SIG_NUM };
7746 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7747 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7748 for (i = 1; PL_sig_name[i]; i++) {
7749 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7750 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7754 PL_psig_ptr = (SV**)NULL;
7755 PL_psig_name = (SV**)NULL;
7758 /* thrdvar.h stuff */
7761 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7762 PL_tmps_ix = proto_perl->Ttmps_ix;
7763 PL_tmps_max = proto_perl->Ttmps_max;
7764 PL_tmps_floor = proto_perl->Ttmps_floor;
7765 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7767 while (i <= PL_tmps_ix) {
7768 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7772 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7773 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7774 Newz(54, PL_markstack, i, I32);
7775 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7776 - proto_perl->Tmarkstack);
7777 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7778 - proto_perl->Tmarkstack);
7779 Copy(proto_perl->Tmarkstack, PL_markstack,
7780 PL_markstack_ptr - PL_markstack + 1, I32);
7782 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7783 * NOTE: unlike the others! */
7784 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7785 PL_scopestack_max = proto_perl->Tscopestack_max;
7786 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7787 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7789 /* next push_return() sets PL_retstack[PL_retstack_ix]
7790 * NOTE: unlike the others! */
7791 PL_retstack_ix = proto_perl->Tretstack_ix;
7792 PL_retstack_max = proto_perl->Tretstack_max;
7793 Newz(54, PL_retstack, PL_retstack_max, OP*);
7794 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7796 /* NOTE: si_dup() looks at PL_markstack */
7797 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7799 /* PL_curstack = PL_curstackinfo->si_stack; */
7800 PL_curstack = av_dup(proto_perl->Tcurstack);
7801 PL_mainstack = av_dup(proto_perl->Tmainstack);
7803 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7804 PL_stack_base = AvARRAY(PL_curstack);
7805 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7806 - proto_perl->Tstack_base);
7807 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7809 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7810 * NOTE: unlike the others! */
7811 PL_savestack_ix = proto_perl->Tsavestack_ix;
7812 PL_savestack_max = proto_perl->Tsavestack_max;
7813 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7814 PL_savestack = ss_dup(proto_perl);
7820 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7821 PL_top_env = &PL_start_env;
7823 PL_op = proto_perl->Top;
7826 PL_Xpv = (XPV*)NULL;
7827 PL_na = proto_perl->Tna;
7829 PL_statbuf = proto_perl->Tstatbuf;
7830 PL_statcache = proto_perl->Tstatcache;
7831 PL_statgv = gv_dup(proto_perl->Tstatgv);
7832 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7834 PL_timesbuf = proto_perl->Ttimesbuf;
7837 PL_tainted = proto_perl->Ttainted;
7838 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7839 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7840 PL_rs = sv_dup_inc(proto_perl->Trs);
7841 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7842 PL_ofslen = proto_perl->Tofslen;
7843 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7844 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7845 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7846 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7847 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7848 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7850 PL_restartop = proto_perl->Trestartop;
7851 PL_in_eval = proto_perl->Tin_eval;
7852 PL_delaymagic = proto_perl->Tdelaymagic;
7853 PL_dirty = proto_perl->Tdirty;
7854 PL_localizing = proto_perl->Tlocalizing;
7856 PL_protect = proto_perl->Tprotect;
7857 PL_errors = sv_dup_inc(proto_perl->Terrors);
7858 PL_av_fetch_sv = Nullsv;
7859 PL_hv_fetch_sv = Nullsv;
7860 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7861 PL_modcount = proto_perl->Tmodcount;
7862 PL_lastgotoprobe = Nullop;
7863 PL_dumpindent = proto_perl->Tdumpindent;
7865 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7866 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7867 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7868 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7869 PL_sortcxix = proto_perl->Tsortcxix;
7870 PL_efloatbuf = Nullch; /* reinits on demand */
7871 PL_efloatsize = 0; /* reinits on demand */
7875 PL_screamfirst = NULL;
7876 PL_screamnext = NULL;
7877 PL_maxscream = -1; /* reinits on demand */
7878 PL_lastscream = Nullsv;
7880 PL_watchaddr = NULL;
7881 PL_watchok = Nullch;
7883 PL_regdummy = proto_perl->Tregdummy;
7884 PL_regcomp_parse = Nullch;
7885 PL_regxend = Nullch;
7886 PL_regcode = (regnode*)NULL;
7889 PL_regprecomp = Nullch;
7894 PL_seen_zerolen = 0;
7896 PL_regcomp_rx = (regexp*)NULL;
7898 PL_colorset = 0; /* reinits PL_colors[] */
7899 /*PL_colors[6] = {0,0,0,0,0,0};*/
7900 PL_reg_whilem_seen = 0;
7901 PL_reginput = Nullch;
7904 PL_regstartp = (I32*)NULL;
7905 PL_regendp = (I32*)NULL;
7906 PL_reglastparen = (U32*)NULL;
7907 PL_regtill = Nullch;
7909 PL_reg_start_tmp = (char**)NULL;
7910 PL_reg_start_tmpl = 0;
7911 PL_regdata = (struct reg_data*)NULL;
7914 PL_reg_eval_set = 0;
7916 PL_regprogram = (regnode*)NULL;
7918 PL_regcc = (CURCUR*)NULL;
7919 PL_reg_call_cc = (struct re_cc_state*)NULL;
7920 PL_reg_re = (regexp*)NULL;
7921 PL_reg_ganch = Nullch;
7923 PL_reg_magic = (MAGIC*)NULL;
7925 PL_reg_oldcurpm = (PMOP*)NULL;
7926 PL_reg_curpm = (PMOP*)NULL;
7927 PL_reg_oldsaved = Nullch;
7928 PL_reg_oldsavedlen = 0;
7930 PL_reg_leftiter = 0;
7931 PL_reg_poscache = Nullch;
7932 PL_reg_poscache_size= 0;
7934 /* RE engine - function pointers */
7935 PL_regcompp = proto_perl->Tregcompp;
7936 PL_regexecp = proto_perl->Tregexecp;
7937 PL_regint_start = proto_perl->Tregint_start;
7938 PL_regint_string = proto_perl->Tregint_string;
7939 PL_regfree = proto_perl->Tregfree;
7941 PL_reginterp_cnt = 0;
7942 PL_reg_starttry = 0;
7945 return (PerlInterpreter*)pPerl;
7951 #else /* !USE_ITHREADS */
7957 #endif /* USE_ITHREADS */
7960 do_report_used(pTHXo_ SV *sv)
7962 if (SvTYPE(sv) != SVTYPEMASK) {
7963 PerlIO_printf(Perl_debug_log, "****\n");
7969 do_clean_objs(pTHXo_ SV *sv)
7973 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7974 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7980 /* XXX Might want to check arrays, etc. */
7983 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7985 do_clean_named_objs(pTHXo_ SV *sv)
7987 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7988 if ( SvOBJECT(GvSV(sv)) ||
7989 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7990 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7991 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7992 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7994 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8002 do_clean_all(pTHXo_ SV *sv)
8004 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8005 SvFLAGS(sv) |= SVf_BREAK;