3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
207 Safefree((void *)sva);
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
219 Perl_report_uninit(pTHX)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
237 * See comment in more_xiv() -- RAM.
239 PL_xiv_root = *(IV**)xiv;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
245 S_del_xiv(pTHX_ XPVIV *p)
247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
249 *(IV**)xiv = PL_xiv_root;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
268 while (xiv < xivend) {
269 *(IV**)xiv = (IV *)(xiv + 1);
283 PL_xnv_root = *(NV**)xnv;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
289 S_del_xnv(pTHX_ XPVNV *p)
291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
293 *(NV**)xnv = PL_xnv_root;
303 New(711, xnv, 1008/sizeof(NV), NV);
304 xnvend = &xnv[1008 / sizeof(NV) - 1];
305 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
307 while (xnv < xnvend) {
308 *(NV**)xnv = (NV*)(xnv + 1);
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
328 S_del_xrv(pTHX_ XRV *p)
331 p->xrv_rv = (SV*)PL_xrv_root;
340 register XRV* xrvend;
341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
365 S_del_xpv(pTHX_ XPV *p)
368 p->xpv_pv = (char*)PL_xpv_root;
377 register XPV* xpvend;
378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
402 S_del_xpviv(pTHX_ XPVIV *p)
405 p->xpv_pv = (char*)PL_xpviv_root;
414 register XPVIV* xpviv;
415 register XPVIV* xpvivend;
416 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417 xpviv = PL_xpviv_root;
418 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419 while (xpviv < xpvivend) {
420 xpviv->xpv_pv = (char*)(xpviv + 1);
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
441 S_del_xpvnv(pTHX_ XPVNV *p)
444 p->xpv_pv = (char*)PL_xpvnv_root;
453 register XPVNV* xpvnv;
454 register XPVNV* xpvnvend;
455 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456 xpvnv = PL_xpvnv_root;
457 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458 while (xpvnv < xpvnvend) {
459 xpvnv->xpv_pv = (char*)(xpvnv + 1);
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
481 S_del_xpvcv(pTHX_ XPVCV *p)
484 p->xpv_pv = (char*)PL_xpvcv_root;
493 register XPVCV* xpvcv;
494 register XPVCV* xpvcvend;
495 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496 xpvcv = PL_xpvcv_root;
497 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498 while (xpvcv < xpvcvend) {
499 xpvcv->xpv_pv = (char*)(xpvcv + 1);
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
521 S_del_xpvav(pTHX_ XPVAV *p)
524 p->xav_array = (char*)PL_xpvav_root;
533 register XPVAV* xpvav;
534 register XPVAV* xpvavend;
535 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536 xpvav = PL_xpvav_root;
537 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538 while (xpvav < xpvavend) {
539 xpvav->xav_array = (char*)(xpvav + 1);
542 xpvav->xav_array = 0;
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
561 S_del_xpvhv(pTHX_ XPVHV *p)
564 p->xhv_array = (char*)PL_xpvhv_root;
573 register XPVHV* xpvhv;
574 register XPVHV* xpvhvend;
575 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576 xpvhv = PL_xpvhv_root;
577 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578 while (xpvhv < xpvhvend) {
579 xpvhv->xhv_array = (char*)(xpvhv + 1);
582 xpvhv->xhv_array = 0;
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
600 S_del_xpvmg(pTHX_ XPVMG *p)
603 p->xpv_pv = (char*)PL_xpvmg_root;
612 register XPVMG* xpvmg;
613 register XPVMG* xpvmgend;
614 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615 xpvmg = PL_xpvmg_root;
616 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617 while (xpvmg < xpvmgend) {
618 xpvmg->xpv_pv = (char*)(xpvmg + 1);
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
640 S_del_xpvlv(pTHX_ XPVLV *p)
643 p->xpv_pv = (char*)PL_xpvlv_root;
652 register XPVLV* xpvlv;
653 register XPVLV* xpvlvend;
654 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655 xpvlv = PL_xpvlv_root;
656 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657 while (xpvlv < xpvlvend) {
658 xpvlv->xpv_pv = (char*)(xpvlv + 1);
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
679 S_del_xpvbm(pTHX_ XPVBM *p)
682 p->xpv_pv = (char*)PL_xpvbm_root;
691 register XPVBM* xpvbm;
692 register XPVBM* xpvbmend;
693 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694 xpvbm = PL_xpvbm_root;
695 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696 while (xpvbm < xpvbmend) {
697 xpvbm->xpv_pv = (char*)(xpvbm + 1);
704 # define my_safemalloc(s) (void*)safexmalloc(717,s)
705 # define my_safefree(p) safexfree((char*)p)
707 # define my_safemalloc(s) (void*)safemalloc(s)
708 # define my_safefree(p) safefree((char*)p)
713 #define new_XIV() my_safemalloc(sizeof(XPVIV))
714 #define del_XIV(p) my_safefree(p)
716 #define new_XNV() my_safemalloc(sizeof(XPVNV))
717 #define del_XNV(p) my_safefree(p)
719 #define new_XRV() my_safemalloc(sizeof(XRV))
720 #define del_XRV(p) my_safefree(p)
722 #define new_XPV() my_safemalloc(sizeof(XPV))
723 #define del_XPV(p) my_safefree(p)
725 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726 #define del_XPVIV(p) my_safefree(p)
728 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729 #define del_XPVNV(p) my_safefree(p)
731 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732 #define del_XPVCV(p) my_safefree(p)
734 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735 #define del_XPVAV(p) my_safefree(p)
737 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738 #define del_XPVHV(p) my_safefree(p)
740 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741 #define del_XPVMG(p) my_safefree(p)
743 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744 #define del_XPVLV(p) my_safefree(p)
746 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747 #define del_XPVBM(p) my_safefree(p)
751 #define new_XIV() (void*)new_xiv()
752 #define del_XIV(p) del_xiv((XPVIV*) p)
754 #define new_XNV() (void*)new_xnv()
755 #define del_XNV(p) del_xnv((XPVNV*) p)
757 #define new_XRV() (void*)new_xrv()
758 #define del_XRV(p) del_xrv((XRV*) p)
760 #define new_XPV() (void*)new_xpv()
761 #define del_XPV(p) del_xpv((XPV *)p)
763 #define new_XPVIV() (void*)new_xpviv()
764 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
766 #define new_XPVNV() (void*)new_xpvnv()
767 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
769 #define new_XPVCV() (void*)new_xpvcv()
770 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
772 #define new_XPVAV() (void*)new_xpvav()
773 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
775 #define new_XPVHV() (void*)new_xpvhv()
776 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
778 #define new_XPVMG() (void*)new_xpvmg()
779 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
781 #define new_XPVLV() (void*)new_xpvlv()
782 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
784 #define new_XPVBM() (void*)new_xpvbm()
785 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
789 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790 #define del_XPVGV(p) my_safefree(p)
792 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793 #define del_XPVFM(p) my_safefree(p)
795 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796 #define del_XPVIO(p) my_safefree(p)
799 =for apidoc sv_upgrade
801 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
808 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
818 if (SvTYPE(sv) == mt)
824 switch (SvTYPE(sv)) {
845 else if (mt < SVt_PVIV)
862 pv = (char*)SvRV(sv);
882 else if (mt == SVt_NV)
893 del_XPVIV(SvANY(sv));
903 del_XPVNV(SvANY(sv));
913 del_XPVMG(SvANY(sv));
916 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
921 Perl_croak(aTHX_ "Can't upgrade to undef");
923 SvANY(sv) = new_XIV();
927 SvANY(sv) = new_XNV();
931 SvANY(sv) = new_XRV();
935 SvANY(sv) = new_XPV();
941 SvANY(sv) = new_XPVIV();
951 SvANY(sv) = new_XPVNV();
959 SvANY(sv) = new_XPVMG();
969 SvANY(sv) = new_XPVLV();
983 SvANY(sv) = new_XPVAV();
998 SvANY(sv) = new_XPVHV();
1006 SvMAGIC(sv) = magic;
1007 SvSTASH(sv) = stash;
1014 SvANY(sv) = new_XPVCV();
1015 Zero(SvANY(sv), 1, XPVCV);
1021 SvMAGIC(sv) = magic;
1022 SvSTASH(sv) = stash;
1025 SvANY(sv) = new_XPVGV();
1031 SvMAGIC(sv) = magic;
1032 SvSTASH(sv) = stash;
1040 SvANY(sv) = new_XPVBM();
1046 SvMAGIC(sv) = magic;
1047 SvSTASH(sv) = stash;
1053 SvANY(sv) = new_XPVFM();
1054 Zero(SvANY(sv), 1, XPVFM);
1060 SvMAGIC(sv) = magic;
1061 SvSTASH(sv) = stash;
1064 SvANY(sv) = new_XPVIO();
1065 Zero(SvANY(sv), 1, XPVIO);
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
1073 IoPAGE_LEN(sv) = 60;
1076 SvFLAGS(sv) &= ~SVTYPEMASK;
1082 Perl_sv_backoff(pTHX_ register SV *sv)
1086 char *s = SvPVX(sv);
1087 SvLEN(sv) += SvIVX(sv);
1088 SvPVX(sv) -= SvIVX(sv);
1090 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1092 SvFLAGS(sv) &= ~SVf_OOK;
1099 Expands the character buffer in the SV. This will use C<sv_unref> and will
1100 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1107 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1111 #ifdef HAS_64K_LIMIT
1112 if (newlen >= 0x10000) {
1113 PerlIO_printf(Perl_debug_log,
1114 "Allocation too large: %"UVxf"\n", (UV)newlen);
1117 #endif /* HAS_64K_LIMIT */
1120 if (SvTYPE(sv) < SVt_PV) {
1121 sv_upgrade(sv, SVt_PV);
1124 else if (SvOOK(sv)) { /* pv is offset? */
1127 if (newlen > SvLEN(sv))
1128 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129 #ifdef HAS_64K_LIMIT
1130 if (newlen >= 0x10000)
1136 if (newlen > SvLEN(sv)) { /* need more room? */
1137 if (SvLEN(sv) && s) {
1138 #if defined(MYMALLOC) && !defined(LEAKTEST)
1139 STRLEN l = malloced_size((void*)SvPVX(sv));
1145 Renew(s,newlen,char);
1148 New(703,s,newlen,char);
1150 SvLEN_set(sv, newlen);
1156 =for apidoc sv_setiv
1158 Copies an integer into the given SV. Does not handle 'set' magic. See
1165 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1167 SV_CHECK_THINKFIRST(sv);
1168 switch (SvTYPE(sv)) {
1170 sv_upgrade(sv, SVt_IV);
1173 sv_upgrade(sv, SVt_PVNV);
1177 sv_upgrade(sv, SVt_PVIV);
1188 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189 PL_op_desc[PL_op->op_type]);
1192 (void)SvIOK_only(sv); /* validate number */
1198 =for apidoc sv_setiv_mg
1200 Like C<sv_setiv>, but also handles 'set' magic.
1206 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1213 =for apidoc sv_setuv
1215 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1222 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1230 =for apidoc sv_setuv_mg
1232 Like C<sv_setuv>, but also handles 'set' magic.
1238 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1245 =for apidoc sv_setnv
1247 Copies a double into the given SV. Does not handle 'set' magic. See
1254 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1256 SV_CHECK_THINKFIRST(sv);
1257 switch (SvTYPE(sv)) {
1260 sv_upgrade(sv, SVt_NV);
1265 sv_upgrade(sv, SVt_PVNV);
1276 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277 PL_op_name[PL_op->op_type]);
1281 (void)SvNOK_only(sv); /* validate number */
1286 =for apidoc sv_setnv_mg
1288 Like C<sv_setnv>, but also handles 'set' magic.
1294 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1301 S_not_a_number(pTHX_ SV *sv)
1307 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308 /* each *s can expand to 4 chars + "...\0",
1309 i.e. need room for 8 chars */
1311 for (s = SvPVX(sv); *s && d < limit; s++) {
1313 if (ch & 128 && !isPRINT_LC(ch)) {
1322 else if (ch == '\r') {
1326 else if (ch == '\f') {
1330 else if (ch == '\\') {
1334 else if (isPRINT_LC(ch))
1349 Perl_warner(aTHX_ WARN_NUMERIC,
1350 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351 PL_op_desc[PL_op->op_type]);
1353 Perl_warner(aTHX_ WARN_NUMERIC,
1354 "Argument \"%s\" isn't numeric", tmpbuf);
1357 /* the number can be converted to integer with atol() or atoll() */
1358 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1363 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1364 until proven guilty, assume that things are not that bad... */
1367 Perl_sv_2iv(pTHX_ register SV *sv)
1371 if (SvGMAGICAL(sv)) {
1376 return I_V(SvNVX(sv));
1378 if (SvPOKp(sv) && SvLEN(sv))
1381 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1383 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1389 if (SvTHINKFIRST(sv)) {
1392 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1393 return SvIV(tmpstr);
1394 return PTR2IV(SvRV(sv));
1396 if (SvREADONLY(sv) && !SvOK(sv)) {
1398 if (ckWARN(WARN_UNINITIALIZED))
1405 return (IV)(SvUVX(sv));
1412 /* We can cache the IV/UV value even if it not good enough
1413 * to reconstruct NV, since the conversion to PV will prefer
1417 if (SvTYPE(sv) == SVt_NV)
1418 sv_upgrade(sv, SVt_PVNV);
1421 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1422 SvIVX(sv) = I_V(SvNVX(sv));
1424 SvUVX(sv) = U_V(SvNVX(sv));
1427 DEBUG_c(PerlIO_printf(Perl_debug_log,
1428 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1432 return (IV)SvUVX(sv);
1435 else if (SvPOKp(sv) && SvLEN(sv)) {
1436 I32 numtype = looks_like_number(sv);
1438 /* We want to avoid a possible problem when we cache an IV which
1439 may be later translated to an NV, and the resulting NV is not
1440 the translation of the initial data.
1442 This means that if we cache such an IV, we need to cache the
1443 NV as well. Moreover, we trade speed for space, and do not
1444 cache the NV if not needed.
1446 if (numtype & IS_NUMBER_NOT_IV) {
1447 /* May be not an integer. Need to cache NV if we cache IV
1448 * - otherwise future conversion to NV will be wrong. */
1451 d = Atof(SvPVX(sv));
1453 if (SvTYPE(sv) < SVt_PVNV)
1454 sv_upgrade(sv, SVt_PVNV);
1458 #if defined(USE_LONG_DOUBLE)
1459 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1460 PTR2UV(sv), SvNVX(sv)));
1462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1463 PTR2UV(sv), SvNVX(sv)));
1465 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1466 SvIVX(sv) = I_V(SvNVX(sv));
1468 SvUVX(sv) = U_V(SvNVX(sv));
1474 /* The NV may be reconstructed from IV - safe to cache IV,
1475 which may be calculated by atol(). */
1476 if (SvTYPE(sv) == SVt_PV)
1477 sv_upgrade(sv, SVt_PVIV);
1479 SvIVX(sv) = Atol(SvPVX(sv));
1481 else { /* Not a number. Cache 0. */
1484 if (SvTYPE(sv) < SVt_PVIV)
1485 sv_upgrade(sv, SVt_PVIV);
1488 if (ckWARN(WARN_NUMERIC))
1494 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1496 if (SvTYPE(sv) < SVt_IV)
1497 /* Typically the caller expects that sv_any is not NULL now. */
1498 sv_upgrade(sv, SVt_IV);
1501 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1502 PTR2UV(sv),SvIVX(sv)));
1503 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1507 Perl_sv_2uv(pTHX_ register SV *sv)
1511 if (SvGMAGICAL(sv)) {
1516 return U_V(SvNVX(sv));
1517 if (SvPOKp(sv) && SvLEN(sv))
1520 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1522 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1528 if (SvTHINKFIRST(sv)) {
1531 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1532 return SvUV(tmpstr);
1533 return PTR2UV(SvRV(sv));
1535 if (SvREADONLY(sv) && !SvOK(sv)) {
1537 if (ckWARN(WARN_UNINITIALIZED))
1547 return (UV)SvIVX(sv);
1551 /* We can cache the IV/UV value even if it not good enough
1552 * to reconstruct NV, since the conversion to PV will prefer
1555 if (SvTYPE(sv) == SVt_NV)
1556 sv_upgrade(sv, SVt_PVNV);
1558 if (SvNVX(sv) >= -0.5) {
1560 SvUVX(sv) = U_V(SvNVX(sv));
1563 SvIVX(sv) = I_V(SvNVX(sv));
1565 DEBUG_c(PerlIO_printf(Perl_debug_log,
1566 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1569 (IV)(UV)SvIVX(sv)));
1570 return (UV)SvIVX(sv);
1573 else if (SvPOKp(sv) && SvLEN(sv)) {
1574 I32 numtype = looks_like_number(sv);
1576 /* We want to avoid a possible problem when we cache a UV which
1577 may be later translated to an NV, and the resulting NV is not
1578 the translation of the initial data.
1580 This means that if we cache such a UV, we need to cache the
1581 NV as well. Moreover, we trade speed for space, and do not
1582 cache the NV if not needed.
1584 if (numtype & IS_NUMBER_NOT_IV) {
1585 /* May be not an integer. Need to cache NV if we cache IV
1586 * - otherwise future conversion to NV will be wrong. */
1589 d = Atof(SvPVX(sv));
1591 if (SvTYPE(sv) < SVt_PVNV)
1592 sv_upgrade(sv, SVt_PVNV);
1596 #if defined(USE_LONG_DOUBLE)
1597 DEBUG_c(PerlIO_printf(Perl_debug_log,
1598 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1599 PTR2UV(sv), SvNVX(sv)));
1601 DEBUG_c(PerlIO_printf(Perl_debug_log,
1602 "0x%"UVxf" 2nv(%g)\n",
1603 PTR2UV(sv), SvNVX(sv)));
1605 if (SvNVX(sv) < -0.5) {
1606 SvIVX(sv) = I_V(SvNVX(sv));
1609 SvUVX(sv) = U_V(SvNVX(sv));
1613 else if (numtype & IS_NUMBER_NEG) {
1614 /* The NV may be reconstructed from IV - safe to cache IV,
1615 which may be calculated by atol(). */
1616 if (SvTYPE(sv) == SVt_PV)
1617 sv_upgrade(sv, SVt_PVIV);
1619 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1621 else if (numtype) { /* Non-negative */
1622 /* The NV may be reconstructed from UV - safe to cache UV,
1623 which may be calculated by strtoul()/atol. */
1624 if (SvTYPE(sv) == SVt_PV)
1625 sv_upgrade(sv, SVt_PVIV);
1627 (void)SvIsUV_on(sv);
1629 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1630 #else /* no atou(), but we know the number fits into IV... */
1631 /* The only problem may be if it is negative... */
1632 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1635 else { /* Not a number. Cache 0. */
1638 if (SvTYPE(sv) < SVt_PVIV)
1639 sv_upgrade(sv, SVt_PVIV);
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((U8*)c, &len);
2335 /* XXX might want to make a callback here instead */
2336 Perl_croak(aTHX_ "Big byte");
2349 char *src = first_hi;
2350 char *dst = first_hi;
2351 while (src < SvEND(sv)) {
2354 U8 u = (U8)utf8_to_uv((U8*)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 ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2666 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2667 "Constant subroutine %s redefined"
2668 : "Subroutine %s redefined",
2669 GvENAME((GV*)dstr));
2671 cv_ckproto(cv, (GV*)dstr,
2672 SvPOK(sref) ? SvPVX(sref) : Nullch);
2674 GvCV(dstr) = (CV*)sref;
2675 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2676 GvASSUMECV_on(dstr);
2677 PL_sub_generation++;
2679 if (GvIMPORTED_CV_off(dstr)
2680 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2682 GvIMPORTED_CV_on(dstr);
2687 SAVESPTR(GvIOp(dstr));
2689 dref = (SV*)GvIOp(dstr);
2690 GvIOp(dstr) = (IO*)sref;
2694 SAVESPTR(GvSV(dstr));
2696 dref = (SV*)GvSV(dstr);
2698 if (GvIMPORTED_SV_off(dstr)
2699 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2701 GvIMPORTED_SV_on(dstr);
2713 (void)SvOOK_off(dstr); /* backoff */
2715 Safefree(SvPVX(dstr));
2716 SvLEN(dstr)=SvCUR(dstr)=0;
2719 (void)SvOK_off(dstr);
2720 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2722 if (sflags & SVp_NOK) {
2724 SvNVX(dstr) = SvNVX(sstr);
2726 if (sflags & SVp_IOK) {
2727 (void)SvIOK_on(dstr);
2728 SvIVX(dstr) = SvIVX(sstr);
2732 if (SvAMAGIC(sstr)) {
2736 else if (sflags & SVp_POK) {
2739 * Check to see if we can just swipe the string. If so, it's a
2740 * possible small lose on short strings, but a big win on long ones.
2741 * It might even be a win on short strings if SvPVX(dstr)
2742 * has to be allocated and SvPVX(sstr) has to be freed.
2745 if (SvTEMP(sstr) && /* slated for free anyway? */
2746 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2747 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2749 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2751 SvFLAGS(dstr) &= ~SVf_OOK;
2752 Safefree(SvPVX(dstr) - SvIVX(dstr));
2754 else if (SvLEN(dstr))
2755 Safefree(SvPVX(dstr));
2757 (void)SvPOK_only(dstr);
2758 SvPV_set(dstr, SvPVX(sstr));
2759 SvLEN_set(dstr, SvLEN(sstr));
2760 SvCUR_set(dstr, SvCUR(sstr));
2762 (void)SvOK_off(sstr);
2763 SvPV_set(sstr, Nullch);
2768 else { /* have to copy actual string */
2769 STRLEN len = SvCUR(sstr);
2771 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2772 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2773 SvCUR_set(dstr, len);
2774 *SvEND(dstr) = '\0';
2775 (void)SvPOK_only(dstr);
2780 if (sflags & SVp_NOK) {
2782 SvNVX(dstr) = SvNVX(sstr);
2784 if (sflags & SVp_IOK) {
2785 (void)SvIOK_on(dstr);
2786 SvIVX(dstr) = SvIVX(sstr);
2791 else if (sflags & SVp_NOK) {
2792 SvNVX(dstr) = SvNVX(sstr);
2793 (void)SvNOK_only(dstr);
2795 (void)SvIOK_on(dstr);
2796 SvIVX(dstr) = SvIVX(sstr);
2797 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2802 else if (sflags & SVp_IOK) {
2803 (void)SvIOK_only(dstr);
2804 SvIVX(dstr) = SvIVX(sstr);
2809 if (dtype == SVt_PVGV) {
2810 if (ckWARN(WARN_MISC))
2811 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2814 (void)SvOK_off(dstr);
2820 =for apidoc sv_setsv_mg
2822 Like C<sv_setsv>, but also handles 'set' magic.
2828 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2830 sv_setsv(dstr,sstr);
2835 =for apidoc sv_setpvn
2837 Copies a string into an SV. The C<len> parameter indicates the number of
2838 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2844 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2846 register char *dptr;
2847 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2848 elicit a warning, but it won't hurt. */
2849 SV_CHECK_THINKFIRST(sv);
2854 (void)SvUPGRADE(sv, SVt_PV);
2856 SvGROW(sv, len + 1);
2858 Move(ptr,dptr,len,char);
2861 (void)SvPOK_only(sv); /* validate pointer */
2866 =for apidoc sv_setpvn_mg
2868 Like C<sv_setpvn>, but also handles 'set' magic.
2874 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2876 sv_setpvn(sv,ptr,len);
2881 =for apidoc sv_setpv
2883 Copies a string into an SV. The string must be null-terminated. Does not
2884 handle 'set' magic. See C<sv_setpv_mg>.
2890 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2892 register STRLEN len;
2894 SV_CHECK_THINKFIRST(sv);
2900 (void)SvUPGRADE(sv, SVt_PV);
2902 SvGROW(sv, len + 1);
2903 Move(ptr,SvPVX(sv),len+1,char);
2905 (void)SvPOK_only(sv); /* validate pointer */
2910 =for apidoc sv_setpv_mg
2912 Like C<sv_setpv>, but also handles 'set' magic.
2918 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2925 =for apidoc sv_usepvn
2927 Tells an SV to use C<ptr> to find its string value. Normally the string is
2928 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2929 The C<ptr> should point to memory that was allocated by C<malloc>. The
2930 string length, C<len>, must be supplied. This function will realloc the
2931 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2932 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2933 See C<sv_usepvn_mg>.
2939 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2941 SV_CHECK_THINKFIRST(sv);
2942 (void)SvUPGRADE(sv, SVt_PV);
2947 (void)SvOOK_off(sv);
2948 if (SvPVX(sv) && SvLEN(sv))
2949 Safefree(SvPVX(sv));
2950 Renew(ptr, len+1, char);
2953 SvLEN_set(sv, len+1);
2955 (void)SvPOK_only(sv); /* validate pointer */
2960 =for apidoc sv_usepvn_mg
2962 Like C<sv_usepvn>, but also handles 'set' magic.
2968 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2970 sv_usepvn(sv,ptr,len);
2975 Perl_sv_force_normal(pTHX_ register SV *sv)
2977 if (SvREADONLY(sv)) {
2979 if (PL_curcop != &PL_compiling)
2980 Perl_croak(aTHX_ PL_no_modify);
2984 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2991 Efficient removal of characters from the beginning of the string buffer.
2992 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2993 the string buffer. The C<ptr> becomes the first character of the adjusted
3000 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3004 register STRLEN delta;
3006 if (!ptr || !SvPOKp(sv))
3008 SV_CHECK_THINKFIRST(sv);
3009 if (SvTYPE(sv) < SVt_PVIV)
3010 sv_upgrade(sv,SVt_PVIV);
3013 if (!SvLEN(sv)) { /* make copy of shared string */
3014 char *pvx = SvPVX(sv);
3015 STRLEN len = SvCUR(sv);
3016 SvGROW(sv, len + 1);
3017 Move(pvx,SvPVX(sv),len,char);
3021 SvFLAGS(sv) |= SVf_OOK;
3023 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3024 delta = ptr - SvPVX(sv);
3032 =for apidoc sv_catpvn
3034 Concatenates the string onto the end of the string which is in the SV. The
3035 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3036 'set' magic. See C<sv_catpvn_mg>.
3042 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3047 junk = SvPV_force(sv, tlen);
3048 SvGROW(sv, tlen + len + 1);
3051 Move(ptr,SvPVX(sv)+tlen,len,char);
3054 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3059 =for apidoc sv_catpvn_mg
3061 Like C<sv_catpvn>, but also handles 'set' magic.
3067 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3069 sv_catpvn(sv,ptr,len);
3074 =for apidoc sv_catsv
3076 Concatenates the string from SV C<ssv> onto the end of the string in SV
3077 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3083 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3089 if (s = SvPV(sstr, len)) {
3091 sv_utf8_upgrade(dstr);
3092 sv_catpvn(dstr,s,len);
3099 =for apidoc sv_catsv_mg
3101 Like C<sv_catsv>, but also handles 'set' magic.
3107 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3109 sv_catsv(dstr,sstr);
3114 =for apidoc sv_catpv
3116 Concatenates the string onto the end of the string which is in the SV.
3117 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3123 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3125 register STRLEN len;
3131 junk = SvPV_force(sv, tlen);
3133 SvGROW(sv, tlen + len + 1);
3136 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3138 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3143 =for apidoc sv_catpv_mg
3145 Like C<sv_catpv>, but also handles 'set' magic.
3151 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3158 Perl_newSV(pTHX_ STRLEN len)
3164 sv_upgrade(sv, SVt_PV);
3165 SvGROW(sv, len + 1);
3170 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3173 =for apidoc sv_magic
3175 Adds magic to an SV.
3181 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3185 if (SvREADONLY(sv)) {
3187 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3188 Perl_croak(aTHX_ PL_no_modify);
3190 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3191 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3198 (void)SvUPGRADE(sv, SVt_PVMG);
3200 Newz(702,mg, 1, MAGIC);
3201 mg->mg_moremagic = SvMAGIC(sv);
3204 if (!obj || obj == sv || how == '#' || how == 'r')
3208 mg->mg_obj = SvREFCNT_inc(obj);
3209 mg->mg_flags |= MGf_REFCOUNTED;
3212 mg->mg_len = namlen;
3215 mg->mg_ptr = savepvn(name, namlen);
3216 else if (namlen == HEf_SVKEY)
3217 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3221 mg->mg_virtual = &PL_vtbl_sv;
3224 mg->mg_virtual = &PL_vtbl_amagic;
3227 mg->mg_virtual = &PL_vtbl_amagicelem;
3233 mg->mg_virtual = &PL_vtbl_bm;
3236 mg->mg_virtual = &PL_vtbl_regdata;
3239 mg->mg_virtual = &PL_vtbl_regdatum;
3242 mg->mg_virtual = &PL_vtbl_env;
3245 mg->mg_virtual = &PL_vtbl_fm;
3248 mg->mg_virtual = &PL_vtbl_envelem;
3251 mg->mg_virtual = &PL_vtbl_mglob;
3254 mg->mg_virtual = &PL_vtbl_isa;
3257 mg->mg_virtual = &PL_vtbl_isaelem;
3260 mg->mg_virtual = &PL_vtbl_nkeys;
3267 mg->mg_virtual = &PL_vtbl_dbline;
3271 mg->mg_virtual = &PL_vtbl_mutex;
3273 #endif /* USE_THREADS */
3274 #ifdef USE_LOCALE_COLLATE
3276 mg->mg_virtual = &PL_vtbl_collxfrm;
3278 #endif /* USE_LOCALE_COLLATE */
3280 mg->mg_virtual = &PL_vtbl_pack;
3284 mg->mg_virtual = &PL_vtbl_packelem;
3287 mg->mg_virtual = &PL_vtbl_regexp;
3290 mg->mg_virtual = &PL_vtbl_sig;
3293 mg->mg_virtual = &PL_vtbl_sigelem;
3296 mg->mg_virtual = &PL_vtbl_taint;
3300 mg->mg_virtual = &PL_vtbl_uvar;
3303 mg->mg_virtual = &PL_vtbl_vec;
3306 mg->mg_virtual = &PL_vtbl_substr;
3309 mg->mg_virtual = &PL_vtbl_defelem;
3312 mg->mg_virtual = &PL_vtbl_glob;
3315 mg->mg_virtual = &PL_vtbl_arylen;
3318 mg->mg_virtual = &PL_vtbl_pos;
3321 mg->mg_virtual = &PL_vtbl_backref;
3323 case '~': /* Reserved for use by extensions not perl internals. */
3324 /* Useful for attaching extension internal data to perl vars. */
3325 /* Note that multiple extensions may clash if magical scalars */
3326 /* etc holding private data from one are passed to another. */
3330 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3334 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3338 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3342 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3345 for (mg = *mgp; mg; mg = *mgp) {
3346 if (mg->mg_type == type) {
3347 MGVTBL* vtbl = mg->mg_virtual;
3348 *mgp = mg->mg_moremagic;
3349 if (vtbl && vtbl->svt_free)
3350 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3351 if (mg->mg_ptr && mg->mg_type != 'g')
3352 if (mg->mg_len >= 0)
3353 Safefree(mg->mg_ptr);
3354 else if (mg->mg_len == HEf_SVKEY)
3355 SvREFCNT_dec((SV*)mg->mg_ptr);
3356 if (mg->mg_flags & MGf_REFCOUNTED)
3357 SvREFCNT_dec(mg->mg_obj);
3361 mgp = &mg->mg_moremagic;
3365 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3372 Perl_sv_rvweaken(pTHX_ SV *sv)
3375 if (!SvOK(sv)) /* let undefs pass */
3378 Perl_croak(aTHX_ "Can't weaken a nonreference");
3379 else if (SvWEAKREF(sv)) {
3381 if (ckWARN(WARN_MISC))
3382 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3386 sv_add_backref(tsv, sv);
3393 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3397 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3398 av = (AV*)mg->mg_obj;
3401 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3402 SvREFCNT_dec(av); /* for sv_magic */
3408 S_sv_del_backref(pTHX_ SV *sv)
3415 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3416 Perl_croak(aTHX_ "panic: del_backref");
3417 av = (AV *)mg->mg_obj;
3422 svp[i] = &PL_sv_undef; /* XXX */
3429 =for apidoc sv_insert
3431 Inserts a string at the specified offset/length within the SV. Similar to
3432 the Perl substr() function.
3438 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3442 register char *midend;
3443 register char *bigend;
3449 Perl_croak(aTHX_ "Can't modify non-existent substring");
3450 SvPV_force(bigstr, curlen);
3451 if (offset + len > curlen) {
3452 SvGROW(bigstr, offset+len+1);
3453 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3454 SvCUR_set(bigstr, offset+len);
3458 i = littlelen - len;
3459 if (i > 0) { /* string might grow */
3460 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3461 mid = big + offset + len;
3462 midend = bigend = big + SvCUR(bigstr);
3465 while (midend > mid) /* shove everything down */
3466 *--bigend = *--midend;
3467 Move(little,big+offset,littlelen,char);
3473 Move(little,SvPVX(bigstr)+offset,len,char);
3478 big = SvPVX(bigstr);
3481 bigend = big + SvCUR(bigstr);
3483 if (midend > bigend)
3484 Perl_croak(aTHX_ "panic: sv_insert");
3486 if (mid - big > bigend - midend) { /* faster to shorten from end */
3488 Move(little, mid, littlelen,char);
3491 i = bigend - midend;
3493 Move(midend, mid, i,char);
3497 SvCUR_set(bigstr, mid - big);
3500 else if (i = mid - big) { /* faster from front */
3501 midend -= littlelen;
3503 sv_chop(bigstr,midend-i);
3508 Move(little, mid, littlelen,char);
3510 else if (littlelen) {
3511 midend -= littlelen;
3512 sv_chop(bigstr,midend);
3513 Move(little,midend,littlelen,char);
3516 sv_chop(bigstr,midend);
3521 /* make sv point to what nstr did */
3524 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3527 U32 refcnt = SvREFCNT(sv);
3528 SV_CHECK_THINKFIRST(sv);
3529 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3530 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3531 if (SvMAGICAL(sv)) {
3535 sv_upgrade(nsv, SVt_PVMG);
3536 SvMAGIC(nsv) = SvMAGIC(sv);
3537 SvFLAGS(nsv) |= SvMAGICAL(sv);
3543 assert(!SvREFCNT(sv));
3544 StructCopy(nsv,sv,SV);
3545 SvREFCNT(sv) = refcnt;
3546 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3551 Perl_sv_clear(pTHX_ register SV *sv)
3555 assert(SvREFCNT(sv) == 0);
3559 if (PL_defstash) { /* Still have a symbol table? */
3564 Zero(&tmpref, 1, SV);
3565 sv_upgrade(&tmpref, SVt_RV);
3567 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3568 SvREFCNT(&tmpref) = 1;
3571 stash = SvSTASH(sv);
3572 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3575 PUSHSTACKi(PERLSI_DESTROY);
3576 SvRV(&tmpref) = SvREFCNT_inc(sv);
3581 call_sv((SV*)GvCV(destructor),
3582 G_DISCARD|G_EVAL|G_KEEPERR);
3588 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3590 del_XRV(SvANY(&tmpref));
3593 if (PL_in_clean_objs)
3594 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3596 /* DESTROY gave object new lease on life */
3602 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3603 SvOBJECT_off(sv); /* Curse the object. */
3604 if (SvTYPE(sv) != SVt_PVIO)
3605 --PL_sv_objcount; /* XXX Might want something more general */
3608 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3611 switch (SvTYPE(sv)) {
3614 IoIFP(sv) != PerlIO_stdin() &&
3615 IoIFP(sv) != PerlIO_stdout() &&
3616 IoIFP(sv) != PerlIO_stderr())
3618 io_close((IO*)sv, FALSE);
3620 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3621 PerlDir_close(IoDIRP(sv));
3622 IoDIRP(sv) = (DIR*)NULL;
3623 Safefree(IoTOP_NAME(sv));
3624 Safefree(IoFMT_NAME(sv));
3625 Safefree(IoBOTTOM_NAME(sv));
3640 SvREFCNT_dec(LvTARG(sv));
3644 Safefree(GvNAME(sv));
3645 /* cannot decrease stash refcount yet, as we might recursively delete
3646 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3647 of stash until current sv is completely gone.
3648 -- JohnPC, 27 Mar 1998 */
3649 stash = GvSTASH(sv);
3655 (void)SvOOK_off(sv);
3663 SvREFCNT_dec(SvRV(sv));
3665 else if (SvPVX(sv) && SvLEN(sv))
3666 Safefree(SvPVX(sv));
3676 switch (SvTYPE(sv)) {
3692 del_XPVIV(SvANY(sv));
3695 del_XPVNV(SvANY(sv));
3698 del_XPVMG(SvANY(sv));
3701 del_XPVLV(SvANY(sv));
3704 del_XPVAV(SvANY(sv));
3707 del_XPVHV(SvANY(sv));
3710 del_XPVCV(SvANY(sv));
3713 del_XPVGV(SvANY(sv));
3714 /* code duplication for increased performance. */
3715 SvFLAGS(sv) &= SVf_BREAK;
3716 SvFLAGS(sv) |= SVTYPEMASK;
3717 /* decrease refcount of the stash that owns this GV, if any */
3719 SvREFCNT_dec(stash);
3720 return; /* not break, SvFLAGS reset already happened */
3722 del_XPVBM(SvANY(sv));
3725 del_XPVFM(SvANY(sv));
3728 del_XPVIO(SvANY(sv));
3731 SvFLAGS(sv) &= SVf_BREAK;
3732 SvFLAGS(sv) |= SVTYPEMASK;
3736 Perl_sv_newref(pTHX_ SV *sv)
3739 ATOMIC_INC(SvREFCNT(sv));
3744 Perl_sv_free(pTHX_ SV *sv)
3747 int refcount_is_zero;
3751 if (SvREFCNT(sv) == 0) {
3752 if (SvFLAGS(sv) & SVf_BREAK)
3754 if (PL_in_clean_all) /* All is fair */
3756 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3757 /* make sure SvREFCNT(sv)==0 happens very seldom */
3758 SvREFCNT(sv) = (~(U32)0)/2;
3761 if (ckWARN_d(WARN_INTERNAL))
3762 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3765 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3766 if (!refcount_is_zero)
3770 if (ckWARN_d(WARN_DEBUGGING))
3771 Perl_warner(aTHX_ WARN_DEBUGGING,
3772 "Attempt to free temp prematurely: SV 0x%"UVxf,
3777 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3778 /* make sure SvREFCNT(sv)==0 happens very seldom */
3779 SvREFCNT(sv) = (~(U32)0)/2;
3790 Returns the length of the string in the SV. See also C<SvCUR>.
3796 Perl_sv_len(pTHX_ register SV *sv)
3805 len = mg_length(sv);
3807 junk = SvPV(sv, len);
3812 Perl_sv_len_utf8(pTHX_ register SV *sv)
3823 len = mg_length(sv);
3826 s = (U8*)SvPV(sv, len);
3837 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3842 I32 uoffset = *offsetp;
3848 start = s = (U8*)SvPV(sv, len);
3850 while (s < send && uoffset--)
3854 *offsetp = s - start;
3858 while (s < send && ulen--)
3868 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3877 s = (U8*)SvPV(sv, len);
3879 Perl_croak(aTHX_ "panic: bad byte offset");
3880 send = s + *offsetp;
3888 if (ckWARN_d(WARN_UTF8))
3889 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3899 Returns a boolean indicating whether the strings in the two SVs are
3906 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3918 pv1 = SvPV(str1, cur1);
3923 pv2 = SvPV(str2, cur2);
3928 return memEQ(pv1, pv2, cur1);
3934 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3935 string in C<sv1> is less than, equal to, or greater than the string in
3942 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3950 pv1 = SvPV(str1, cur1);
3958 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3959 /* must upgrade other to UTF8 first */
3961 sv_utf8_upgrade(str2);
3964 sv_utf8_upgrade(str1);
3965 /* refresh pointer and length */
3974 pv2 = sv_2pv(str2, &cur2);
3982 return cur2 ? -1 : 0;
3987 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3990 return retval < 0 ? -1 : 1;
3995 return cur1 < cur2 ? -1 : 1;
3999 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4001 #ifdef USE_LOCALE_COLLATE
4007 if (PL_collation_standard)
4011 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4013 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4015 if (!pv1 || !len1) {
4026 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4029 return retval < 0 ? -1 : 1;
4032 * When the result of collation is equality, that doesn't mean
4033 * that there are no differences -- some locales exclude some
4034 * characters from consideration. So to avoid false equalities,
4035 * we use the raw string as a tiebreaker.
4041 #endif /* USE_LOCALE_COLLATE */
4043 return sv_cmp(sv1, sv2);
4046 #ifdef USE_LOCALE_COLLATE
4048 * Any scalar variable may carry an 'o' magic that contains the
4049 * scalar data of the variable transformed to such a format that
4050 * a normal memory comparison can be used to compare the data
4051 * according to the locale settings.
4054 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4058 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4059 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4064 Safefree(mg->mg_ptr);
4066 if ((xf = mem_collxfrm(s, len, &xlen))) {
4067 if (SvREADONLY(sv)) {
4070 return xf + sizeof(PL_collation_ix);
4073 sv_magic(sv, 0, 'o', 0, 0);
4074 mg = mg_find(sv, 'o');
4087 if (mg && mg->mg_ptr) {
4089 return mg->mg_ptr + sizeof(PL_collation_ix);
4097 #endif /* USE_LOCALE_COLLATE */
4100 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4105 register STDCHAR rslast;
4106 register STDCHAR *bp;
4110 SV_CHECK_THINKFIRST(sv);
4111 (void)SvUPGRADE(sv, SVt_PV);
4115 if (RsSNARF(PL_rs)) {
4119 else if (RsRECORD(PL_rs)) {
4120 I32 recsize, bytesread;
4123 /* Grab the size of the record we're getting */
4124 recsize = SvIV(SvRV(PL_rs));
4125 (void)SvPOK_only(sv); /* Validate pointer */
4126 buffer = SvGROW(sv, recsize + 1);
4129 /* VMS wants read instead of fread, because fread doesn't respect */
4130 /* RMS record boundaries. This is not necessarily a good thing to be */
4131 /* doing, but we've got no other real choice */
4132 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4134 bytesread = PerlIO_read(fp, buffer, recsize);
4136 SvCUR_set(sv, bytesread);
4137 buffer[bytesread] = '\0';
4138 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4140 else if (RsPARA(PL_rs)) {
4145 rsptr = SvPV(PL_rs, rslen);
4146 rslast = rslen ? rsptr[rslen - 1] : '\0';
4148 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4149 do { /* to make sure file boundaries work right */
4152 i = PerlIO_getc(fp);
4156 PerlIO_ungetc(fp,i);
4162 /* See if we know enough about I/O mechanism to cheat it ! */
4164 /* This used to be #ifdef test - it is made run-time test for ease
4165 of abstracting out stdio interface. One call should be cheap
4166 enough here - and may even be a macro allowing compile
4170 if (PerlIO_fast_gets(fp)) {
4173 * We're going to steal some values from the stdio struct
4174 * and put EVERYTHING in the innermost loop into registers.
4176 register STDCHAR *ptr;
4180 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4181 /* An ungetc()d char is handled separately from the regular
4182 * buffer, so we getc() it back out and stuff it in the buffer.
4184 i = PerlIO_getc(fp);
4185 if (i == EOF) return 0;
4186 *(--((*fp)->_ptr)) = (unsigned char) i;
4190 /* Here is some breathtakingly efficient cheating */
4192 cnt = PerlIO_get_cnt(fp); /* get count into register */
4193 (void)SvPOK_only(sv); /* validate pointer */
4194 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4195 if (cnt > 80 && SvLEN(sv) > append) {
4196 shortbuffered = cnt - SvLEN(sv) + append + 1;
4197 cnt -= shortbuffered;
4201 /* remember that cnt can be negative */
4202 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4207 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4208 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4209 DEBUG_P(PerlIO_printf(Perl_debug_log,
4210 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4211 DEBUG_P(PerlIO_printf(Perl_debug_log,
4212 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4213 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4214 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4219 while (cnt > 0) { /* this | eat */
4221 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4222 goto thats_all_folks; /* screams | sed :-) */
4226 Copy(ptr, bp, cnt, char); /* this | eat */
4227 bp += cnt; /* screams | dust */
4228 ptr += cnt; /* louder | sed :-) */
4233 if (shortbuffered) { /* oh well, must extend */
4234 cnt = shortbuffered;
4236 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4238 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4239 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4243 DEBUG_P(PerlIO_printf(Perl_debug_log,
4244 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4245 PTR2UV(ptr),(long)cnt));
4246 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4247 DEBUG_P(PerlIO_printf(Perl_debug_log,
4248 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4249 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4250 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4251 /* This used to call 'filbuf' in stdio form, but as that behaves like
4252 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4253 another abstraction. */
4254 i = PerlIO_getc(fp); /* get more characters */
4255 DEBUG_P(PerlIO_printf(Perl_debug_log,
4256 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4257 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4258 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4259 cnt = PerlIO_get_cnt(fp);
4260 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4261 DEBUG_P(PerlIO_printf(Perl_debug_log,
4262 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4264 if (i == EOF) /* all done for ever? */
4265 goto thats_really_all_folks;
4267 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4269 SvGROW(sv, bpx + cnt + 2);
4270 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4272 *bp++ = i; /* store character from PerlIO_getc */
4274 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4275 goto thats_all_folks;
4279 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4280 memNE((char*)bp - rslen, rsptr, rslen))
4281 goto screamer; /* go back to the fray */
4282 thats_really_all_folks:
4284 cnt += shortbuffered;
4285 DEBUG_P(PerlIO_printf(Perl_debug_log,
4286 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4287 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4288 DEBUG_P(PerlIO_printf(Perl_debug_log,
4289 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4290 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4291 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4293 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4294 DEBUG_P(PerlIO_printf(Perl_debug_log,
4295 "Screamer: done, len=%ld, string=|%.*s|\n",
4296 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4301 /*The big, slow, and stupid way */
4304 /* Need to work around EPOC SDK features */
4305 /* On WINS: MS VC5 generates calls to _chkstk, */
4306 /* if a `large' stack frame is allocated */
4307 /* gcc on MARM does not generate calls like these */
4313 register STDCHAR *bpe = buf + sizeof(buf);
4315 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4316 ; /* keep reading */
4320 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4321 /* Accomodate broken VAXC compiler, which applies U8 cast to
4322 * both args of ?: operator, causing EOF to change into 255
4324 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4328 sv_catpvn(sv, (char *) buf, cnt);
4330 sv_setpvn(sv, (char *) buf, cnt);
4332 if (i != EOF && /* joy */
4334 SvCUR(sv) < rslen ||
4335 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4339 * If we're reading from a TTY and we get a short read,
4340 * indicating that the user hit his EOF character, we need
4341 * to notice it now, because if we try to read from the TTY
4342 * again, the EOF condition will disappear.
4344 * The comparison of cnt to sizeof(buf) is an optimization
4345 * that prevents unnecessary calls to feof().
4349 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4354 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4355 while (i != EOF) { /* to make sure file boundaries work right */
4356 i = PerlIO_getc(fp);
4358 PerlIO_ungetc(fp,i);
4364 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4371 Auto-increment of the value in the SV.
4377 Perl_sv_inc(pTHX_ register SV *sv)
4386 if (SvTHINKFIRST(sv)) {
4387 if (SvREADONLY(sv)) {
4389 if (PL_curcop != &PL_compiling)
4390 Perl_croak(aTHX_ PL_no_modify);
4394 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4396 i = PTR2IV(SvRV(sv));
4401 flags = SvFLAGS(sv);
4402 if (flags & SVp_NOK) {
4403 (void)SvNOK_only(sv);
4407 if (flags & SVp_IOK) {
4409 if (SvUVX(sv) == UV_MAX)
4410 sv_setnv(sv, (NV)UV_MAX + 1.0);
4412 (void)SvIOK_only_UV(sv);
4415 if (SvIVX(sv) == IV_MAX)
4416 sv_setnv(sv, (NV)IV_MAX + 1.0);
4418 (void)SvIOK_only(sv);
4424 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4425 if ((flags & SVTYPEMASK) < SVt_PVNV)
4426 sv_upgrade(sv, SVt_NV);
4428 (void)SvNOK_only(sv);
4432 while (isALPHA(*d)) d++;
4433 while (isDIGIT(*d)) d++;
4435 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4439 while (d >= SvPVX(sv)) {
4447 /* MKS: The original code here died if letters weren't consecutive.
4448 * at least it didn't have to worry about non-C locales. The
4449 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4450 * arranged in order (although not consecutively) and that only
4451 * [A-Za-z] are accepted by isALPHA in the C locale.
4453 if (*d != 'z' && *d != 'Z') {
4454 do { ++*d; } while (!isALPHA(*d));
4457 *(d--) -= 'z' - 'a';
4462 *(d--) -= 'z' - 'a' + 1;
4466 /* oh,oh, the number grew */
4467 SvGROW(sv, SvCUR(sv) + 2);
4469 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4480 Auto-decrement of the value in the SV.
4486 Perl_sv_dec(pTHX_ register SV *sv)
4494 if (SvTHINKFIRST(sv)) {
4495 if (SvREADONLY(sv)) {
4497 if (PL_curcop != &PL_compiling)
4498 Perl_croak(aTHX_ PL_no_modify);
4502 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4504 i = PTR2IV(SvRV(sv));
4509 flags = SvFLAGS(sv);
4510 if (flags & SVp_NOK) {
4512 (void)SvNOK_only(sv);
4515 if (flags & SVp_IOK) {
4517 if (SvUVX(sv) == 0) {
4518 (void)SvIOK_only(sv);
4522 (void)SvIOK_only_UV(sv);
4526 if (SvIVX(sv) == IV_MIN)
4527 sv_setnv(sv, (NV)IV_MIN - 1.0);
4529 (void)SvIOK_only(sv);
4535 if (!(flags & SVp_POK)) {
4536 if ((flags & SVTYPEMASK) < SVt_PVNV)
4537 sv_upgrade(sv, SVt_NV);
4539 (void)SvNOK_only(sv);
4542 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4546 =for apidoc sv_mortalcopy
4548 Creates a new SV which is a copy of the original SV. The new SV is marked
4554 /* Make a string that will exist for the duration of the expression
4555 * evaluation. Actually, it may have to last longer than that, but
4556 * hopefully we won't free it until it has been assigned to a
4557 * permanent location. */
4560 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4566 sv_setsv(sv,oldstr);
4568 PL_tmps_stack[++PL_tmps_ix] = sv;
4574 =for apidoc sv_newmortal
4576 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4582 Perl_sv_newmortal(pTHX)
4588 SvFLAGS(sv) = SVs_TEMP;
4590 PL_tmps_stack[++PL_tmps_ix] = sv;
4595 =for apidoc sv_2mortal
4597 Marks an SV as mortal. The SV will be destroyed when the current context
4603 /* same thing without the copying */
4606 Perl_sv_2mortal(pTHX_ register SV *sv)
4611 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4614 PL_tmps_stack[++PL_tmps_ix] = sv;
4622 Creates a new SV and copies a string into it. The reference count for the
4623 SV is set to 1. If C<len> is zero, Perl will compute the length using
4624 strlen(). For efficiency, consider using C<newSVpvn> instead.
4630 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4637 sv_setpvn(sv,s,len);
4642 =for apidoc newSVpvn
4644 Creates a new SV and copies a string into it. The reference count for the
4645 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4646 string. You are responsible for ensuring that the source string is at least
4653 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4658 sv_setpvn(sv,s,len);
4662 #if defined(PERL_IMPLICIT_CONTEXT)
4664 Perl_newSVpvf_nocontext(const char* pat, ...)
4669 va_start(args, pat);
4670 sv = vnewSVpvf(pat, &args);
4677 =for apidoc newSVpvf
4679 Creates a new SV an initialize it with the string formatted like
4686 Perl_newSVpvf(pTHX_ const char* pat, ...)
4690 va_start(args, pat);
4691 sv = vnewSVpvf(pat, &args);
4697 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4701 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4708 Creates a new SV and copies a floating point value into it.
4709 The reference count for the SV is set to 1.
4715 Perl_newSVnv(pTHX_ NV n)
4727 Creates a new SV and copies an integer into it. The reference count for the
4734 Perl_newSViv(pTHX_ IV i)
4744 =for apidoc newRV_noinc
4746 Creates an RV wrapper for an SV. The reference count for the original
4747 SV is B<not> incremented.
4753 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4759 sv_upgrade(sv, SVt_RV);
4766 /* newRV_inc is #defined to newRV in sv.h */
4768 Perl_newRV(pTHX_ SV *tmpRef)
4770 return newRV_noinc(SvREFCNT_inc(tmpRef));
4776 Creates a new SV which is an exact duplicate of the original SV.
4781 /* make an exact duplicate of old */
4784 Perl_newSVsv(pTHX_ register SV *old)
4791 if (SvTYPE(old) == SVTYPEMASK) {
4792 if (ckWARN_d(WARN_INTERNAL))
4793 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4808 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4816 char todo[PERL_UCHAR_MAX+1];
4821 if (!*s) { /* reset ?? searches */
4822 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4823 pm->op_pmdynflags &= ~PMdf_USED;
4828 /* reset variables */
4830 if (!HvARRAY(stash))
4833 Zero(todo, 256, char);
4835 i = (unsigned char)*s;
4839 max = (unsigned char)*s++;
4840 for ( ; i <= max; i++) {
4843 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4844 for (entry = HvARRAY(stash)[i];
4846 entry = HeNEXT(entry))
4848 if (!todo[(U8)*HeKEY(entry)])
4850 gv = (GV*)HeVAL(entry);
4852 if (SvTHINKFIRST(sv)) {
4853 if (!SvREADONLY(sv) && SvROK(sv))
4858 if (SvTYPE(sv) >= SVt_PV) {
4860 if (SvPVX(sv) != Nullch)
4867 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4869 #ifndef VMS /* VMS has no environ array */
4871 environ[0] = Nullch;
4880 Perl_sv_2io(pTHX_ SV *sv)
4886 switch (SvTYPE(sv)) {
4894 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4898 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4900 return sv_2io(SvRV(sv));
4901 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4907 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4914 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4921 return *gvp = Nullgv, Nullcv;
4922 switch (SvTYPE(sv)) {
4942 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4943 tryAMAGICunDEREF(to_cv);
4946 if (SvTYPE(sv) == SVt_PVCV) {
4955 Perl_croak(aTHX_ "Not a subroutine reference");
4960 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4966 if (lref && !GvCVu(gv)) {
4969 tmpsv = NEWSV(704,0);
4970 gv_efullname3(tmpsv, gv, Nullch);
4971 /* XXX this is probably not what they think they're getting.
4972 * It has the same effect as "sub name;", i.e. just a forward
4974 newSUB(start_subparse(FALSE, 0),
4975 newSVOP(OP_CONST, 0, tmpsv),
4980 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4987 Perl_sv_true(pTHX_ register SV *sv)
4994 if ((tXpv = (XPV*)SvANY(sv)) &&
4995 (tXpv->xpv_cur > 1 ||
4996 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5003 return SvIVX(sv) != 0;
5006 return SvNVX(sv) != 0.0;
5008 return sv_2bool(sv);
5014 Perl_sv_iv(pTHX_ register SV *sv)
5018 return (IV)SvUVX(sv);
5025 Perl_sv_uv(pTHX_ register SV *sv)
5030 return (UV)SvIVX(sv);
5036 Perl_sv_nv(pTHX_ register SV *sv)
5044 Perl_sv_pv(pTHX_ SV *sv)
5051 return sv_2pv(sv, &n_a);
5055 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5061 return sv_2pv(sv, lp);
5065 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5069 if (SvTHINKFIRST(sv) && !SvROK(sv))
5070 sv_force_normal(sv);
5076 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5078 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5079 PL_op_name[PL_op->op_type]);
5083 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5088 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5089 SvGROW(sv, len + 1);
5090 Move(s,SvPVX(sv),len,char);
5095 SvPOK_on(sv); /* validate pointer */
5097 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5098 PTR2UV(sv),SvPVX(sv)));
5105 Perl_sv_pvbyte(pTHX_ SV *sv)
5111 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5113 return sv_pvn(sv,lp);
5117 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5119 return sv_pvn_force(sv,lp);
5123 Perl_sv_pvutf8(pTHX_ SV *sv)
5125 sv_utf8_upgrade(sv);
5130 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5132 sv_utf8_upgrade(sv);
5133 return sv_pvn(sv,lp);
5137 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5139 sv_utf8_upgrade(sv);
5140 return sv_pvn_force(sv,lp);
5144 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5146 if (ob && SvOBJECT(sv))
5147 return HvNAME(SvSTASH(sv));
5149 switch (SvTYPE(sv)) {
5163 case SVt_PVLV: return "LVALUE";
5164 case SVt_PVAV: return "ARRAY";
5165 case SVt_PVHV: return "HASH";
5166 case SVt_PVCV: return "CODE";
5167 case SVt_PVGV: return "GLOB";
5168 case SVt_PVFM: return "FORMAT";
5169 default: return "UNKNOWN";
5175 =for apidoc sv_isobject
5177 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5178 object. If the SV is not an RV, or if the object is not blessed, then this
5185 Perl_sv_isobject(pTHX_ SV *sv)
5202 Returns a boolean indicating whether the SV is blessed into the specified
5203 class. This does not check for subtypes; use C<sv_derived_from> to verify
5204 an inheritance relationship.
5210 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5222 return strEQ(HvNAME(SvSTASH(sv)), name);
5228 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5229 it will be upgraded to one. If C<classname> is non-null then the new SV will
5230 be blessed in the specified package. The new SV is returned and its
5231 reference count is 1.
5237 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5244 SV_CHECK_THINKFIRST(rv);
5247 if (SvTYPE(rv) < SVt_RV)
5248 sv_upgrade(rv, SVt_RV);
5255 HV* stash = gv_stashpv(classname, TRUE);
5256 (void)sv_bless(rv, stash);
5262 =for apidoc sv_setref_pv
5264 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5265 argument will be upgraded to an RV. That RV will be modified to point to
5266 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5267 into the SV. The C<classname> argument indicates the package for the
5268 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5269 will be returned and will have a reference count of 1.
5271 Do not use with other Perl types such as HV, AV, SV, CV, because those
5272 objects will become corrupted by the pointer copy process.
5274 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5280 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5283 sv_setsv(rv, &PL_sv_undef);
5287 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5292 =for apidoc sv_setref_iv
5294 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5295 argument will be upgraded to an RV. That RV will be modified to point to
5296 the new SV. The C<classname> argument indicates the package for the
5297 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5298 will be returned and will have a reference count of 1.
5304 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5306 sv_setiv(newSVrv(rv,classname), iv);
5311 =for apidoc sv_setref_nv
5313 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5314 argument will be upgraded to an RV. That RV will be modified to point to
5315 the new SV. The C<classname> argument indicates the package for the
5316 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5317 will be returned and will have a reference count of 1.
5323 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5325 sv_setnv(newSVrv(rv,classname), nv);
5330 =for apidoc sv_setref_pvn
5332 Copies a string into a new SV, optionally blessing the SV. The length of the
5333 string must be specified with C<n>. The C<rv> argument will be upgraded to
5334 an RV. That RV will be modified to point to the new SV. The C<classname>
5335 argument indicates the package for the blessing. Set C<classname> to
5336 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5337 a reference count of 1.
5339 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5345 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5347 sv_setpvn(newSVrv(rv,classname), pv, n);
5352 =for apidoc sv_bless
5354 Blesses an SV into a specified package. The SV must be an RV. The package
5355 must be designated by its stash (see C<gv_stashpv()>). The reference count
5356 of the SV is unaffected.
5362 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5367 Perl_croak(aTHX_ "Can't bless non-reference value");
5369 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5370 if (SvREADONLY(tmpRef))
5371 Perl_croak(aTHX_ PL_no_modify);
5372 if (SvOBJECT(tmpRef)) {
5373 if (SvTYPE(tmpRef) != SVt_PVIO)
5375 SvREFCNT_dec(SvSTASH(tmpRef));
5378 SvOBJECT_on(tmpRef);
5379 if (SvTYPE(tmpRef) != SVt_PVIO)
5381 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5382 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5393 S_sv_unglob(pTHX_ SV *sv)
5397 assert(SvTYPE(sv) == SVt_PVGV);
5402 SvREFCNT_dec(GvSTASH(sv));
5403 GvSTASH(sv) = Nullhv;
5405 sv_unmagic(sv, '*');
5406 Safefree(GvNAME(sv));
5409 /* need to keep SvANY(sv) in the right arena */
5410 xpvmg = new_XPVMG();
5411 StructCopy(SvANY(sv), xpvmg, XPVMG);
5412 del_XPVGV(SvANY(sv));
5415 SvFLAGS(sv) &= ~SVTYPEMASK;
5416 SvFLAGS(sv) |= SVt_PVMG;
5420 =for apidoc sv_unref
5422 Unsets the RV status of the SV, and decrements the reference count of
5423 whatever was being referenced by the RV. This can almost be thought of
5424 as a reversal of C<newSVrv>. See C<SvROK_off>.
5430 Perl_sv_unref(pTHX_ SV *sv)
5434 if (SvWEAKREF(sv)) {
5442 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5445 sv_2mortal(rv); /* Schedule for freeing later */
5449 Perl_sv_taint(pTHX_ SV *sv)
5451 sv_magic((sv), Nullsv, 't', Nullch, 0);
5455 Perl_sv_untaint(pTHX_ SV *sv)
5457 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5458 MAGIC *mg = mg_find(sv, 't');
5465 Perl_sv_tainted(pTHX_ SV *sv)
5467 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5468 MAGIC *mg = mg_find(sv, 't');
5469 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
5476 =for apidoc sv_setpviv
5478 Copies an integer into the given SV, also updating its string value.
5479 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5485 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5487 char buf[TYPE_CHARS(UV)];
5489 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5491 sv_setpvn(sv, ptr, ebuf - ptr);
5496 =for apidoc sv_setpviv_mg
5498 Like C<sv_setpviv>, but also handles 'set' magic.
5504 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5506 char buf[TYPE_CHARS(UV)];
5508 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5510 sv_setpvn(sv, ptr, ebuf - ptr);
5514 #if defined(PERL_IMPLICIT_CONTEXT)
5516 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5520 va_start(args, pat);
5521 sv_vsetpvf(sv, pat, &args);
5527 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5531 va_start(args, pat);
5532 sv_vsetpvf_mg(sv, pat, &args);
5538 =for apidoc sv_setpvf
5540 Processes its arguments like C<sprintf> and sets an SV to the formatted
5541 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5547 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5550 va_start(args, pat);
5551 sv_vsetpvf(sv, pat, &args);
5556 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5558 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5562 =for apidoc sv_setpvf_mg
5564 Like C<sv_setpvf>, but also handles 'set' magic.
5570 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5573 va_start(args, pat);
5574 sv_vsetpvf_mg(sv, pat, &args);
5579 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5581 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5585 #if defined(PERL_IMPLICIT_CONTEXT)
5587 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5591 va_start(args, pat);
5592 sv_vcatpvf(sv, pat, &args);
5597 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5601 va_start(args, pat);
5602 sv_vcatpvf_mg(sv, pat, &args);
5608 =for apidoc sv_catpvf
5610 Processes its arguments like C<sprintf> and appends the formatted output
5611 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5612 typically be called after calling this function to handle 'set' magic.
5618 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5621 va_start(args, pat);
5622 sv_vcatpvf(sv, pat, &args);
5627 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5629 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5633 =for apidoc sv_catpvf_mg
5635 Like C<sv_catpvf>, but also handles 'set' magic.
5641 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5644 va_start(args, pat);
5645 sv_vcatpvf_mg(sv, pat, &args);
5650 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5652 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5657 =for apidoc sv_vsetpvfn
5659 Works like C<vcatpvfn> but copies the text into the SV instead of
5666 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5668 sv_setpvn(sv, "", 0);
5669 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5673 =for apidoc sv_vcatpvfn
5675 Processes its arguments like C<vsprintf> and appends the formatted output
5676 to an SV. Uses an array of SVs if the C style variable argument list is
5677 missing (NULL). When running with taint checks enabled, indicates via
5678 C<maybe_tainted> if results are untrustworthy (often due to the use of
5685 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5693 static char nullstr[] = "(null)";
5696 /* no matter what, this is a string now */
5697 (void)SvPV_force(sv, origlen);
5699 /* special-case "", "%s", and "%_" */
5702 if (patlen == 2 && pat[0] == '%') {
5706 char *s = va_arg(*args, char*);
5707 sv_catpv(sv, s ? s : nullstr);
5709 else if (svix < svmax) {
5710 sv_catsv(sv, *svargs);
5711 if (DO_UTF8(*svargs))
5717 argsv = va_arg(*args, SV*);
5718 sv_catsv(sv, argsv);
5723 /* See comment on '_' below */
5728 patend = (char*)pat + patlen;
5729 for (p = (char*)pat; p < patend; p = q) {
5737 bool has_precis = FALSE;
5739 bool is_utf = FALSE;
5743 STRLEN esignlen = 0;
5745 char *eptr = Nullch;
5747 /* Times 4: a decimal digit takes more than 3 binary digits.
5748 * NV_DIG: mantissa takes than many decimal digits.
5749 * Plus 32: Playing safe. */
5750 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5751 /* large enough for "%#.#f" --chip */
5752 /* what about long double NVs? --jhi */
5763 for (q = p; q < patend && *q != '%'; ++q) ;
5765 sv_catpvn(sv, p, q - p);
5803 case '1': case '2': case '3':
5804 case '4': case '5': case '6':
5805 case '7': case '8': case '9':
5808 width = width * 10 + (*q++ - '0');
5813 i = va_arg(*args, int);
5815 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5817 width = (i < 0) ? -i : i;
5828 i = va_arg(*args, int);
5830 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5831 precis = (i < 0) ? 0 : i;
5837 precis = precis * 10 + (*q++ - '0');
5854 if (*(q + 1) == 'l') { /* lld */
5881 uv = va_arg(*args, int);
5883 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5884 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5885 eptr = (char*)utf8buf;
5886 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5898 eptr = va_arg(*args, char*);
5900 #ifdef MACOS_TRADITIONAL
5901 /* On MacOS, %#s format is used for Pascal strings */
5906 elen = strlen(eptr);
5909 elen = sizeof nullstr - 1;
5912 else if (svix < svmax) {
5913 argsv = svargs[svix++];
5914 eptr = SvPVx(argsv, elen);
5915 if (DO_UTF8(argsv)) {
5916 if (has_precis && precis < elen) {
5918 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5921 if (width) { /* fudge width (can't fudge elen) */
5922 width += elen - sv_len_utf8(argsv);
5931 argsv = va_arg(*args, SV*);
5932 else if (svix < svmax)
5933 argsv = svargs[svix++];
5936 U8 *str = (U8*)SvPVx(argsv,len);
5938 SV *vsv = NEWSV(73,vlen);
5941 U8 *vptr = (U8*)SvPVX(vsv);
5943 bool utf = DO_UTF8(argsv);
5951 uv = utf8_to_uv(str, &ulen);
5958 eptr = ebuf + sizeof ebuf;
5960 *--eptr = '0' + uv % 10;
5962 elen = (ebuf + sizeof ebuf) - eptr;
5963 while (elen >= vfree-1) {
5964 STRLEN off = vptr - (U8*)SvPVX(vsv);
5968 vptr = (U8*)SvPVX(vsv) + off;
5970 memcpy(vptr, eptr, elen);
5980 SvCUR_set(vsv,vcur);
5988 * The "%_" hack might have to be changed someday,
5989 * if ISO or ANSI decide to use '_' for something.
5990 * So we keep it hidden from users' code.
5994 argsv = va_arg(*args,SV*);
5995 eptr = SvPVx(argsv, elen);
6000 if (has_precis && elen > precis)
6008 uv = PTR2UV(va_arg(*args, void*));
6010 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6025 case 'h': iv = (short)va_arg(*args, int); break;
6026 default: iv = va_arg(*args, int); break;
6027 case 'l': iv = va_arg(*args, long); break;
6028 case 'V': iv = va_arg(*args, IV); break;
6030 case 'q': iv = va_arg(*args, Quad_t); break;
6035 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6037 case 'h': iv = (short)iv; break;
6038 default: iv = (int)iv; break;
6039 case 'l': iv = (long)iv; break;
6042 case 'q': iv = (Quad_t)iv; break;
6049 esignbuf[esignlen++] = plus;
6053 esignbuf[esignlen++] = '-';
6091 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6092 default: uv = va_arg(*args, unsigned); break;
6093 case 'l': uv = va_arg(*args, unsigned long); break;
6094 case 'V': uv = va_arg(*args, UV); break;
6096 case 'q': uv = va_arg(*args, Quad_t); break;
6101 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6103 case 'h': uv = (unsigned short)uv; break;
6104 default: uv = (unsigned)uv; break;
6105 case 'l': uv = (unsigned long)uv; break;
6108 case 'q': uv = (Quad_t)uv; break;
6114 eptr = ebuf + sizeof ebuf;
6120 p = (char*)((c == 'X')
6121 ? "0123456789ABCDEF" : "0123456789abcdef");
6127 esignbuf[esignlen++] = '0';
6128 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6134 *--eptr = '0' + dig;
6136 if (alt && *eptr != '0')
6142 *--eptr = '0' + dig;
6145 esignbuf[esignlen++] = '0';
6146 esignbuf[esignlen++] = 'b';
6149 default: /* it had better be ten or less */
6150 #if defined(PERL_Y2KWARN)
6151 if (ckWARN(WARN_Y2K)) {
6153 char *s = SvPV(sv,n);
6154 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6155 && (n == 2 || !isDIGIT(s[n-3])))
6157 Perl_warner(aTHX_ WARN_Y2K,
6158 "Possible Y2K bug: %%%c %s",
6159 c, "format string following '19'");
6165 *--eptr = '0' + dig;
6166 } while (uv /= base);
6169 elen = (ebuf + sizeof ebuf) - eptr;
6172 zeros = precis - elen;
6173 else if (precis == 0 && elen == 1 && *eptr == '0')
6178 /* FLOATING POINT */
6181 c = 'f'; /* maybe %F isn't supported here */
6187 /* This is evil, but floating point is even more evil */
6190 nv = va_arg(*args, NV);
6192 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6195 if (c != 'e' && c != 'E') {
6197 (void)frexp(nv, &i);
6198 if (i == PERL_INT_MIN)
6199 Perl_die(aTHX_ "panic: frexp");
6201 need = BIT_DIGITS(i);
6203 need += has_precis ? precis : 6; /* known default */
6207 need += 20; /* fudge factor */
6208 if (PL_efloatsize < need) {
6209 Safefree(PL_efloatbuf);
6210 PL_efloatsize = need + 20; /* more fudge */
6211 New(906, PL_efloatbuf, PL_efloatsize, char);
6212 PL_efloatbuf[0] = '\0';
6215 eptr = ebuf + sizeof ebuf;
6218 #ifdef USE_LONG_DOUBLE
6220 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6221 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6226 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6231 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6244 RESTORE_NUMERIC_STANDARD();
6245 (void)sprintf(PL_efloatbuf, eptr, nv);
6246 RESTORE_NUMERIC_LOCAL();
6249 eptr = PL_efloatbuf;
6250 elen = strlen(PL_efloatbuf);
6256 i = SvCUR(sv) - origlen;
6259 case 'h': *(va_arg(*args, short*)) = i; break;
6260 default: *(va_arg(*args, int*)) = i; break;
6261 case 'l': *(va_arg(*args, long*)) = i; break;
6262 case 'V': *(va_arg(*args, IV*)) = i; break;
6264 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6268 else if (svix < svmax)
6269 sv_setuv(svargs[svix++], (UV)i);
6270 continue; /* not "break" */
6276 if (!args && ckWARN(WARN_PRINTF) &&
6277 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6278 SV *msg = sv_newmortal();
6279 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6280 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6283 Perl_sv_catpvf(aTHX_ msg,
6284 "\"%%%c\"", c & 0xFF);
6286 Perl_sv_catpvf(aTHX_ msg,
6287 "\"%%\\%03"UVof"\"",
6290 sv_catpv(msg, "end of string");
6291 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6294 /* output mangled stuff ... */
6300 /* ... right here, because formatting flags should not apply */
6301 SvGROW(sv, SvCUR(sv) + elen + 1);
6303 memcpy(p, eptr, elen);
6306 SvCUR(sv) = p - SvPVX(sv);
6307 continue; /* not "break" */
6310 have = esignlen + zeros + elen;
6311 need = (have > width ? have : width);
6314 SvGROW(sv, SvCUR(sv) + need + 1);
6316 if (esignlen && fill == '0') {
6317 for (i = 0; i < esignlen; i++)
6321 memset(p, fill, gap);
6324 if (esignlen && fill != '0') {
6325 for (i = 0; i < esignlen; i++)
6329 for (i = zeros; i; i--)
6333 memcpy(p, eptr, elen);
6337 memset(p, ' ', gap);
6343 SvCUR(sv) = p - SvPVX(sv);
6347 #if defined(USE_ITHREADS)
6349 #if defined(USE_THREADS)
6350 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6353 #ifndef OpREFCNT_inc
6354 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
6357 #ifndef GpREFCNT_inc
6358 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6362 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6363 #define av_dup(s) (AV*)sv_dup((SV*)s)
6364 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6365 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6366 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6367 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6368 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6369 #define io_dup(s) (IO*)sv_dup((SV*)s)
6370 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6371 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6372 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6373 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6374 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6377 Perl_re_dup(pTHX_ REGEXP *r)
6379 /* XXX fix when pmop->op_pmregexp becomes shared */
6380 return ReREFCNT_inc(r);
6384 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6388 return (PerlIO*)NULL;
6390 /* look for it in the table first */
6391 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6395 /* create anew and remember what it is */
6396 ret = PerlIO_fdupopen(fp);
6397 ptr_table_store(PL_ptr_table, fp, ret);
6402 Perl_dirp_dup(pTHX_ DIR *dp)
6411 Perl_gp_dup(pTHX_ GP *gp)
6416 /* look for it in the table first */
6417 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6421 /* create anew and remember what it is */
6422 Newz(0, ret, 1, GP);
6423 ptr_table_store(PL_ptr_table, gp, ret);
6426 ret->gp_refcnt = 0; /* must be before any other dups! */
6427 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6428 ret->gp_io = io_dup_inc(gp->gp_io);
6429 ret->gp_form = cv_dup_inc(gp->gp_form);
6430 ret->gp_av = av_dup_inc(gp->gp_av);
6431 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6432 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6433 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6434 ret->gp_cvgen = gp->gp_cvgen;
6435 ret->gp_flags = gp->gp_flags;
6436 ret->gp_line = gp->gp_line;
6437 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6442 Perl_mg_dup(pTHX_ MAGIC *mg)
6444 MAGIC *mgret = (MAGIC*)NULL;
6447 return (MAGIC*)NULL;
6448 /* look for it in the table first */
6449 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6453 for (; mg; mg = mg->mg_moremagic) {
6455 Newz(0, nmg, 1, MAGIC);
6459 mgprev->mg_moremagic = nmg;
6460 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6461 nmg->mg_private = mg->mg_private;
6462 nmg->mg_type = mg->mg_type;
6463 nmg->mg_flags = mg->mg_flags;
6464 if (mg->mg_type == 'r') {
6465 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6468 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6469 ? sv_dup_inc(mg->mg_obj)
6470 : sv_dup(mg->mg_obj);
6472 nmg->mg_len = mg->mg_len;
6473 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6474 if (mg->mg_ptr && mg->mg_type != 'g') {
6475 if (mg->mg_len >= 0) {
6476 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6477 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6478 AMT *amtp = (AMT*)mg->mg_ptr;
6479 AMT *namtp = (AMT*)nmg->mg_ptr;
6481 for (i = 1; i < NofAMmeth; i++) {
6482 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6486 else if (mg->mg_len == HEf_SVKEY)
6487 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6495 Perl_ptr_table_new(pTHX)
6498 Newz(0, tbl, 1, PTR_TBL_t);
6501 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6506 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6508 PTR_TBL_ENT_t *tblent;
6509 UV hash = PTR2UV(sv);
6511 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6512 for (; tblent; tblent = tblent->next) {
6513 if (tblent->oldval == sv)
6514 return tblent->newval;
6520 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6522 PTR_TBL_ENT_t *tblent, **otblent;
6523 /* XXX this may be pessimal on platforms where pointers aren't good
6524 * hash values e.g. if they grow faster in the most significant
6526 UV hash = PTR2UV(oldv);
6530 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6531 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6532 if (tblent->oldval == oldv) {
6533 tblent->newval = newv;
6538 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6539 tblent->oldval = oldv;
6540 tblent->newval = newv;
6541 tblent->next = *otblent;
6544 if (i && tbl->tbl_items > tbl->tbl_max)
6545 ptr_table_split(tbl);
6549 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6551 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6552 UV oldsize = tbl->tbl_max + 1;
6553 UV newsize = oldsize * 2;
6556 Renew(ary, newsize, PTR_TBL_ENT_t*);
6557 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6558 tbl->tbl_max = --newsize;
6560 for (i=0; i < oldsize; i++, ary++) {
6561 PTR_TBL_ENT_t **curentp, **entp, *ent;
6564 curentp = ary + oldsize;
6565 for (entp = ary, ent = *ary; ent; ent = *entp) {
6566 if ((newsize & PTR2UV(ent->oldval)) != i) {
6568 ent->next = *curentp;
6583 Perl_sv_dup(pTHX_ SV *sstr)
6590 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6592 /* look for it in the table first */
6593 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6597 /* create anew and remember what it is */
6599 ptr_table_store(PL_ptr_table, sstr, dstr);
6602 SvFLAGS(dstr) = SvFLAGS(sstr);
6603 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6604 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6607 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6608 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6609 PL_watch_pvx, SvPVX(sstr));
6612 switch (SvTYPE(sstr)) {
6617 SvANY(dstr) = new_XIV();
6618 SvIVX(dstr) = SvIVX(sstr);
6621 SvANY(dstr) = new_XNV();
6622 SvNVX(dstr) = SvNVX(sstr);
6625 SvANY(dstr) = new_XRV();
6626 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6629 SvANY(dstr) = new_XPV();
6630 SvCUR(dstr) = SvCUR(sstr);
6631 SvLEN(dstr) = SvLEN(sstr);
6633 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6634 else if (SvPVX(sstr) && SvLEN(sstr))
6635 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6637 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6640 SvANY(dstr) = new_XPVIV();
6641 SvCUR(dstr) = SvCUR(sstr);
6642 SvLEN(dstr) = SvLEN(sstr);
6643 SvIVX(dstr) = SvIVX(sstr);
6645 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6646 else if (SvPVX(sstr) && SvLEN(sstr))
6647 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6649 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6652 SvANY(dstr) = new_XPVNV();
6653 SvCUR(dstr) = SvCUR(sstr);
6654 SvLEN(dstr) = SvLEN(sstr);
6655 SvIVX(dstr) = SvIVX(sstr);
6656 SvNVX(dstr) = SvNVX(sstr);
6658 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6659 else if (SvPVX(sstr) && SvLEN(sstr))
6660 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6662 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6665 SvANY(dstr) = new_XPVMG();
6666 SvCUR(dstr) = SvCUR(sstr);
6667 SvLEN(dstr) = SvLEN(sstr);
6668 SvIVX(dstr) = SvIVX(sstr);
6669 SvNVX(dstr) = SvNVX(sstr);
6670 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6671 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6673 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6674 else if (SvPVX(sstr) && SvLEN(sstr))
6675 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6677 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6680 SvANY(dstr) = new_XPVBM();
6681 SvCUR(dstr) = SvCUR(sstr);
6682 SvLEN(dstr) = SvLEN(sstr);
6683 SvIVX(dstr) = SvIVX(sstr);
6684 SvNVX(dstr) = SvNVX(sstr);
6685 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6686 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6688 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6689 else if (SvPVX(sstr) && SvLEN(sstr))
6690 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6692 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6693 BmRARE(dstr) = BmRARE(sstr);
6694 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6695 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6698 SvANY(dstr) = new_XPVLV();
6699 SvCUR(dstr) = SvCUR(sstr);
6700 SvLEN(dstr) = SvLEN(sstr);
6701 SvIVX(dstr) = SvIVX(sstr);
6702 SvNVX(dstr) = SvNVX(sstr);
6703 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6704 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6706 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6707 else if (SvPVX(sstr) && SvLEN(sstr))
6708 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6710 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6711 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6712 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6713 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6714 LvTYPE(dstr) = LvTYPE(sstr);
6717 SvANY(dstr) = new_XPVGV();
6718 SvCUR(dstr) = SvCUR(sstr);
6719 SvLEN(dstr) = SvLEN(sstr);
6720 SvIVX(dstr) = SvIVX(sstr);
6721 SvNVX(dstr) = SvNVX(sstr);
6722 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6723 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6725 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6726 else if (SvPVX(sstr) && SvLEN(sstr))
6727 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6729 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6730 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6731 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6732 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6733 GvFLAGS(dstr) = GvFLAGS(sstr);
6734 GvGP(dstr) = gp_dup(GvGP(sstr));
6735 (void)GpREFCNT_inc(GvGP(dstr));
6738 SvANY(dstr) = new_XPVIO();
6739 SvCUR(dstr) = SvCUR(sstr);
6740 SvLEN(dstr) = SvLEN(sstr);
6741 SvIVX(dstr) = SvIVX(sstr);
6742 SvNVX(dstr) = SvNVX(sstr);
6743 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6744 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6746 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6747 else if (SvPVX(sstr) && SvLEN(sstr))
6748 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6750 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6751 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6752 if (IoOFP(sstr) == IoIFP(sstr))
6753 IoOFP(dstr) = IoIFP(dstr);
6755 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6756 /* PL_rsfp_filters entries have fake IoDIRP() */
6757 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6758 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6760 IoDIRP(dstr) = IoDIRP(sstr);
6761 IoLINES(dstr) = IoLINES(sstr);
6762 IoPAGE(dstr) = IoPAGE(sstr);
6763 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6764 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6765 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6766 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6767 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6768 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6769 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6770 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6771 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6772 IoTYPE(dstr) = IoTYPE(sstr);
6773 IoFLAGS(dstr) = IoFLAGS(sstr);
6776 SvANY(dstr) = new_XPVAV();
6777 SvCUR(dstr) = SvCUR(sstr);
6778 SvLEN(dstr) = SvLEN(sstr);
6779 SvIVX(dstr) = SvIVX(sstr);
6780 SvNVX(dstr) = SvNVX(sstr);
6781 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6782 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6783 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6784 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6785 if (AvARRAY((AV*)sstr)) {
6786 SV **dst_ary, **src_ary;
6787 SSize_t items = AvFILLp((AV*)sstr) + 1;
6789 src_ary = AvARRAY((AV*)sstr);
6790 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6791 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6792 SvPVX(dstr) = (char*)dst_ary;
6793 AvALLOC((AV*)dstr) = dst_ary;
6794 if (AvREAL((AV*)sstr)) {
6796 *dst_ary++ = sv_dup_inc(*src_ary++);
6800 *dst_ary++ = sv_dup(*src_ary++);
6802 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6803 while (items-- > 0) {
6804 *dst_ary++ = &PL_sv_undef;
6808 SvPVX(dstr) = Nullch;
6809 AvALLOC((AV*)dstr) = (SV**)NULL;
6813 SvANY(dstr) = new_XPVHV();
6814 SvCUR(dstr) = SvCUR(sstr);
6815 SvLEN(dstr) = SvLEN(sstr);
6816 SvIVX(dstr) = SvIVX(sstr);
6817 SvNVX(dstr) = SvNVX(sstr);
6818 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6819 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6820 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6821 if (HvARRAY((HV*)sstr)) {
6824 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6825 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6826 Newz(0, dxhv->xhv_array,
6827 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6828 while (i <= sxhv->xhv_max) {
6829 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6830 !!HvSHAREKEYS(sstr));
6833 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6836 SvPVX(dstr) = Nullch;
6837 HvEITER((HV*)dstr) = (HE*)NULL;
6839 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6840 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6843 SvANY(dstr) = new_XPVFM();
6844 FmLINES(dstr) = FmLINES(sstr);
6848 SvANY(dstr) = new_XPVCV();
6850 SvCUR(dstr) = SvCUR(sstr);
6851 SvLEN(dstr) = SvLEN(sstr);
6852 SvIVX(dstr) = SvIVX(sstr);
6853 SvNVX(dstr) = SvNVX(sstr);
6854 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6855 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6856 if (SvPVX(sstr) && SvLEN(sstr))
6857 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6859 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6860 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6861 CvSTART(dstr) = CvSTART(sstr);
6862 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6863 CvXSUB(dstr) = CvXSUB(sstr);
6864 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6865 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6866 CvDEPTH(dstr) = CvDEPTH(sstr);
6867 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6868 /* XXX padlists are real, but pretend to be not */
6869 AvREAL_on(CvPADLIST(sstr));
6870 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6871 AvREAL_off(CvPADLIST(sstr));
6872 AvREAL_off(CvPADLIST(dstr));
6875 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6876 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6877 CvFLAGS(dstr) = CvFLAGS(sstr);
6880 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6884 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6891 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6896 return (PERL_CONTEXT*)NULL;
6898 /* look for it in the table first */
6899 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6903 /* create anew and remember what it is */
6904 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6905 ptr_table_store(PL_ptr_table, cxs, ncxs);
6908 PERL_CONTEXT *cx = &cxs[ix];
6909 PERL_CONTEXT *ncx = &ncxs[ix];
6910 ncx->cx_type = cx->cx_type;
6911 if (CxTYPE(cx) == CXt_SUBST) {
6912 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6915 ncx->blk_oldsp = cx->blk_oldsp;
6916 ncx->blk_oldcop = cx->blk_oldcop;
6917 ncx->blk_oldretsp = cx->blk_oldretsp;
6918 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6919 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6920 ncx->blk_oldpm = cx->blk_oldpm;
6921 ncx->blk_gimme = cx->blk_gimme;
6922 switch (CxTYPE(cx)) {
6924 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6925 ? cv_dup_inc(cx->blk_sub.cv)
6926 : cv_dup(cx->blk_sub.cv));
6927 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6928 ? av_dup_inc(cx->blk_sub.argarray)
6930 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6931 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6932 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6933 ncx->blk_sub.lval = cx->blk_sub.lval;
6936 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6937 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6938 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6939 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6940 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6943 ncx->blk_loop.label = cx->blk_loop.label;
6944 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6945 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6946 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6947 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6948 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6949 ? cx->blk_loop.iterdata
6950 : gv_dup((GV*)cx->blk_loop.iterdata));
6951 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6952 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6953 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6954 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6955 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6958 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6959 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6960 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6961 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6974 Perl_si_dup(pTHX_ PERL_SI *si)
6979 return (PERL_SI*)NULL;
6981 /* look for it in the table first */
6982 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6986 /* create anew and remember what it is */
6987 Newz(56, nsi, 1, PERL_SI);
6988 ptr_table_store(PL_ptr_table, si, nsi);
6990 nsi->si_stack = av_dup_inc(si->si_stack);
6991 nsi->si_cxix = si->si_cxix;
6992 nsi->si_cxmax = si->si_cxmax;
6993 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6994 nsi->si_type = si->si_type;
6995 nsi->si_prev = si_dup(si->si_prev);
6996 nsi->si_next = si_dup(si->si_next);
6997 nsi->si_markoff = si->si_markoff;
7002 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7003 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7004 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7005 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7006 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7007 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7008 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7009 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7010 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7011 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7012 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7013 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7016 #define pv_dup_inc(p) SAVEPV(p)
7017 #define pv_dup(p) SAVEPV(p)
7018 #define svp_dup_inc(p,pp) any_dup(p,pp)
7021 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7028 /* look for it in the table first */
7029 ret = ptr_table_fetch(PL_ptr_table, v);
7033 /* see if it is part of the interpreter structure */
7034 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7035 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7043 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7045 ANY *ss = proto_perl->Tsavestack;
7046 I32 ix = proto_perl->Tsavestack_ix;
7047 I32 max = proto_perl->Tsavestack_max;
7060 void (*dptr) (void*);
7061 void (*dxptr) (pTHXo_ void*);
7063 Newz(54, nss, max, ANY);
7069 case SAVEt_ITEM: /* normal string */
7070 sv = (SV*)POPPTR(ss,ix);
7071 TOPPTR(nss,ix) = sv_dup_inc(sv);
7072 sv = (SV*)POPPTR(ss,ix);
7073 TOPPTR(nss,ix) = sv_dup_inc(sv);
7075 case SAVEt_SV: /* scalar reference */
7076 sv = (SV*)POPPTR(ss,ix);
7077 TOPPTR(nss,ix) = sv_dup_inc(sv);
7078 gv = (GV*)POPPTR(ss,ix);
7079 TOPPTR(nss,ix) = gv_dup_inc(gv);
7081 case SAVEt_GENERIC_SVREF: /* generic sv */
7082 case SAVEt_SVREF: /* scalar reference */
7083 sv = (SV*)POPPTR(ss,ix);
7084 TOPPTR(nss,ix) = sv_dup_inc(sv);
7085 ptr = POPPTR(ss,ix);
7086 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7088 case SAVEt_AV: /* array reference */
7089 av = (AV*)POPPTR(ss,ix);
7090 TOPPTR(nss,ix) = av_dup_inc(av);
7091 gv = (GV*)POPPTR(ss,ix);
7092 TOPPTR(nss,ix) = gv_dup(gv);
7094 case SAVEt_HV: /* hash reference */
7095 hv = (HV*)POPPTR(ss,ix);
7096 TOPPTR(nss,ix) = hv_dup_inc(hv);
7097 gv = (GV*)POPPTR(ss,ix);
7098 TOPPTR(nss,ix) = gv_dup(gv);
7100 case SAVEt_INT: /* int reference */
7101 ptr = POPPTR(ss,ix);
7102 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7103 intval = (int)POPINT(ss,ix);
7104 TOPINT(nss,ix) = intval;
7106 case SAVEt_LONG: /* long reference */
7107 ptr = POPPTR(ss,ix);
7108 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7109 longval = (long)POPLONG(ss,ix);
7110 TOPLONG(nss,ix) = longval;
7112 case SAVEt_I32: /* I32 reference */
7113 case SAVEt_I16: /* I16 reference */
7114 case SAVEt_I8: /* I8 reference */
7115 ptr = POPPTR(ss,ix);
7116 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7120 case SAVEt_IV: /* IV reference */
7121 ptr = POPPTR(ss,ix);
7122 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7126 case SAVEt_SPTR: /* SV* reference */
7127 ptr = POPPTR(ss,ix);
7128 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7129 sv = (SV*)POPPTR(ss,ix);
7130 TOPPTR(nss,ix) = sv_dup(sv);
7132 case SAVEt_VPTR: /* random* reference */
7133 ptr = POPPTR(ss,ix);
7134 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7135 ptr = POPPTR(ss,ix);
7136 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7138 case SAVEt_PPTR: /* char* reference */
7139 ptr = POPPTR(ss,ix);
7140 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7141 c = (char*)POPPTR(ss,ix);
7142 TOPPTR(nss,ix) = pv_dup(c);
7144 case SAVEt_HPTR: /* HV* reference */
7145 ptr = POPPTR(ss,ix);
7146 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7147 hv = (HV*)POPPTR(ss,ix);
7148 TOPPTR(nss,ix) = hv_dup(hv);
7150 case SAVEt_APTR: /* AV* reference */
7151 ptr = POPPTR(ss,ix);
7152 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7153 av = (AV*)POPPTR(ss,ix);
7154 TOPPTR(nss,ix) = av_dup(av);
7157 gv = (GV*)POPPTR(ss,ix);
7158 TOPPTR(nss,ix) = gv_dup(gv);
7160 case SAVEt_GP: /* scalar reference */
7161 gp = (GP*)POPPTR(ss,ix);
7162 TOPPTR(nss,ix) = gp = gp_dup(gp);
7163 (void)GpREFCNT_inc(gp);
7164 gv = (GV*)POPPTR(ss,ix);
7165 TOPPTR(nss,ix) = gv_dup_inc(c);
7166 c = (char*)POPPTR(ss,ix);
7167 TOPPTR(nss,ix) = pv_dup(c);
7174 sv = (SV*)POPPTR(ss,ix);
7175 TOPPTR(nss,ix) = sv_dup_inc(sv);
7178 ptr = POPPTR(ss,ix);
7179 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7180 /* these are assumed to be refcounted properly */
7181 switch (((OP*)ptr)->op_type) {
7188 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7191 TOPPTR(nss,ix) = Nullop;
7196 TOPPTR(nss,ix) = Nullop;
7199 c = (char*)POPPTR(ss,ix);
7200 TOPPTR(nss,ix) = pv_dup_inc(c);
7203 longval = POPLONG(ss,ix);
7204 TOPLONG(nss,ix) = longval;
7207 hv = (HV*)POPPTR(ss,ix);
7208 TOPPTR(nss,ix) = hv_dup_inc(hv);
7209 c = (char*)POPPTR(ss,ix);
7210 TOPPTR(nss,ix) = pv_dup_inc(c);
7214 case SAVEt_DESTRUCTOR:
7215 ptr = POPPTR(ss,ix);
7216 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7217 dptr = POPDPTR(ss,ix);
7218 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7220 case SAVEt_DESTRUCTOR_X:
7221 ptr = POPPTR(ss,ix);
7222 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7223 dxptr = POPDXPTR(ss,ix);
7224 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7226 case SAVEt_REGCONTEXT:
7232 case SAVEt_STACK_POS: /* Position on Perl stack */
7236 case SAVEt_AELEM: /* array element */
7237 sv = (SV*)POPPTR(ss,ix);
7238 TOPPTR(nss,ix) = sv_dup_inc(sv);
7241 av = (AV*)POPPTR(ss,ix);
7242 TOPPTR(nss,ix) = av_dup_inc(av);
7244 case SAVEt_HELEM: /* hash element */
7245 sv = (SV*)POPPTR(ss,ix);
7246 TOPPTR(nss,ix) = sv_dup_inc(sv);
7247 sv = (SV*)POPPTR(ss,ix);
7248 TOPPTR(nss,ix) = sv_dup_inc(sv);
7249 hv = (HV*)POPPTR(ss,ix);
7250 TOPPTR(nss,ix) = hv_dup_inc(hv);
7253 ptr = POPPTR(ss,ix);
7254 TOPPTR(nss,ix) = ptr;
7261 av = (AV*)POPPTR(ss,ix);
7262 TOPPTR(nss,ix) = av_dup(av);
7265 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7277 perl_clone(PerlInterpreter *proto_perl, UV flags)
7280 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7283 #ifdef PERL_IMPLICIT_SYS
7284 return perl_clone_using(proto_perl, flags,
7286 proto_perl->IMemShared,
7287 proto_perl->IMemParse,
7297 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7298 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7299 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7300 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7301 struct IPerlDir* ipD, struct IPerlSock* ipS,
7302 struct IPerlProc* ipP)
7304 /* XXX many of the string copies here can be optimized if they're
7305 * constants; they need to be allocated as common memory and just
7306 * their pointers copied. */
7312 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7314 PERL_SET_INTERP(pPerl);
7315 # else /* !PERL_OBJECT */
7316 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7317 PERL_SET_INTERP(my_perl);
7320 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7325 # else /* !DEBUGGING */
7326 Zero(my_perl, 1, PerlInterpreter);
7327 # endif /* DEBUGGING */
7331 PL_MemShared = ipMS;
7339 # endif /* PERL_OBJECT */
7340 #else /* !PERL_IMPLICIT_SYS */
7344 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7345 PERL_SET_INTERP(my_perl);
7348 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7353 # else /* !DEBUGGING */
7354 Zero(my_perl, 1, PerlInterpreter);
7355 # endif /* DEBUGGING */
7356 #endif /* PERL_IMPLICIT_SYS */
7359 PL_xiv_arenaroot = NULL;
7364 PL_xpviv_root = NULL;
7365 PL_xpvnv_root = NULL;
7366 PL_xpvcv_root = NULL;
7367 PL_xpvav_root = NULL;
7368 PL_xpvhv_root = NULL;
7369 PL_xpvmg_root = NULL;
7370 PL_xpvlv_root = NULL;
7371 PL_xpvbm_root = NULL;
7373 PL_nice_chunk = NULL;
7374 PL_nice_chunk_size = 0;
7377 PL_sv_root = Nullsv;
7378 PL_sv_arenaroot = Nullsv;
7380 PL_debug = proto_perl->Idebug;
7382 /* create SV map for pointer relocation */
7383 PL_ptr_table = ptr_table_new();
7385 /* initialize these special pointers as early as possible */
7386 SvANY(&PL_sv_undef) = NULL;
7387 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7388 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7389 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7392 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7394 SvANY(&PL_sv_no) = new_XPVNV();
7396 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7397 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7398 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7399 SvCUR(&PL_sv_no) = 0;
7400 SvLEN(&PL_sv_no) = 1;
7401 SvNVX(&PL_sv_no) = 0;
7402 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7405 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7407 SvANY(&PL_sv_yes) = new_XPVNV();
7409 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7410 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7411 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7412 SvCUR(&PL_sv_yes) = 1;
7413 SvLEN(&PL_sv_yes) = 2;
7414 SvNVX(&PL_sv_yes) = 1;
7415 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7417 /* create shared string table */
7418 PL_strtab = newHV();
7419 HvSHAREKEYS_off(PL_strtab);
7420 hv_ksplit(PL_strtab, 512);
7421 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7423 PL_compiling = proto_perl->Icompiling;
7424 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7425 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7426 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7427 if (!specialWARN(PL_compiling.cop_warnings))
7428 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7429 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7431 /* pseudo environmental stuff */
7432 PL_origargc = proto_perl->Iorigargc;
7434 New(0, PL_origargv, i+1, char*);
7435 PL_origargv[i] = '\0';
7437 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7439 PL_envgv = gv_dup(proto_perl->Ienvgv);
7440 PL_incgv = gv_dup(proto_perl->Iincgv);
7441 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7442 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7443 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7444 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7447 PL_minus_c = proto_perl->Iminus_c;
7448 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7449 PL_localpatches = proto_perl->Ilocalpatches;
7450 PL_splitstr = proto_perl->Isplitstr;
7451 PL_preprocess = proto_perl->Ipreprocess;
7452 PL_minus_n = proto_perl->Iminus_n;
7453 PL_minus_p = proto_perl->Iminus_p;
7454 PL_minus_l = proto_perl->Iminus_l;
7455 PL_minus_a = proto_perl->Iminus_a;
7456 PL_minus_F = proto_perl->Iminus_F;
7457 PL_doswitches = proto_perl->Idoswitches;
7458 PL_dowarn = proto_perl->Idowarn;
7459 PL_doextract = proto_perl->Idoextract;
7460 PL_sawampersand = proto_perl->Isawampersand;
7461 PL_unsafe = proto_perl->Iunsafe;
7462 PL_inplace = SAVEPV(proto_perl->Iinplace);
7463 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7464 PL_perldb = proto_perl->Iperldb;
7465 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7467 /* magical thingies */
7468 /* XXX time(&PL_basetime) when asked for? */
7469 PL_basetime = proto_perl->Ibasetime;
7470 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7472 PL_maxsysfd = proto_perl->Imaxsysfd;
7473 PL_multiline = proto_perl->Imultiline;
7474 PL_statusvalue = proto_perl->Istatusvalue;
7476 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7479 /* shortcuts to various I/O objects */
7480 PL_stdingv = gv_dup(proto_perl->Istdingv);
7481 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7482 PL_defgv = gv_dup(proto_perl->Idefgv);
7483 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7484 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7485 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7487 /* shortcuts to regexp stuff */
7488 PL_replgv = gv_dup(proto_perl->Ireplgv);
7490 /* shortcuts to misc objects */
7491 PL_errgv = gv_dup(proto_perl->Ierrgv);
7493 /* shortcuts to debugging objects */
7494 PL_DBgv = gv_dup(proto_perl->IDBgv);
7495 PL_DBline = gv_dup(proto_perl->IDBline);
7496 PL_DBsub = gv_dup(proto_perl->IDBsub);
7497 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7498 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7499 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7500 PL_lineary = av_dup(proto_perl->Ilineary);
7501 PL_dbargs = av_dup(proto_perl->Idbargs);
7504 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7505 PL_curstash = hv_dup(proto_perl->Tcurstash);
7506 PL_debstash = hv_dup(proto_perl->Idebstash);
7507 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7508 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7510 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7511 PL_endav = av_dup_inc(proto_perl->Iendav);
7512 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7513 PL_initav = av_dup_inc(proto_perl->Iinitav);
7515 PL_sub_generation = proto_perl->Isub_generation;
7517 /* funky return mechanisms */
7518 PL_forkprocess = proto_perl->Iforkprocess;
7520 /* subprocess state */
7521 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7523 /* internal state */
7524 PL_tainting = proto_perl->Itainting;
7525 PL_maxo = proto_perl->Imaxo;
7526 if (proto_perl->Iop_mask)
7527 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7529 PL_op_mask = Nullch;
7531 /* current interpreter roots */
7532 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7533 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7534 PL_main_start = proto_perl->Imain_start;
7535 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
7536 PL_eval_start = proto_perl->Ieval_start;
7538 /* runtime control stuff */
7539 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7540 PL_copline = proto_perl->Icopline;
7542 PL_filemode = proto_perl->Ifilemode;
7543 PL_lastfd = proto_perl->Ilastfd;
7544 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7547 PL_gensym = proto_perl->Igensym;
7548 PL_preambled = proto_perl->Ipreambled;
7549 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7550 PL_laststatval = proto_perl->Ilaststatval;
7551 PL_laststype = proto_perl->Ilaststype;
7552 PL_mess_sv = Nullsv;
7554 PL_orslen = proto_perl->Iorslen;
7555 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7556 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7558 /* interpreter atexit processing */
7559 PL_exitlistlen = proto_perl->Iexitlistlen;
7560 if (PL_exitlistlen) {
7561 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7562 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7565 PL_exitlist = (PerlExitListEntry*)NULL;
7566 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7568 PL_profiledata = NULL;
7569 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7570 /* PL_rsfp_filters entries have fake IoDIRP() */
7571 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7573 PL_compcv = cv_dup(proto_perl->Icompcv);
7574 PL_comppad = av_dup(proto_perl->Icomppad);
7575 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7576 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7577 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7578 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7579 proto_perl->Tcurpad);
7581 #ifdef HAVE_INTERP_INTERN
7582 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7585 /* more statics moved here */
7586 PL_generation = proto_perl->Igeneration;
7587 PL_DBcv = cv_dup(proto_perl->IDBcv);
7589 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7590 PL_in_clean_all = proto_perl->Iin_clean_all;
7592 PL_uid = proto_perl->Iuid;
7593 PL_euid = proto_perl->Ieuid;
7594 PL_gid = proto_perl->Igid;
7595 PL_egid = proto_perl->Iegid;
7596 PL_nomemok = proto_perl->Inomemok;
7597 PL_an = proto_perl->Ian;
7598 PL_cop_seqmax = proto_perl->Icop_seqmax;
7599 PL_op_seqmax = proto_perl->Iop_seqmax;
7600 PL_evalseq = proto_perl->Ievalseq;
7601 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7602 PL_origalen = proto_perl->Iorigalen;
7603 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7604 PL_osname = SAVEPV(proto_perl->Iosname);
7605 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7606 PL_sighandlerp = proto_perl->Isighandlerp;
7609 PL_runops = proto_perl->Irunops;
7611 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7614 PL_cshlen = proto_perl->Icshlen;
7615 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7618 PL_lex_state = proto_perl->Ilex_state;
7619 PL_lex_defer = proto_perl->Ilex_defer;
7620 PL_lex_expect = proto_perl->Ilex_expect;
7621 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7622 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7623 PL_lex_starts = proto_perl->Ilex_starts;
7624 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7625 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7626 PL_lex_op = proto_perl->Ilex_op;
7627 PL_lex_inpat = proto_perl->Ilex_inpat;
7628 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7629 PL_lex_brackets = proto_perl->Ilex_brackets;
7630 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7631 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7632 PL_lex_casemods = proto_perl->Ilex_casemods;
7633 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7634 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7636 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7637 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7638 PL_nexttoke = proto_perl->Inexttoke;
7640 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7641 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7642 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7643 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7644 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7645 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7646 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7647 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7648 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7649 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7650 PL_pending_ident = proto_perl->Ipending_ident;
7651 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7653 PL_expect = proto_perl->Iexpect;
7655 PL_multi_start = proto_perl->Imulti_start;
7656 PL_multi_end = proto_perl->Imulti_end;
7657 PL_multi_open = proto_perl->Imulti_open;
7658 PL_multi_close = proto_perl->Imulti_close;
7660 PL_error_count = proto_perl->Ierror_count;
7661 PL_subline = proto_perl->Isubline;
7662 PL_subname = sv_dup_inc(proto_perl->Isubname);
7664 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7665 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7666 PL_padix = proto_perl->Ipadix;
7667 PL_padix_floor = proto_perl->Ipadix_floor;
7668 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7670 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7671 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7672 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7673 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7674 PL_last_lop_op = proto_perl->Ilast_lop_op;
7675 PL_in_my = proto_perl->Iin_my;
7676 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7678 PL_cryptseen = proto_perl->Icryptseen;
7681 PL_hints = proto_perl->Ihints;
7683 PL_amagic_generation = proto_perl->Iamagic_generation;
7685 #ifdef USE_LOCALE_COLLATE
7686 PL_collation_ix = proto_perl->Icollation_ix;
7687 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7688 PL_collation_standard = proto_perl->Icollation_standard;
7689 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7690 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7691 #endif /* USE_LOCALE_COLLATE */
7693 #ifdef USE_LOCALE_NUMERIC
7694 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7695 PL_numeric_standard = proto_perl->Inumeric_standard;
7696 PL_numeric_local = proto_perl->Inumeric_local;
7697 PL_numeric_radix = proto_perl->Inumeric_radix;
7698 #endif /* !USE_LOCALE_NUMERIC */
7700 /* utf8 character classes */
7701 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7702 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7703 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7704 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7705 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7706 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7707 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7708 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7709 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7710 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7711 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7712 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7713 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7714 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7715 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7716 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7717 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7720 PL_last_swash_hv = Nullhv; /* reinits on demand */
7721 PL_last_swash_klen = 0;
7722 PL_last_swash_key[0]= '\0';
7723 PL_last_swash_tmps = (U8*)NULL;
7724 PL_last_swash_slen = 0;
7726 /* perly.c globals */
7727 PL_yydebug = proto_perl->Iyydebug;
7728 PL_yynerrs = proto_perl->Iyynerrs;
7729 PL_yyerrflag = proto_perl->Iyyerrflag;
7730 PL_yychar = proto_perl->Iyychar;
7731 PL_yyval = proto_perl->Iyyval;
7732 PL_yylval = proto_perl->Iyylval;
7734 PL_glob_index = proto_perl->Iglob_index;
7735 PL_srand_called = proto_perl->Isrand_called;
7736 PL_uudmap['M'] = 0; /* reinits on demand */
7737 PL_bitcount = Nullch; /* reinits on demand */
7739 if (proto_perl->Ipsig_ptr) {
7740 int sig_num[] = { SIG_NUM };
7741 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7742 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7743 for (i = 1; PL_sig_name[i]; i++) {
7744 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7745 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7749 PL_psig_ptr = (SV**)NULL;
7750 PL_psig_name = (SV**)NULL;
7753 /* thrdvar.h stuff */
7756 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7757 PL_tmps_ix = proto_perl->Ttmps_ix;
7758 PL_tmps_max = proto_perl->Ttmps_max;
7759 PL_tmps_floor = proto_perl->Ttmps_floor;
7760 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7762 while (i <= PL_tmps_ix) {
7763 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7767 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7768 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7769 Newz(54, PL_markstack, i, I32);
7770 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7771 - proto_perl->Tmarkstack);
7772 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7773 - proto_perl->Tmarkstack);
7774 Copy(proto_perl->Tmarkstack, PL_markstack,
7775 PL_markstack_ptr - PL_markstack + 1, I32);
7777 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7778 * NOTE: unlike the others! */
7779 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7780 PL_scopestack_max = proto_perl->Tscopestack_max;
7781 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7782 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7784 /* next push_return() sets PL_retstack[PL_retstack_ix]
7785 * NOTE: unlike the others! */
7786 PL_retstack_ix = proto_perl->Tretstack_ix;
7787 PL_retstack_max = proto_perl->Tretstack_max;
7788 Newz(54, PL_retstack, PL_retstack_max, OP*);
7789 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7791 /* NOTE: si_dup() looks at PL_markstack */
7792 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7794 /* PL_curstack = PL_curstackinfo->si_stack; */
7795 PL_curstack = av_dup(proto_perl->Tcurstack);
7796 PL_mainstack = av_dup(proto_perl->Tmainstack);
7798 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7799 PL_stack_base = AvARRAY(PL_curstack);
7800 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7801 - proto_perl->Tstack_base);
7802 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7804 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7805 * NOTE: unlike the others! */
7806 PL_savestack_ix = proto_perl->Tsavestack_ix;
7807 PL_savestack_max = proto_perl->Tsavestack_max;
7808 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7809 PL_savestack = ss_dup(proto_perl);
7815 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7816 PL_top_env = &PL_start_env;
7818 PL_op = proto_perl->Top;
7821 PL_Xpv = (XPV*)NULL;
7822 PL_na = proto_perl->Tna;
7824 PL_statbuf = proto_perl->Tstatbuf;
7825 PL_statcache = proto_perl->Tstatcache;
7826 PL_statgv = gv_dup(proto_perl->Tstatgv);
7827 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7829 PL_timesbuf = proto_perl->Ttimesbuf;
7832 PL_tainted = proto_perl->Ttainted;
7833 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7834 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7835 PL_rs = sv_dup_inc(proto_perl->Trs);
7836 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7837 PL_ofslen = proto_perl->Tofslen;
7838 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7839 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7840 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7841 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7842 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7843 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7845 PL_restartop = proto_perl->Trestartop;
7846 PL_in_eval = proto_perl->Tin_eval;
7847 PL_delaymagic = proto_perl->Tdelaymagic;
7848 PL_dirty = proto_perl->Tdirty;
7849 PL_localizing = proto_perl->Tlocalizing;
7851 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7852 PL_protect = proto_perl->Tprotect;
7854 PL_errors = sv_dup_inc(proto_perl->Terrors);
7855 PL_av_fetch_sv = Nullsv;
7856 PL_hv_fetch_sv = Nullsv;
7857 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7858 PL_modcount = proto_perl->Tmodcount;
7859 PL_lastgotoprobe = Nullop;
7860 PL_dumpindent = proto_perl->Tdumpindent;
7862 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7863 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7864 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7865 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7866 PL_sortcxix = proto_perl->Tsortcxix;
7867 PL_efloatbuf = Nullch; /* reinits on demand */
7868 PL_efloatsize = 0; /* reinits on demand */
7872 PL_screamfirst = NULL;
7873 PL_screamnext = NULL;
7874 PL_maxscream = -1; /* reinits on demand */
7875 PL_lastscream = Nullsv;
7877 PL_watchaddr = NULL;
7878 PL_watchok = Nullch;
7880 PL_regdummy = proto_perl->Tregdummy;
7881 PL_regcomp_parse = Nullch;
7882 PL_regxend = Nullch;
7883 PL_regcode = (regnode*)NULL;
7886 PL_regprecomp = Nullch;
7891 PL_seen_zerolen = 0;
7893 PL_regcomp_rx = (regexp*)NULL;
7895 PL_colorset = 0; /* reinits PL_colors[] */
7896 /*PL_colors[6] = {0,0,0,0,0,0};*/
7897 PL_reg_whilem_seen = 0;
7898 PL_reginput = Nullch;
7901 PL_regstartp = (I32*)NULL;
7902 PL_regendp = (I32*)NULL;
7903 PL_reglastparen = (U32*)NULL;
7904 PL_regtill = Nullch;
7906 PL_reg_start_tmp = (char**)NULL;
7907 PL_reg_start_tmpl = 0;
7908 PL_regdata = (struct reg_data*)NULL;
7911 PL_reg_eval_set = 0;
7913 PL_regprogram = (regnode*)NULL;
7915 PL_regcc = (CURCUR*)NULL;
7916 PL_reg_call_cc = (struct re_cc_state*)NULL;
7917 PL_reg_re = (regexp*)NULL;
7918 PL_reg_ganch = Nullch;
7920 PL_reg_magic = (MAGIC*)NULL;
7922 PL_reg_oldcurpm = (PMOP*)NULL;
7923 PL_reg_curpm = (PMOP*)NULL;
7924 PL_reg_oldsaved = Nullch;
7925 PL_reg_oldsavedlen = 0;
7927 PL_reg_leftiter = 0;
7928 PL_reg_poscache = Nullch;
7929 PL_reg_poscache_size= 0;
7931 /* RE engine - function pointers */
7932 PL_regcompp = proto_perl->Tregcompp;
7933 PL_regexecp = proto_perl->Tregexecp;
7934 PL_regint_start = proto_perl->Tregint_start;
7935 PL_regint_string = proto_perl->Tregint_string;
7936 PL_regfree = proto_perl->Tregfree;
7938 PL_reginterp_cnt = 0;
7939 PL_reg_starttry = 0;
7942 return (PerlInterpreter*)pPerl;
7948 #else /* !USE_ITHREADS */
7954 #endif /* USE_ITHREADS */
7957 do_report_used(pTHXo_ SV *sv)
7959 if (SvTYPE(sv) != SVTYPEMASK) {
7960 PerlIO_printf(Perl_debug_log, "****\n");
7966 do_clean_objs(pTHXo_ SV *sv)
7970 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7971 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7977 /* XXX Might want to check arrays, etc. */
7980 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7982 do_clean_named_objs(pTHXo_ SV *sv)
7984 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7985 if ( SvOBJECT(GvSV(sv)) ||
7986 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7987 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7988 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7989 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7991 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7999 do_clean_all(pTHXo_ SV *sv)
8001 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8002 SvFLAGS(sv) |= SVf_BREAK;