3 * Copyright (c) 1991-1999, 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);
34 (p) = (SV*)safemalloc(sizeof(SV)); \
46 Safefree((char*)(p)); \
51 static I32 registry_size;
53 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
55 #define REG_REPLACE(sv,a,b) \
57 void* p = sv->sv_any; \
58 I32 h = REGHASH(sv, registry_size); \
60 while (registry[i] != (a)) { \
61 if (++i >= registry_size) \
64 Perl_die(aTHX_ "SV registry bug"); \
69 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
70 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
73 S_reg_add(pTHX_ SV *sv)
75 if (PL_sv_count >= (registry_size >> 1))
77 SV **oldreg = registry;
78 I32 oldsize = registry_size;
80 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
81 Newz(707, registry, registry_size, SV*);
86 for (i = 0; i < oldsize; ++i) {
87 SV* oldsv = oldreg[i];
100 S_reg_remove(pTHX_ SV *sv)
107 S_visit(pTHX_ SVFUNC_t f)
111 for (i = 0; i < registry_size; ++i) {
112 SV* sv = registry[i];
113 if (sv && SvTYPE(sv) != SVTYPEMASK)
119 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
121 if (!(flags & SVf_FAKE))
128 * "A time to plant, and a time to uproot what was planted..."
131 #define plant_SV(p) \
133 SvANY(p) = (void *)PL_sv_root; \
134 SvFLAGS(p) = SVTYPEMASK; \
139 /* sv_mutex must be held while calling uproot_SV() */
140 #define uproot_SV(p) \
143 PL_sv_root = (SV*)SvANY(p); \
165 if (PL_debug & 32768) \
173 S_del_sv(pTHX_ SV *p)
175 if (PL_debug & 32768) {
180 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
182 svend = &sva[SvREFCNT(sva)];
183 if (p >= sv && p < svend)
187 if (ckWARN_d(WARN_INTERNAL))
188 Perl_warner(aTHX_ WARN_INTERNAL,
189 "Attempt to free non-arena SV: 0x%"UVxf,
197 #else /* ! DEBUGGING */
199 #define del_SV(p) plant_SV(p)
201 #endif /* DEBUGGING */
204 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
209 Zero(sva, size, char);
211 /* The first SV in an arena isn't an SV. */
212 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
213 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
214 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
216 PL_sv_arenaroot = sva;
217 PL_sv_root = sva + 1;
219 svend = &sva[SvREFCNT(sva) - 1];
222 SvANY(sv) = (void *)(SV*)(sv + 1);
223 SvFLAGS(sv) = SVTYPEMASK;
227 SvFLAGS(sv) = SVTYPEMASK;
230 /* sv_mutex must be held while calling more_sv() */
237 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
238 PL_nice_chunk = Nullch;
241 char *chunk; /* must use New here to match call to */
242 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
243 sv_add_arena(chunk, 1008, 0);
250 S_visit(pTHX_ SVFUNC_t f)
256 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
257 svend = &sva[SvREFCNT(sva)];
258 for (sv = sva + 1; sv < svend; ++sv) {
259 if (SvTYPE(sv) != SVTYPEMASK)
268 Perl_sv_report_used(pTHX)
270 visit(do_report_used);
274 Perl_sv_clean_objs(pTHX)
276 PL_in_clean_objs = TRUE;
277 visit(do_clean_objs);
278 #ifndef DISABLE_DESTRUCTOR_KLUDGE
279 /* some barnacles may yet remain, clinging to typeglobs */
280 visit(do_clean_named_objs);
282 PL_in_clean_objs = FALSE;
286 Perl_sv_clean_all(pTHX)
288 PL_in_clean_all = TRUE;
290 PL_in_clean_all = FALSE;
294 Perl_sv_free_arenas(pTHX)
299 /* Free arenas here, but be careful about fake ones. (We assume
300 contiguity of the fake ones with the corresponding real ones.) */
302 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
303 svanext = (SV*) SvANY(sva);
304 while (svanext && SvFAKE(svanext))
305 svanext = (SV*) SvANY(svanext);
308 Safefree((void *)sva);
312 Safefree(PL_nice_chunk);
313 PL_nice_chunk = Nullch;
314 PL_nice_chunk_size = 0;
328 * See comment in more_xiv() -- RAM.
330 PL_xiv_root = *(IV**)xiv;
332 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
336 S_del_xiv(pTHX_ XPVIV *p)
338 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
340 *(IV**)xiv = PL_xiv_root;
351 New(705, ptr, 1008/sizeof(XPV), XPV);
352 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
353 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
356 xivend = &xiv[1008 / sizeof(IV) - 1];
357 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
359 while (xiv < xivend) {
360 *(IV**)xiv = (IV *)(xiv + 1);
374 PL_xnv_root = *(NV**)xnv;
376 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
380 S_del_xnv(pTHX_ XPVNV *p)
382 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
384 *(NV**)xnv = PL_xnv_root;
394 New(711, xnv, 1008/sizeof(NV), NV);
395 xnvend = &xnv[1008 / sizeof(NV) - 1];
396 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
398 while (xnv < xnvend) {
399 *(NV**)xnv = (NV*)(xnv + 1);
413 PL_xrv_root = (XRV*)xrv->xrv_rv;
419 S_del_xrv(pTHX_ XRV *p)
422 p->xrv_rv = (SV*)PL_xrv_root;
431 register XRV* xrvend;
432 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
434 xrvend = &xrv[1008 / sizeof(XRV) - 1];
435 while (xrv < xrvend) {
436 xrv->xrv_rv = (SV*)(xrv + 1);
450 PL_xpv_root = (XPV*)xpv->xpv_pv;
456 S_del_xpv(pTHX_ XPV *p)
459 p->xpv_pv = (char*)PL_xpv_root;
468 register XPV* xpvend;
469 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
471 xpvend = &xpv[1008 / sizeof(XPV) - 1];
472 while (xpv < xpvend) {
473 xpv->xpv_pv = (char*)(xpv + 1);
486 xpviv = PL_xpviv_root;
487 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
493 S_del_xpviv(pTHX_ XPVIV *p)
496 p->xpv_pv = (char*)PL_xpviv_root;
505 register XPVIV* xpviv;
506 register XPVIV* xpvivend;
507 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
508 xpviv = PL_xpviv_root;
509 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
510 while (xpviv < xpvivend) {
511 xpviv->xpv_pv = (char*)(xpviv + 1);
525 xpvnv = PL_xpvnv_root;
526 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
532 S_del_xpvnv(pTHX_ XPVNV *p)
535 p->xpv_pv = (char*)PL_xpvnv_root;
544 register XPVNV* xpvnv;
545 register XPVNV* xpvnvend;
546 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
547 xpvnv = PL_xpvnv_root;
548 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
549 while (xpvnv < xpvnvend) {
550 xpvnv->xpv_pv = (char*)(xpvnv + 1);
565 xpvcv = PL_xpvcv_root;
566 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
572 S_del_xpvcv(pTHX_ XPVCV *p)
575 p->xpv_pv = (char*)PL_xpvcv_root;
584 register XPVCV* xpvcv;
585 register XPVCV* xpvcvend;
586 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
587 xpvcv = PL_xpvcv_root;
588 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
589 while (xpvcv < xpvcvend) {
590 xpvcv->xpv_pv = (char*)(xpvcv + 1);
605 xpvav = PL_xpvav_root;
606 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
612 S_del_xpvav(pTHX_ XPVAV *p)
615 p->xav_array = (char*)PL_xpvav_root;
624 register XPVAV* xpvav;
625 register XPVAV* xpvavend;
626 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
627 xpvav = PL_xpvav_root;
628 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
629 while (xpvav < xpvavend) {
630 xpvav->xav_array = (char*)(xpvav + 1);
633 xpvav->xav_array = 0;
645 xpvhv = PL_xpvhv_root;
646 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
652 S_del_xpvhv(pTHX_ XPVHV *p)
655 p->xhv_array = (char*)PL_xpvhv_root;
664 register XPVHV* xpvhv;
665 register XPVHV* xpvhvend;
666 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
667 xpvhv = PL_xpvhv_root;
668 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
669 while (xpvhv < xpvhvend) {
670 xpvhv->xhv_array = (char*)(xpvhv + 1);
673 xpvhv->xhv_array = 0;
684 xpvmg = PL_xpvmg_root;
685 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
691 S_del_xpvmg(pTHX_ XPVMG *p)
694 p->xpv_pv = (char*)PL_xpvmg_root;
703 register XPVMG* xpvmg;
704 register XPVMG* xpvmgend;
705 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
706 xpvmg = PL_xpvmg_root;
707 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
708 while (xpvmg < xpvmgend) {
709 xpvmg->xpv_pv = (char*)(xpvmg + 1);
724 xpvlv = PL_xpvlv_root;
725 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
731 S_del_xpvlv(pTHX_ XPVLV *p)
734 p->xpv_pv = (char*)PL_xpvlv_root;
743 register XPVLV* xpvlv;
744 register XPVLV* xpvlvend;
745 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
746 xpvlv = PL_xpvlv_root;
747 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
748 while (xpvlv < xpvlvend) {
749 xpvlv->xpv_pv = (char*)(xpvlv + 1);
763 xpvbm = PL_xpvbm_root;
764 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
770 S_del_xpvbm(pTHX_ XPVBM *p)
773 p->xpv_pv = (char*)PL_xpvbm_root;
782 register XPVBM* xpvbm;
783 register XPVBM* xpvbmend;
784 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
785 xpvbm = PL_xpvbm_root;
786 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
787 while (xpvbm < xpvbmend) {
788 xpvbm->xpv_pv = (char*)(xpvbm + 1);
795 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
796 #define del_XIV(p) Safefree((char*)p)
798 #define new_XIV() (void*)new_xiv()
799 #define del_XIV(p) del_xiv((XPVIV*) p)
803 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
804 #define del_XNV(p) Safefree((char*)p)
806 #define new_XNV() (void*)new_xnv()
807 #define del_XNV(p) del_xnv((XPVNV*) p)
811 #define new_XRV() (void*)safemalloc(sizeof(XRV))
812 #define del_XRV(p) Safefree((char*)p)
814 #define new_XRV() (void*)new_xrv()
815 #define del_XRV(p) del_xrv((XRV*) p)
819 #define new_XPV() (void*)safemalloc(sizeof(XPV))
820 #define del_XPV(p) Safefree((char*)p)
822 #define new_XPV() (void*)new_xpv()
823 #define del_XPV(p) del_xpv((XPV *)p)
827 # define my_safemalloc(s) safemalloc(s)
828 # define my_safefree(s) safefree(s)
831 S_my_safemalloc(MEM_SIZE size)
834 New(717, p, size, char);
837 # define my_safefree(s) Safefree(s)
841 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
842 #define del_XPVIV(p) Safefree((char*)p)
844 #define new_XPVIV() (void*)new_xpviv()
845 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
849 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
850 #define del_XPVNV(p) Safefree((char*)p)
852 #define new_XPVNV() (void*)new_xpvnv()
853 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
858 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
859 #define del_XPVCV(p) Safefree((char*)p)
861 #define new_XPVCV() (void*)new_xpvcv()
862 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
866 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
867 #define del_XPVAV(p) Safefree((char*)p)
869 #define new_XPVAV() (void*)new_xpvav()
870 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
874 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
875 #define del_XPVHV(p) Safefree((char*)p)
877 #define new_XPVHV() (void*)new_xpvhv()
878 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
882 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
883 #define del_XPVMG(p) Safefree((char*)p)
885 #define new_XPVMG() (void*)new_xpvmg()
886 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
890 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
891 #define del_XPVLV(p) Safefree((char*)p)
893 #define new_XPVLV() (void*)new_xpvlv()
894 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
897 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
898 #define del_XPVGV(p) my_safefree((char*)p)
901 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
902 #define del_XPVBM(p) Safefree((char*)p)
904 #define new_XPVBM() (void*)new_xpvbm()
905 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
908 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
909 #define del_XPVFM(p) my_safefree((char*)p)
911 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
912 #define del_XPVIO(p) my_safefree((char*)p)
915 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
925 if (SvTYPE(sv) == mt)
931 switch (SvTYPE(sv)) {
952 else if (mt < SVt_PVIV)
969 pv = (char*)SvRV(sv);
989 else if (mt == SVt_NV)
1000 del_XPVIV(SvANY(sv));
1010 del_XPVNV(SvANY(sv));
1018 magic = SvMAGIC(sv);
1019 stash = SvSTASH(sv);
1020 del_XPVMG(SvANY(sv));
1023 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1028 Perl_croak(aTHX_ "Can't upgrade to undef");
1030 SvANY(sv) = new_XIV();
1034 SvANY(sv) = new_XNV();
1038 SvANY(sv) = new_XRV();
1042 SvANY(sv) = new_XPV();
1048 SvANY(sv) = new_XPVIV();
1058 SvANY(sv) = new_XPVNV();
1066 SvANY(sv) = new_XPVMG();
1072 SvMAGIC(sv) = magic;
1073 SvSTASH(sv) = stash;
1076 SvANY(sv) = new_XPVLV();
1082 SvMAGIC(sv) = magic;
1083 SvSTASH(sv) = stash;
1090 SvANY(sv) = new_XPVAV();
1098 SvMAGIC(sv) = magic;
1099 SvSTASH(sv) = stash;
1105 SvANY(sv) = new_XPVHV();
1113 SvMAGIC(sv) = magic;
1114 SvSTASH(sv) = stash;
1121 SvANY(sv) = new_XPVCV();
1122 Zero(SvANY(sv), 1, XPVCV);
1128 SvMAGIC(sv) = magic;
1129 SvSTASH(sv) = stash;
1132 SvANY(sv) = new_XPVGV();
1138 SvMAGIC(sv) = magic;
1139 SvSTASH(sv) = stash;
1147 SvANY(sv) = new_XPVBM();
1153 SvMAGIC(sv) = magic;
1154 SvSTASH(sv) = stash;
1160 SvANY(sv) = new_XPVFM();
1161 Zero(SvANY(sv), 1, XPVFM);
1167 SvMAGIC(sv) = magic;
1168 SvSTASH(sv) = stash;
1171 SvANY(sv) = new_XPVIO();
1172 Zero(SvANY(sv), 1, XPVIO);
1178 SvMAGIC(sv) = magic;
1179 SvSTASH(sv) = stash;
1180 IoPAGE_LEN(sv) = 60;
1183 SvFLAGS(sv) &= ~SVTYPEMASK;
1189 Perl_sv_backoff(pTHX_ register SV *sv)
1193 char *s = SvPVX(sv);
1194 SvLEN(sv) += SvIVX(sv);
1195 SvPVX(sv) -= SvIVX(sv);
1197 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1199 SvFLAGS(sv) &= ~SVf_OOK;
1204 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1208 #ifdef HAS_64K_LIMIT
1209 if (newlen >= 0x10000) {
1210 PerlIO_printf(Perl_debug_log,
1211 "Allocation too large: %"UVxf"\n", (UV)newlen);
1214 #endif /* HAS_64K_LIMIT */
1217 if (SvTYPE(sv) < SVt_PV) {
1218 sv_upgrade(sv, SVt_PV);
1221 else if (SvOOK(sv)) { /* pv is offset? */
1224 if (newlen > SvLEN(sv))
1225 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1226 #ifdef HAS_64K_LIMIT
1227 if (newlen >= 0x10000)
1233 if (newlen > SvLEN(sv)) { /* need more room? */
1234 if (SvLEN(sv) && s) {
1235 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1236 STRLEN l = malloced_size((void*)SvPVX(sv));
1242 Renew(s,newlen,char);
1245 New(703,s,newlen,char);
1247 SvLEN_set(sv, newlen);
1253 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1255 SV_CHECK_THINKFIRST(sv);
1256 switch (SvTYPE(sv)) {
1258 sv_upgrade(sv, SVt_IV);
1261 sv_upgrade(sv, SVt_PVNV);
1265 sv_upgrade(sv, SVt_PVIV);
1276 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1277 PL_op_desc[PL_op->op_type]);
1280 (void)SvIOK_only(sv); /* validate number */
1286 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1293 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1301 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1308 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1310 SV_CHECK_THINKFIRST(sv);
1311 switch (SvTYPE(sv)) {
1314 sv_upgrade(sv, SVt_NV);
1319 sv_upgrade(sv, SVt_PVNV);
1330 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1331 PL_op_name[PL_op->op_type]);
1335 (void)SvNOK_only(sv); /* validate number */
1340 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1347 S_not_a_number(pTHX_ SV *sv)
1353 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1354 /* each *s can expand to 4 chars + "...\0",
1355 i.e. need room for 8 chars */
1357 for (s = SvPVX(sv); *s && d < limit; s++) {
1359 if (ch & 128 && !isPRINT_LC(ch)) {
1368 else if (ch == '\r') {
1372 else if (ch == '\f') {
1376 else if (ch == '\\') {
1380 else if (isPRINT_LC(ch))
1395 Perl_warner(aTHX_ WARN_NUMERIC,
1396 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1397 PL_op_desc[PL_op->op_type]);
1399 Perl_warner(aTHX_ WARN_NUMERIC,
1400 "Argument \"%s\" isn't numeric", tmpbuf);
1403 /* the number can be converted to integer with atol() or atoll() */
1404 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1405 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1406 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1407 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1409 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1410 until proven guilty, assume that things are not that bad... */
1413 Perl_sv_2iv(pTHX_ register SV *sv)
1417 if (SvGMAGICAL(sv)) {
1422 return I_V(SvNVX(sv));
1424 if (SvPOKp(sv) && SvLEN(sv))
1427 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1429 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1430 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1435 if (SvTHINKFIRST(sv)) {
1438 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1439 return SvIV(tmpstr);
1440 return PTR2IV(SvRV(sv));
1442 if (SvREADONLY(sv) && !SvOK(sv)) {
1444 if (ckWARN(WARN_UNINITIALIZED))
1445 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1451 return (IV)(SvUVX(sv));
1458 /* We can cache the IV/UV value even if it not good enough
1459 * to reconstruct NV, since the conversion to PV will prefer
1463 if (SvTYPE(sv) == SVt_NV)
1464 sv_upgrade(sv, SVt_PVNV);
1467 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1468 SvIVX(sv) = I_V(SvNVX(sv));
1470 SvUVX(sv) = U_V(SvNVX(sv));
1473 DEBUG_c(PerlIO_printf(Perl_debug_log,
1474 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1478 return (IV)SvUVX(sv);
1481 else if (SvPOKp(sv) && SvLEN(sv)) {
1482 I32 numtype = looks_like_number(sv);
1484 /* We want to avoid a possible problem when we cache an IV which
1485 may be later translated to an NV, and the resulting NV is not
1486 the translation of the initial data.
1488 This means that if we cache such an IV, we need to cache the
1489 NV as well. Moreover, we trade speed for space, and do not
1490 cache the NV if not needed.
1492 if (numtype & IS_NUMBER_NOT_IV) {
1493 /* May be not an integer. Need to cache NV if we cache IV
1494 * - otherwise future conversion to NV will be wrong. */
1497 d = Atof(SvPVX(sv));
1499 if (SvTYPE(sv) < SVt_PVNV)
1500 sv_upgrade(sv, SVt_PVNV);
1504 #if defined(USE_LONG_DOUBLE)
1505 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1506 PTR2UV(sv), SvNVX(sv)));
1508 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1509 PTR2UV(sv), SvNVX(sv)));
1511 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1512 SvIVX(sv) = I_V(SvNVX(sv));
1514 SvUVX(sv) = U_V(SvNVX(sv));
1520 /* The NV may be reconstructed from IV - safe to cache IV,
1521 which may be calculated by atol(). */
1522 if (SvTYPE(sv) == SVt_PV)
1523 sv_upgrade(sv, SVt_PVIV);
1525 SvIVX(sv) = Atol(SvPVX(sv));
1527 else { /* Not a number. Cache 0. */
1530 if (SvTYPE(sv) < SVt_PVIV)
1531 sv_upgrade(sv, SVt_PVIV);
1534 if (ckWARN(WARN_NUMERIC))
1540 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1541 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1542 if (SvTYPE(sv) < SVt_IV)
1543 /* Typically the caller expects that sv_any is not NULL now. */
1544 sv_upgrade(sv, SVt_IV);
1547 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1548 PTR2UV(sv),SvIVX(sv)));
1549 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1553 Perl_sv_2uv(pTHX_ register SV *sv)
1557 if (SvGMAGICAL(sv)) {
1562 return U_V(SvNVX(sv));
1563 if (SvPOKp(sv) && SvLEN(sv))
1566 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1568 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1569 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1574 if (SvTHINKFIRST(sv)) {
1577 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1578 return SvUV(tmpstr);
1579 return PTR2UV(SvRV(sv));
1581 if (SvREADONLY(sv) && !SvOK(sv)) {
1583 if (ckWARN(WARN_UNINITIALIZED))
1584 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1593 return (UV)SvIVX(sv);
1597 /* We can cache the IV/UV value even if it not good enough
1598 * to reconstruct NV, since the conversion to PV will prefer
1601 if (SvTYPE(sv) == SVt_NV)
1602 sv_upgrade(sv, SVt_PVNV);
1604 if (SvNVX(sv) >= -0.5) {
1606 SvUVX(sv) = U_V(SvNVX(sv));
1609 SvIVX(sv) = I_V(SvNVX(sv));
1611 DEBUG_c(PerlIO_printf(Perl_debug_log,
1612 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1615 (IV)(UV)SvIVX(sv)));
1616 return (UV)SvIVX(sv);
1619 else if (SvPOKp(sv) && SvLEN(sv)) {
1620 I32 numtype = looks_like_number(sv);
1622 /* We want to avoid a possible problem when we cache a UV which
1623 may be later translated to an NV, and the resulting NV is not
1624 the translation of the initial data.
1626 This means that if we cache such a UV, we need to cache the
1627 NV as well. Moreover, we trade speed for space, and do not
1628 cache the NV if not needed.
1630 if (numtype & IS_NUMBER_NOT_IV) {
1631 /* May be not an integer. Need to cache NV if we cache IV
1632 * - otherwise future conversion to NV will be wrong. */
1635 d = Atof(SvPVX(sv));
1637 if (SvTYPE(sv) < SVt_PVNV)
1638 sv_upgrade(sv, SVt_PVNV);
1642 #if defined(USE_LONG_DOUBLE)
1643 DEBUG_c(PerlIO_printf(Perl_debug_log,
1644 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1645 PTR2UV(sv), SvNVX(sv)));
1647 DEBUG_c(PerlIO_printf(Perl_debug_log,
1648 "0x%"UVxf" 2nv(%g)\n",
1649 PTR2UV(sv), SvNVX(sv)));
1651 if (SvNVX(sv) < -0.5) {
1652 SvIVX(sv) = I_V(SvNVX(sv));
1655 SvUVX(sv) = U_V(SvNVX(sv));
1659 else if (numtype & IS_NUMBER_NEG) {
1660 /* The NV may be reconstructed from IV - safe to cache IV,
1661 which may be calculated by atol(). */
1662 if (SvTYPE(sv) == SVt_PV)
1663 sv_upgrade(sv, SVt_PVIV);
1665 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1667 else if (numtype) { /* Non-negative */
1668 /* The NV may be reconstructed from UV - safe to cache UV,
1669 which may be calculated by strtoul()/atol. */
1670 if (SvTYPE(sv) == SVt_PV)
1671 sv_upgrade(sv, SVt_PVIV);
1673 (void)SvIsUV_on(sv);
1675 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1676 #else /* no atou(), but we know the number fits into IV... */
1677 /* The only problem may be if it is negative... */
1678 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1681 else { /* Not a number. Cache 0. */
1684 if (SvTYPE(sv) < SVt_PVIV)
1685 sv_upgrade(sv, SVt_PVIV);
1686 SvUVX(sv) = 0; /* We assume that 0s have the
1687 same bitmap in IV and UV. */
1689 (void)SvIsUV_on(sv);
1690 if (ckWARN(WARN_NUMERIC))
1695 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1697 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1698 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1700 if (SvTYPE(sv) < SVt_IV)
1701 /* Typically the caller expects that sv_any is not NULL now. */
1702 sv_upgrade(sv, SVt_IV);
1706 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1707 PTR2UV(sv),SvUVX(sv)));
1708 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1712 Perl_sv_2nv(pTHX_ register SV *sv)
1716 if (SvGMAGICAL(sv)) {
1720 if (SvPOKp(sv) && SvLEN(sv)) {
1722 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1724 return Atof(SvPVX(sv));
1728 return (NV)SvUVX(sv);
1730 return (NV)SvIVX(sv);
1733 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1736 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1741 if (SvTHINKFIRST(sv)) {
1744 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1745 return SvNV(tmpstr);
1746 return PTR2NV(SvRV(sv));
1748 if (SvREADONLY(sv) && !SvOK(sv)) {
1750 if (ckWARN(WARN_UNINITIALIZED))
1751 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1755 if (SvTYPE(sv) < SVt_NV) {
1756 if (SvTYPE(sv) == SVt_IV)
1757 sv_upgrade(sv, SVt_PVNV);
1759 sv_upgrade(sv, SVt_NV);
1760 #if defined(USE_LONG_DOUBLE)
1762 RESTORE_NUMERIC_STANDARD();
1763 PerlIO_printf(Perl_debug_log,
1764 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1765 PTR2UV(sv), SvNVX(sv));
1766 RESTORE_NUMERIC_LOCAL();
1770 RESTORE_NUMERIC_STANDARD();
1771 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1772 PTR2UV(sv), SvNVX(sv));
1773 RESTORE_NUMERIC_LOCAL();
1777 else if (SvTYPE(sv) < SVt_PVNV)
1778 sv_upgrade(sv, SVt_PVNV);
1780 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1782 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1784 else if (SvPOKp(sv) && SvLEN(sv)) {
1786 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1788 SvNVX(sv) = Atof(SvPVX(sv));
1792 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1793 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1794 if (SvTYPE(sv) < SVt_NV)
1795 /* Typically the caller expects that sv_any is not NULL now. */
1796 sv_upgrade(sv, SVt_NV);
1800 #if defined(USE_LONG_DOUBLE)
1802 RESTORE_NUMERIC_STANDARD();
1803 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1804 PTR2UV(sv), SvNVX(sv));
1805 RESTORE_NUMERIC_LOCAL();
1809 RESTORE_NUMERIC_STANDARD();
1810 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1811 PTR2UV(sv), SvNVX(sv));
1812 RESTORE_NUMERIC_LOCAL();
1819 S_asIV(pTHX_ SV *sv)
1821 I32 numtype = looks_like_number(sv);
1824 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1825 return Atol(SvPVX(sv));
1828 if (ckWARN(WARN_NUMERIC))
1831 d = Atof(SvPVX(sv));
1836 S_asUV(pTHX_ SV *sv)
1838 I32 numtype = looks_like_number(sv);
1841 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1842 return Strtoul(SvPVX(sv), Null(char**), 10);
1846 if (ckWARN(WARN_NUMERIC))
1849 return U_V(Atof(SvPVX(sv)));
1853 * Returns a combination of (advisory only - can get false negatives)
1854 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1856 * 0 if does not look like number.
1858 * In fact possible values are 0 and
1859 * IS_NUMBER_TO_INT_BY_ATOL 123
1860 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1861 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1862 * with a possible addition of IS_NUMBER_NEG.
1866 Perl_looks_like_number(pTHX_ SV *sv)
1869 register char *send;
1870 register char *sbegin;
1871 register char *nbegin;
1879 else if (SvPOKp(sv))
1880 sbegin = SvPV(sv, len);
1883 send = sbegin + len;
1890 numtype = IS_NUMBER_NEG;
1897 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1898 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1902 /* next must be digit or the radix separator */
1906 } while (isDIGIT(*s));
1908 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1911 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1914 #ifdef USE_LOCALE_NUMERIC
1915 || IS_NUMERIC_RADIX(*s)
1919 numtype |= IS_NUMBER_NOT_IV;
1920 while (isDIGIT(*s)) /* optional digits after the radix */
1925 #ifdef USE_LOCALE_NUMERIC
1926 || IS_NUMERIC_RADIX(*s)
1930 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1931 /* no digits before the radix means we need digits after it */
1935 } while (isDIGIT(*s));
1943 /* we can have an optional exponent part */
1944 if (*s == 'e' || *s == 'E') {
1945 numtype &= ~IS_NUMBER_NEG;
1946 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1948 if (*s == '+' || *s == '-')
1953 } while (isDIGIT(*s));
1962 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1963 return IS_NUMBER_TO_INT_BY_ATOL;
1968 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1971 return sv_2pv(sv, &n_a);
1974 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1976 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1979 char *ptr = buf + TYPE_CHARS(UV);
1994 *--ptr = '0' + (uv % 10);
2003 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2008 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2009 char *tmpbuf = tbuf;
2015 if (SvGMAGICAL(sv)) {
2023 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2025 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2030 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2035 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2037 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2038 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2044 if (SvTHINKFIRST(sv)) {
2047 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2048 return SvPV(tmpstr,*lp);
2055 switch (SvTYPE(sv)) {
2057 if ( ((SvFLAGS(sv) &
2058 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2059 == (SVs_OBJECT|SVs_RMG))
2060 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2061 && (mg = mg_find(sv, 'r'))) {
2063 regexp *re = (regexp *)mg->mg_obj;
2066 char *fptr = "msix";
2071 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2073 while(ch = *fptr++) {
2075 reflags[left++] = ch;
2078 reflags[right--] = ch;
2083 reflags[left] = '-';
2087 mg->mg_len = re->prelen + 4 + left;
2088 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2089 Copy("(?", mg->mg_ptr, 2, char);
2090 Copy(reflags, mg->mg_ptr+2, left, char);
2091 Copy(":", mg->mg_ptr+left+2, 1, char);
2092 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2093 mg->mg_ptr[mg->mg_len - 1] = ')';
2094 mg->mg_ptr[mg->mg_len] = 0;
2096 PL_reginterp_cnt += re->program[0].next_off;
2108 case SVt_PVBM: s = "SCALAR"; break;
2109 case SVt_PVLV: s = "LVALUE"; break;
2110 case SVt_PVAV: s = "ARRAY"; break;
2111 case SVt_PVHV: s = "HASH"; break;
2112 case SVt_PVCV: s = "CODE"; break;
2113 case SVt_PVGV: s = "GLOB"; break;
2114 case SVt_PVFM: s = "FORMAT"; break;
2115 case SVt_PVIO: s = "IO"; break;
2116 default: s = "UNKNOWN"; break;
2120 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2123 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2129 if (SvREADONLY(sv) && !SvOK(sv)) {
2131 if (ckWARN(WARN_UNINITIALIZED))
2132 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2137 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2138 /* XXXX 64-bit? IV may have better precision... */
2139 /* I tried changing this for to be 64-bit-aware and
2140 * the t/op/numconvert.t became very, very, angry.
2142 if (SvTYPE(sv) < SVt_PVNV)
2143 sv_upgrade(sv, SVt_PVNV);
2146 olderrno = errno; /* some Xenix systems wipe out errno here */
2148 if (SvNVX(sv) == 0.0)
2149 (void)strcpy(s,"0");
2153 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2156 #ifdef FIXNEGATIVEZERO
2157 if (*s == '-' && s[1] == '0' && !s[2])
2166 else if (SvIOKp(sv)) {
2167 U32 isIOK = SvIOK(sv);
2168 U32 isUIOK = SvIsUV(sv);
2169 char buf[TYPE_CHARS(UV)];
2172 if (SvTYPE(sv) < SVt_PVIV)
2173 sv_upgrade(sv, SVt_PVIV);
2175 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2177 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2178 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2179 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2180 SvCUR_set(sv, ebuf - ptr);
2193 if (ckWARN(WARN_UNINITIALIZED)
2194 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2196 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2199 if (SvTYPE(sv) < SVt_PV)
2200 /* Typically the caller expects that sv_any is not NULL now. */
2201 sv_upgrade(sv, SVt_PV);
2204 *lp = s - SvPVX(sv);
2207 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2208 PTR2UV(sv),SvPVX(sv)));
2212 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2213 /* Sneaky stuff here */
2217 tsv = newSVpv(tmpbuf, 0);
2233 len = strlen(tmpbuf);
2235 #ifdef FIXNEGATIVEZERO
2236 if (len == 2 && t[0] == '-' && t[1] == '0') {
2241 (void)SvUPGRADE(sv, SVt_PV);
2243 s = SvGROW(sv, len + 1);
2251 /* This function is only called on magical items */
2253 Perl_sv_2bool(pTHX_ register SV *sv)
2263 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2264 return SvTRUE(tmpsv);
2265 return SvRV(sv) != 0;
2268 register XPV* Xpvtmp;
2269 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2270 (*Xpvtmp->xpv_pv > '0' ||
2271 Xpvtmp->xpv_cur > 1 ||
2272 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2279 return SvIVX(sv) != 0;
2282 return SvNVX(sv) != 0.0;
2289 /* Note: sv_setsv() should not be called with a source string that needs
2290 * to be reused, since it may destroy the source string if it is marked
2295 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2298 register U32 sflags;
2304 SV_CHECK_THINKFIRST(dstr);
2306 sstr = &PL_sv_undef;
2307 stype = SvTYPE(sstr);
2308 dtype = SvTYPE(dstr);
2312 /* There's a lot of redundancy below but we're going for speed here */
2317 if (dtype != SVt_PVGV) {
2318 (void)SvOK_off(dstr);
2326 sv_upgrade(dstr, SVt_IV);
2329 sv_upgrade(dstr, SVt_PVNV);
2333 sv_upgrade(dstr, SVt_PVIV);
2336 (void)SvIOK_only(dstr);
2337 SvIVX(dstr) = SvIVX(sstr);
2350 sv_upgrade(dstr, SVt_NV);
2355 sv_upgrade(dstr, SVt_PVNV);
2358 SvNVX(dstr) = SvNVX(sstr);
2359 (void)SvNOK_only(dstr);
2367 sv_upgrade(dstr, SVt_RV);
2368 else if (dtype == SVt_PVGV &&
2369 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2372 if (GvIMPORTED(dstr) != GVf_IMPORTED
2373 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2375 GvIMPORTED_on(dstr);
2386 sv_upgrade(dstr, SVt_PV);
2389 if (dtype < SVt_PVIV)
2390 sv_upgrade(dstr, SVt_PVIV);
2393 if (dtype < SVt_PVNV)
2394 sv_upgrade(dstr, SVt_PVNV);
2401 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2402 PL_op_name[PL_op->op_type]);
2404 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2408 if (dtype <= SVt_PVGV) {
2410 if (dtype != SVt_PVGV) {
2411 char *name = GvNAME(sstr);
2412 STRLEN len = GvNAMELEN(sstr);
2413 sv_upgrade(dstr, SVt_PVGV);
2414 sv_magic(dstr, dstr, '*', name, len);
2415 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2416 GvNAME(dstr) = savepvn(name, len);
2417 GvNAMELEN(dstr) = len;
2418 SvFAKE_on(dstr); /* can coerce to non-glob */
2420 /* ahem, death to those who redefine active sort subs */
2421 else if (PL_curstackinfo->si_type == PERLSI_SORT
2422 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2423 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2425 (void)SvOK_off(dstr);
2426 GvINTRO_off(dstr); /* one-shot flag */
2428 GvGP(dstr) = gp_ref(GvGP(sstr));
2430 if (GvIMPORTED(dstr) != GVf_IMPORTED
2431 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2433 GvIMPORTED_on(dstr);
2441 if (SvGMAGICAL(sstr)) {
2443 if (SvTYPE(sstr) != stype) {
2444 stype = SvTYPE(sstr);
2445 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2449 if (stype == SVt_PVLV)
2450 (void)SvUPGRADE(dstr, SVt_PVNV);
2452 (void)SvUPGRADE(dstr, stype);
2455 sflags = SvFLAGS(sstr);
2457 if (sflags & SVf_ROK) {
2458 if (dtype >= SVt_PV) {
2459 if (dtype == SVt_PVGV) {
2460 SV *sref = SvREFCNT_inc(SvRV(sstr));
2462 int intro = GvINTRO(dstr);
2467 GvINTRO_off(dstr); /* one-shot flag */
2468 Newz(602,gp, 1, GP);
2469 GvGP(dstr) = gp_ref(gp);
2470 GvSV(dstr) = NEWSV(72,0);
2471 GvLINE(dstr) = CopLINE(PL_curcop);
2472 GvEGV(dstr) = (GV*)dstr;
2475 switch (SvTYPE(sref)) {
2478 SAVESPTR(GvAV(dstr));
2480 dref = (SV*)GvAV(dstr);
2481 GvAV(dstr) = (AV*)sref;
2482 if (GvIMPORTED_AV_off(dstr)
2483 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2485 GvIMPORTED_AV_on(dstr);
2490 SAVESPTR(GvHV(dstr));
2492 dref = (SV*)GvHV(dstr);
2493 GvHV(dstr) = (HV*)sref;
2494 if (GvIMPORTED_HV_off(dstr)
2495 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2497 GvIMPORTED_HV_on(dstr);
2502 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2503 SvREFCNT_dec(GvCV(dstr));
2504 GvCV(dstr) = Nullcv;
2505 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2506 PL_sub_generation++;
2508 SAVESPTR(GvCV(dstr));
2511 dref = (SV*)GvCV(dstr);
2512 if (GvCV(dstr) != (CV*)sref) {
2513 CV* cv = GvCV(dstr);
2515 if (!GvCVGEN((GV*)dstr) &&
2516 (CvROOT(cv) || CvXSUB(cv)))
2518 SV *const_sv = cv_const_sv(cv);
2519 bool const_changed = TRUE;
2521 const_changed = sv_cmp(const_sv,
2522 op_const_sv(CvSTART((CV*)sref),
2524 /* ahem, death to those who redefine
2525 * active sort subs */
2526 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2527 PL_sortcop == CvSTART(cv))
2529 "Can't redefine active sort subroutine %s",
2530 GvENAME((GV*)dstr));
2531 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2532 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2533 && HvNAME(GvSTASH(CvGV(cv)))
2534 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2536 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2537 "Constant subroutine %s redefined"
2538 : "Subroutine %s redefined",
2539 GvENAME((GV*)dstr));
2542 cv_ckproto(cv, (GV*)dstr,
2543 SvPOK(sref) ? SvPVX(sref) : Nullch);
2545 GvCV(dstr) = (CV*)sref;
2546 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2547 GvASSUMECV_on(dstr);
2548 PL_sub_generation++;
2550 if (GvIMPORTED_CV_off(dstr)
2551 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2553 GvIMPORTED_CV_on(dstr);
2558 SAVESPTR(GvIOp(dstr));
2560 dref = (SV*)GvIOp(dstr);
2561 GvIOp(dstr) = (IO*)sref;
2565 SAVESPTR(GvSV(dstr));
2567 dref = (SV*)GvSV(dstr);
2569 if (GvIMPORTED_SV_off(dstr)
2570 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2572 GvIMPORTED_SV_on(dstr);
2584 (void)SvOOK_off(dstr); /* backoff */
2586 Safefree(SvPVX(dstr));
2587 SvLEN(dstr)=SvCUR(dstr)=0;
2590 (void)SvOK_off(dstr);
2591 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2593 if (sflags & SVp_NOK) {
2595 SvNVX(dstr) = SvNVX(sstr);
2597 if (sflags & SVp_IOK) {
2598 (void)SvIOK_on(dstr);
2599 SvIVX(dstr) = SvIVX(sstr);
2603 if (SvAMAGIC(sstr)) {
2607 else if (sflags & SVp_POK) {
2610 * Check to see if we can just swipe the string. If so, it's a
2611 * possible small lose on short strings, but a big win on long ones.
2612 * It might even be a win on short strings if SvPVX(dstr)
2613 * has to be allocated and SvPVX(sstr) has to be freed.
2616 if (SvTEMP(sstr) && /* slated for free anyway? */
2617 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2618 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2620 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2622 SvFLAGS(dstr) &= ~SVf_OOK;
2623 Safefree(SvPVX(dstr) - SvIVX(dstr));
2625 else if (SvLEN(dstr))
2626 Safefree(SvPVX(dstr));
2628 (void)SvPOK_only(dstr);
2629 SvPV_set(dstr, SvPVX(sstr));
2630 SvLEN_set(dstr, SvLEN(sstr));
2631 SvCUR_set(dstr, SvCUR(sstr));
2633 (void)SvOK_off(sstr);
2634 SvPV_set(sstr, Nullch);
2639 else { /* have to copy actual string */
2640 STRLEN len = SvCUR(sstr);
2642 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2643 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2644 SvCUR_set(dstr, len);
2645 *SvEND(dstr) = '\0';
2646 (void)SvPOK_only(dstr);
2649 if (sflags & SVp_NOK) {
2651 SvNVX(dstr) = SvNVX(sstr);
2653 if (sflags & SVp_IOK) {
2654 (void)SvIOK_on(dstr);
2655 SvIVX(dstr) = SvIVX(sstr);
2660 else if (sflags & SVp_NOK) {
2661 SvNVX(dstr) = SvNVX(sstr);
2662 (void)SvNOK_only(dstr);
2664 (void)SvIOK_on(dstr);
2665 SvIVX(dstr) = SvIVX(sstr);
2666 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2671 else if (sflags & SVp_IOK) {
2672 (void)SvIOK_only(dstr);
2673 SvIVX(dstr) = SvIVX(sstr);
2678 if (dtype == SVt_PVGV) {
2679 if (ckWARN(WARN_UNSAFE))
2680 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2683 (void)SvOK_off(dstr);
2689 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2691 sv_setsv(dstr,sstr);
2696 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2698 register char *dptr;
2699 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2700 elicit a warning, but it won't hurt. */
2701 SV_CHECK_THINKFIRST(sv);
2706 (void)SvUPGRADE(sv, SVt_PV);
2708 SvGROW(sv, len + 1);
2710 Move(ptr,dptr,len,char);
2713 (void)SvPOK_only(sv); /* validate pointer */
2718 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2720 sv_setpvn(sv,ptr,len);
2725 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2727 register STRLEN len;
2729 SV_CHECK_THINKFIRST(sv);
2735 (void)SvUPGRADE(sv, SVt_PV);
2737 SvGROW(sv, len + 1);
2738 Move(ptr,SvPVX(sv),len+1,char);
2740 (void)SvPOK_only(sv); /* validate pointer */
2745 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2752 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2754 SV_CHECK_THINKFIRST(sv);
2755 (void)SvUPGRADE(sv, SVt_PV);
2760 (void)SvOOK_off(sv);
2761 if (SvPVX(sv) && SvLEN(sv))
2762 Safefree(SvPVX(sv));
2763 Renew(ptr, len+1, char);
2766 SvLEN_set(sv, len+1);
2768 (void)SvPOK_only(sv); /* validate pointer */
2773 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2775 sv_usepvn(sv,ptr,len);
2780 Perl_sv_force_normal(pTHX_ register SV *sv)
2782 if (SvREADONLY(sv)) {
2784 if (PL_curcop != &PL_compiling)
2785 Perl_croak(aTHX_ PL_no_modify);
2789 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2794 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2798 register STRLEN delta;
2800 if (!ptr || !SvPOKp(sv))
2802 SV_CHECK_THINKFIRST(sv);
2803 if (SvTYPE(sv) < SVt_PVIV)
2804 sv_upgrade(sv,SVt_PVIV);
2807 if (!SvLEN(sv)) { /* make copy of shared string */
2808 char *pvx = SvPVX(sv);
2809 STRLEN len = SvCUR(sv);
2810 SvGROW(sv, len + 1);
2811 Move(pvx,SvPVX(sv),len,char);
2815 SvFLAGS(sv) |= SVf_OOK;
2817 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2818 delta = ptr - SvPVX(sv);
2826 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2831 junk = SvPV_force(sv, tlen);
2832 SvGROW(sv, tlen + len + 1);
2835 Move(ptr,SvPVX(sv)+tlen,len,char);
2838 (void)SvPOK_only(sv); /* validate pointer */
2843 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2845 sv_catpvn(sv,ptr,len);
2850 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2856 if (s = SvPV(sstr, len))
2857 sv_catpvn(dstr,s,len);
2861 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2863 sv_catsv(dstr,sstr);
2868 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2870 register STRLEN len;
2876 junk = SvPV_force(sv, tlen);
2878 SvGROW(sv, tlen + len + 1);
2881 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2883 (void)SvPOK_only(sv); /* validate pointer */
2888 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2895 Perl_newSV(pTHX_ STRLEN len)
2901 sv_upgrade(sv, SVt_PV);
2902 SvGROW(sv, len + 1);
2907 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2910 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2914 if (SvREADONLY(sv)) {
2916 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2917 Perl_croak(aTHX_ PL_no_modify);
2919 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2920 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2927 (void)SvUPGRADE(sv, SVt_PVMG);
2929 Newz(702,mg, 1, MAGIC);
2930 mg->mg_moremagic = SvMAGIC(sv);
2933 if (!obj || obj == sv || how == '#' || how == 'r')
2937 mg->mg_obj = SvREFCNT_inc(obj);
2938 mg->mg_flags |= MGf_REFCOUNTED;
2941 mg->mg_len = namlen;
2944 mg->mg_ptr = savepvn(name, namlen);
2945 else if (namlen == HEf_SVKEY)
2946 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2950 mg->mg_virtual = &PL_vtbl_sv;
2953 mg->mg_virtual = &PL_vtbl_amagic;
2956 mg->mg_virtual = &PL_vtbl_amagicelem;
2962 mg->mg_virtual = &PL_vtbl_bm;
2965 mg->mg_virtual = &PL_vtbl_regdata;
2968 mg->mg_virtual = &PL_vtbl_regdatum;
2971 mg->mg_virtual = &PL_vtbl_env;
2974 mg->mg_virtual = &PL_vtbl_fm;
2977 mg->mg_virtual = &PL_vtbl_envelem;
2980 mg->mg_virtual = &PL_vtbl_mglob;
2983 mg->mg_virtual = &PL_vtbl_isa;
2986 mg->mg_virtual = &PL_vtbl_isaelem;
2989 mg->mg_virtual = &PL_vtbl_nkeys;
2996 mg->mg_virtual = &PL_vtbl_dbline;
3000 mg->mg_virtual = &PL_vtbl_mutex;
3002 #endif /* USE_THREADS */
3003 #ifdef USE_LOCALE_COLLATE
3005 mg->mg_virtual = &PL_vtbl_collxfrm;
3007 #endif /* USE_LOCALE_COLLATE */
3009 mg->mg_virtual = &PL_vtbl_pack;
3013 mg->mg_virtual = &PL_vtbl_packelem;
3016 mg->mg_virtual = &PL_vtbl_regexp;
3019 mg->mg_virtual = &PL_vtbl_sig;
3022 mg->mg_virtual = &PL_vtbl_sigelem;
3025 mg->mg_virtual = &PL_vtbl_taint;
3029 mg->mg_virtual = &PL_vtbl_uvar;
3032 mg->mg_virtual = &PL_vtbl_vec;
3035 mg->mg_virtual = &PL_vtbl_substr;
3038 mg->mg_virtual = &PL_vtbl_defelem;
3041 mg->mg_virtual = &PL_vtbl_glob;
3044 mg->mg_virtual = &PL_vtbl_arylen;
3047 mg->mg_virtual = &PL_vtbl_pos;
3050 mg->mg_virtual = &PL_vtbl_backref;
3052 case '~': /* Reserved for use by extensions not perl internals. */
3053 /* Useful for attaching extension internal data to perl vars. */
3054 /* Note that multiple extensions may clash if magical scalars */
3055 /* etc holding private data from one are passed to another. */
3059 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3063 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3067 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3071 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3074 for (mg = *mgp; mg; mg = *mgp) {
3075 if (mg->mg_type == type) {
3076 MGVTBL* vtbl = mg->mg_virtual;
3077 *mgp = mg->mg_moremagic;
3078 if (vtbl && vtbl->svt_free)
3079 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3080 if (mg->mg_ptr && mg->mg_type != 'g')
3081 if (mg->mg_len >= 0)
3082 Safefree(mg->mg_ptr);
3083 else if (mg->mg_len == HEf_SVKEY)
3084 SvREFCNT_dec((SV*)mg->mg_ptr);
3085 if (mg->mg_flags & MGf_REFCOUNTED)
3086 SvREFCNT_dec(mg->mg_obj);
3090 mgp = &mg->mg_moremagic;
3094 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3101 Perl_sv_rvweaken(pTHX_ SV *sv)
3104 if (!SvOK(sv)) /* let undefs pass */
3107 Perl_croak(aTHX_ "Can't weaken a nonreference");
3108 else if (SvWEAKREF(sv)) {
3110 if (ckWARN(WARN_MISC))
3111 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3115 sv_add_backref(tsv, sv);
3122 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3126 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3127 av = (AV*)mg->mg_obj;
3130 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3131 SvREFCNT_dec(av); /* for sv_magic */
3137 S_sv_del_backref(pTHX_ SV *sv)
3144 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3145 Perl_croak(aTHX_ "panic: del_backref");
3146 av = (AV *)mg->mg_obj;
3151 svp[i] = &PL_sv_undef; /* XXX */
3158 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3162 register char *midend;
3163 register char *bigend;
3169 Perl_croak(aTHX_ "Can't modify non-existent substring");
3170 SvPV_force(bigstr, curlen);
3171 if (offset + len > curlen) {
3172 SvGROW(bigstr, offset+len+1);
3173 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3174 SvCUR_set(bigstr, offset+len);
3177 i = littlelen - len;
3178 if (i > 0) { /* string might grow */
3179 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3180 mid = big + offset + len;
3181 midend = bigend = big + SvCUR(bigstr);
3184 while (midend > mid) /* shove everything down */
3185 *--bigend = *--midend;
3186 Move(little,big+offset,littlelen,char);
3192 Move(little,SvPVX(bigstr)+offset,len,char);
3197 big = SvPVX(bigstr);
3200 bigend = big + SvCUR(bigstr);
3202 if (midend > bigend)
3203 Perl_croak(aTHX_ "panic: sv_insert");
3205 if (mid - big > bigend - midend) { /* faster to shorten from end */
3207 Move(little, mid, littlelen,char);
3210 i = bigend - midend;
3212 Move(midend, mid, i,char);
3216 SvCUR_set(bigstr, mid - big);
3219 else if (i = mid - big) { /* faster from front */
3220 midend -= littlelen;
3222 sv_chop(bigstr,midend-i);
3227 Move(little, mid, littlelen,char);
3229 else if (littlelen) {
3230 midend -= littlelen;
3231 sv_chop(bigstr,midend);
3232 Move(little,midend,littlelen,char);
3235 sv_chop(bigstr,midend);
3240 /* make sv point to what nstr did */
3243 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3246 U32 refcnt = SvREFCNT(sv);
3247 SV_CHECK_THINKFIRST(sv);
3248 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3249 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3250 if (SvMAGICAL(sv)) {
3254 sv_upgrade(nsv, SVt_PVMG);
3255 SvMAGIC(nsv) = SvMAGIC(sv);
3256 SvFLAGS(nsv) |= SvMAGICAL(sv);
3262 assert(!SvREFCNT(sv));
3263 StructCopy(nsv,sv,SV);
3264 SvREFCNT(sv) = refcnt;
3265 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3270 Perl_sv_clear(pTHX_ register SV *sv)
3274 assert(SvREFCNT(sv) == 0);
3278 if (PL_defstash) { /* Still have a symbol table? */
3283 Zero(&tmpref, 1, SV);
3284 sv_upgrade(&tmpref, SVt_RV);
3286 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3287 SvREFCNT(&tmpref) = 1;
3290 stash = SvSTASH(sv);
3291 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3294 PUSHSTACKi(PERLSI_DESTROY);
3295 SvRV(&tmpref) = SvREFCNT_inc(sv);
3300 call_sv((SV*)GvCV(destructor),
3301 G_DISCARD|G_EVAL|G_KEEPERR);
3307 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3309 del_XRV(SvANY(&tmpref));
3312 if (PL_in_clean_objs)
3313 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3315 /* DESTROY gave object new lease on life */
3321 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3322 SvOBJECT_off(sv); /* Curse the object. */
3323 if (SvTYPE(sv) != SVt_PVIO)
3324 --PL_sv_objcount; /* XXX Might want something more general */
3327 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3330 switch (SvTYPE(sv)) {
3333 IoIFP(sv) != PerlIO_stdin() &&
3334 IoIFP(sv) != PerlIO_stdout() &&
3335 IoIFP(sv) != PerlIO_stderr())
3337 io_close((IO*)sv, FALSE);
3339 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3340 PerlDir_close(IoDIRP(sv));
3341 IoDIRP(sv) = (DIR*)NULL;
3342 Safefree(IoTOP_NAME(sv));
3343 Safefree(IoFMT_NAME(sv));
3344 Safefree(IoBOTTOM_NAME(sv));
3359 SvREFCNT_dec(LvTARG(sv));
3363 Safefree(GvNAME(sv));
3364 /* cannot decrease stash refcount yet, as we might recursively delete
3365 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3366 of stash until current sv is completely gone.
3367 -- JohnPC, 27 Mar 1998 */
3368 stash = GvSTASH(sv);
3374 (void)SvOOK_off(sv);
3382 SvREFCNT_dec(SvRV(sv));
3384 else if (SvPVX(sv) && SvLEN(sv))
3385 Safefree(SvPVX(sv));
3395 switch (SvTYPE(sv)) {
3411 del_XPVIV(SvANY(sv));
3414 del_XPVNV(SvANY(sv));
3417 del_XPVMG(SvANY(sv));
3420 del_XPVLV(SvANY(sv));
3423 del_XPVAV(SvANY(sv));
3426 del_XPVHV(SvANY(sv));
3429 del_XPVCV(SvANY(sv));
3432 del_XPVGV(SvANY(sv));
3433 /* code duplication for increased performance. */
3434 SvFLAGS(sv) &= SVf_BREAK;
3435 SvFLAGS(sv) |= SVTYPEMASK;
3436 /* decrease refcount of the stash that owns this GV, if any */
3438 SvREFCNT_dec(stash);
3439 return; /* not break, SvFLAGS reset already happened */
3441 del_XPVBM(SvANY(sv));
3444 del_XPVFM(SvANY(sv));
3447 del_XPVIO(SvANY(sv));
3450 SvFLAGS(sv) &= SVf_BREAK;
3451 SvFLAGS(sv) |= SVTYPEMASK;
3455 Perl_sv_newref(pTHX_ SV *sv)
3458 ATOMIC_INC(SvREFCNT(sv));
3463 Perl_sv_free(pTHX_ SV *sv)
3466 int refcount_is_zero;
3470 if (SvREFCNT(sv) == 0) {
3471 if (SvFLAGS(sv) & SVf_BREAK)
3473 if (PL_in_clean_all) /* All is fair */
3475 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3476 /* make sure SvREFCNT(sv)==0 happens very seldom */
3477 SvREFCNT(sv) = (~(U32)0)/2;
3480 if (ckWARN_d(WARN_INTERNAL))
3481 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3484 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3485 if (!refcount_is_zero)
3489 if (ckWARN_d(WARN_DEBUGGING))
3490 Perl_warner(aTHX_ WARN_DEBUGGING,
3491 "Attempt to free temp prematurely: SV 0x%"UVxf,
3496 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3497 /* make sure SvREFCNT(sv)==0 happens very seldom */
3498 SvREFCNT(sv) = (~(U32)0)/2;
3507 Perl_sv_len(pTHX_ register SV *sv)
3516 len = mg_length(sv);
3518 junk = SvPV(sv, len);
3523 Perl_sv_len_utf8(pTHX_ register SV *sv)
3534 len = mg_length(sv);
3537 s = (U8*)SvPV(sv, len);
3548 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3553 I32 uoffset = *offsetp;
3559 start = s = (U8*)SvPV(sv, len);
3561 while (s < send && uoffset--)
3565 *offsetp = s - start;
3569 while (s < send && ulen--)
3579 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3588 s = (U8*)SvPV(sv, len);
3590 Perl_croak(aTHX_ "panic: bad byte offset");
3591 send = s + *offsetp;
3599 if (ckWARN_d(WARN_UTF8))
3600 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3608 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3620 pv1 = SvPV(str1, cur1);
3625 pv2 = SvPV(str2, cur2);
3630 return memEQ(pv1, pv2, cur1);
3634 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3637 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3639 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3643 return cur2 ? -1 : 0;
3648 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3651 return retval < 0 ? -1 : 1;
3656 return cur1 < cur2 ? -1 : 1;
3660 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3662 #ifdef USE_LOCALE_COLLATE
3668 if (PL_collation_standard)
3672 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3674 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3676 if (!pv1 || !len1) {
3687 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3690 return retval < 0 ? -1 : 1;
3693 * When the result of collation is equality, that doesn't mean
3694 * that there are no differences -- some locales exclude some
3695 * characters from consideration. So to avoid false equalities,
3696 * we use the raw string as a tiebreaker.
3702 #endif /* USE_LOCALE_COLLATE */
3704 return sv_cmp(sv1, sv2);
3707 #ifdef USE_LOCALE_COLLATE
3709 * Any scalar variable may carry an 'o' magic that contains the
3710 * scalar data of the variable transformed to such a format that
3711 * a normal memory comparison can be used to compare the data
3712 * according to the locale settings.
3715 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3719 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3720 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3725 Safefree(mg->mg_ptr);
3727 if ((xf = mem_collxfrm(s, len, &xlen))) {
3728 if (SvREADONLY(sv)) {
3731 return xf + sizeof(PL_collation_ix);
3734 sv_magic(sv, 0, 'o', 0, 0);
3735 mg = mg_find(sv, 'o');
3748 if (mg && mg->mg_ptr) {
3750 return mg->mg_ptr + sizeof(PL_collation_ix);
3758 #endif /* USE_LOCALE_COLLATE */
3761 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3766 register STDCHAR rslast;
3767 register STDCHAR *bp;
3771 SV_CHECK_THINKFIRST(sv);
3772 (void)SvUPGRADE(sv, SVt_PV);
3776 if (RsSNARF(PL_rs)) {
3780 else if (RsRECORD(PL_rs)) {
3781 I32 recsize, bytesread;
3784 /* Grab the size of the record we're getting */
3785 recsize = SvIV(SvRV(PL_rs));
3786 (void)SvPOK_only(sv); /* Validate pointer */
3787 buffer = SvGROW(sv, recsize + 1);
3790 /* VMS wants read instead of fread, because fread doesn't respect */
3791 /* RMS record boundaries. This is not necessarily a good thing to be */
3792 /* doing, but we've got no other real choice */
3793 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3795 bytesread = PerlIO_read(fp, buffer, recsize);
3797 SvCUR_set(sv, bytesread);
3798 buffer[bytesread] = '\0';
3799 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3801 else if (RsPARA(PL_rs)) {
3806 rsptr = SvPV(PL_rs, rslen);
3807 rslast = rslen ? rsptr[rslen - 1] : '\0';
3809 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3810 do { /* to make sure file boundaries work right */
3813 i = PerlIO_getc(fp);
3817 PerlIO_ungetc(fp,i);
3823 /* See if we know enough about I/O mechanism to cheat it ! */
3825 /* This used to be #ifdef test - it is made run-time test for ease
3826 of abstracting out stdio interface. One call should be cheap
3827 enough here - and may even be a macro allowing compile
3831 if (PerlIO_fast_gets(fp)) {
3834 * We're going to steal some values from the stdio struct
3835 * and put EVERYTHING in the innermost loop into registers.
3837 register STDCHAR *ptr;
3841 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3842 /* An ungetc()d char is handled separately from the regular
3843 * buffer, so we getc() it back out and stuff it in the buffer.
3845 i = PerlIO_getc(fp);
3846 if (i == EOF) return 0;
3847 *(--((*fp)->_ptr)) = (unsigned char) i;
3851 /* Here is some breathtakingly efficient cheating */
3853 cnt = PerlIO_get_cnt(fp); /* get count into register */
3854 (void)SvPOK_only(sv); /* validate pointer */
3855 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3856 if (cnt > 80 && SvLEN(sv) > append) {
3857 shortbuffered = cnt - SvLEN(sv) + append + 1;
3858 cnt -= shortbuffered;
3862 /* remember that cnt can be negative */
3863 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3868 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3869 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3870 DEBUG_P(PerlIO_printf(Perl_debug_log,
3871 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3872 DEBUG_P(PerlIO_printf(Perl_debug_log,
3873 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3874 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3875 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3880 while (cnt > 0) { /* this | eat */
3882 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3883 goto thats_all_folks; /* screams | sed :-) */
3887 Copy(ptr, bp, cnt, char); /* this | eat */
3888 bp += cnt; /* screams | dust */
3889 ptr += cnt; /* louder | sed :-) */
3894 if (shortbuffered) { /* oh well, must extend */
3895 cnt = shortbuffered;
3897 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3899 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3900 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3904 DEBUG_P(PerlIO_printf(Perl_debug_log,
3905 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3906 PTR2UV(ptr),(long)cnt));
3907 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3908 DEBUG_P(PerlIO_printf(Perl_debug_log,
3909 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3910 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3911 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3912 /* This used to call 'filbuf' in stdio form, but as that behaves like
3913 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3914 another abstraction. */
3915 i = PerlIO_getc(fp); /* get more characters */
3916 DEBUG_P(PerlIO_printf(Perl_debug_log,
3917 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3918 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3919 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3920 cnt = PerlIO_get_cnt(fp);
3921 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3922 DEBUG_P(PerlIO_printf(Perl_debug_log,
3923 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3925 if (i == EOF) /* all done for ever? */
3926 goto thats_really_all_folks;
3928 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3930 SvGROW(sv, bpx + cnt + 2);
3931 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3933 *bp++ = i; /* store character from PerlIO_getc */
3935 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3936 goto thats_all_folks;
3940 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3941 memNE((char*)bp - rslen, rsptr, rslen))
3942 goto screamer; /* go back to the fray */
3943 thats_really_all_folks:
3945 cnt += shortbuffered;
3946 DEBUG_P(PerlIO_printf(Perl_debug_log,
3947 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3948 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3949 DEBUG_P(PerlIO_printf(Perl_debug_log,
3950 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3951 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3952 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3954 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3955 DEBUG_P(PerlIO_printf(Perl_debug_log,
3956 "Screamer: done, len=%ld, string=|%.*s|\n",
3957 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3962 /*The big, slow, and stupid way */
3965 /* Need to work around EPOC SDK features */
3966 /* On WINS: MS VC5 generates calls to _chkstk, */
3967 /* if a `large' stack frame is allocated */
3968 /* gcc on MARM does not generate calls like these */
3974 register STDCHAR *bpe = buf + sizeof(buf);
3976 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3977 ; /* keep reading */
3981 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3982 /* Accomodate broken VAXC compiler, which applies U8 cast to
3983 * both args of ?: operator, causing EOF to change into 255
3985 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3989 sv_catpvn(sv, (char *) buf, cnt);
3991 sv_setpvn(sv, (char *) buf, cnt);
3993 if (i != EOF && /* joy */
3995 SvCUR(sv) < rslen ||
3996 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4000 * If we're reading from a TTY and we get a short read,
4001 * indicating that the user hit his EOF character, we need
4002 * to notice it now, because if we try to read from the TTY
4003 * again, the EOF condition will disappear.
4005 * The comparison of cnt to sizeof(buf) is an optimization
4006 * that prevents unnecessary calls to feof().
4010 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4015 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4016 while (i != EOF) { /* to make sure file boundaries work right */
4017 i = PerlIO_getc(fp);
4019 PerlIO_ungetc(fp,i);
4026 win32_strip_return(sv);
4029 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4034 Perl_sv_inc(pTHX_ register SV *sv)
4043 if (SvTHINKFIRST(sv)) {
4044 if (SvREADONLY(sv)) {
4046 if (PL_curcop != &PL_compiling)
4047 Perl_croak(aTHX_ PL_no_modify);
4051 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4053 i = PTR2IV(SvRV(sv));
4058 flags = SvFLAGS(sv);
4059 if (flags & SVp_NOK) {
4060 (void)SvNOK_only(sv);
4064 if (flags & SVp_IOK) {
4066 if (SvUVX(sv) == UV_MAX)
4067 sv_setnv(sv, (NV)UV_MAX + 1.0);
4069 (void)SvIOK_only_UV(sv);
4072 if (SvIVX(sv) == IV_MAX)
4073 sv_setnv(sv, (NV)IV_MAX + 1.0);
4075 (void)SvIOK_only(sv);
4081 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4082 if ((flags & SVTYPEMASK) < SVt_PVNV)
4083 sv_upgrade(sv, SVt_NV);
4085 (void)SvNOK_only(sv);
4089 while (isALPHA(*d)) d++;
4090 while (isDIGIT(*d)) d++;
4092 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4096 while (d >= SvPVX(sv)) {
4104 /* MKS: The original code here died if letters weren't consecutive.
4105 * at least it didn't have to worry about non-C locales. The
4106 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4107 * arranged in order (although not consecutively) and that only
4108 * [A-Za-z] are accepted by isALPHA in the C locale.
4110 if (*d != 'z' && *d != 'Z') {
4111 do { ++*d; } while (!isALPHA(*d));
4114 *(d--) -= 'z' - 'a';
4119 *(d--) -= 'z' - 'a' + 1;
4123 /* oh,oh, the number grew */
4124 SvGROW(sv, SvCUR(sv) + 2);
4126 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4135 Perl_sv_dec(pTHX_ register SV *sv)
4143 if (SvTHINKFIRST(sv)) {
4144 if (SvREADONLY(sv)) {
4146 if (PL_curcop != &PL_compiling)
4147 Perl_croak(aTHX_ PL_no_modify);
4151 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4153 i = PTR2IV(SvRV(sv));
4158 flags = SvFLAGS(sv);
4159 if (flags & SVp_NOK) {
4161 (void)SvNOK_only(sv);
4164 if (flags & SVp_IOK) {
4166 if (SvUVX(sv) == 0) {
4167 (void)SvIOK_only(sv);
4171 (void)SvIOK_only_UV(sv);
4175 if (SvIVX(sv) == IV_MIN)
4176 sv_setnv(sv, (NV)IV_MIN - 1.0);
4178 (void)SvIOK_only(sv);
4184 if (!(flags & SVp_POK)) {
4185 if ((flags & SVTYPEMASK) < SVt_PVNV)
4186 sv_upgrade(sv, SVt_NV);
4188 (void)SvNOK_only(sv);
4191 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4194 /* Make a string that will exist for the duration of the expression
4195 * evaluation. Actually, it may have to last longer than that, but
4196 * hopefully we won't free it until it has been assigned to a
4197 * permanent location. */
4200 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4206 sv_setsv(sv,oldstr);
4208 PL_tmps_stack[++PL_tmps_ix] = sv;
4214 Perl_sv_newmortal(pTHX)
4220 SvFLAGS(sv) = SVs_TEMP;
4222 PL_tmps_stack[++PL_tmps_ix] = sv;
4226 /* same thing without the copying */
4229 Perl_sv_2mortal(pTHX_ register SV *sv)
4234 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4237 PL_tmps_stack[++PL_tmps_ix] = sv;
4243 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4250 sv_setpvn(sv,s,len);
4255 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4260 sv_setpvn(sv,s,len);
4264 #if defined(PERL_IMPLICIT_CONTEXT)
4266 Perl_newSVpvf_nocontext(const char* pat, ...)
4271 va_start(args, pat);
4272 sv = vnewSVpvf(pat, &args);
4279 Perl_newSVpvf(pTHX_ const char* pat, ...)
4283 va_start(args, pat);
4284 sv = vnewSVpvf(pat, &args);
4290 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4294 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4299 Perl_newSVnv(pTHX_ NV n)
4309 Perl_newSViv(pTHX_ IV i)
4319 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4325 sv_upgrade(sv, SVt_RV);
4333 Perl_newRV(pTHX_ SV *tmpRef)
4335 return newRV_noinc(SvREFCNT_inc(tmpRef));
4338 /* make an exact duplicate of old */
4341 Perl_newSVsv(pTHX_ register SV *old)
4348 if (SvTYPE(old) == SVTYPEMASK) {
4349 if (ckWARN_d(WARN_INTERNAL))
4350 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4365 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4373 char todo[PERL_UCHAR_MAX+1];
4378 if (!*s) { /* reset ?? searches */
4379 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4380 pm->op_pmdynflags &= ~PMdf_USED;
4385 /* reset variables */
4387 if (!HvARRAY(stash))
4390 Zero(todo, 256, char);
4392 i = (unsigned char)*s;
4396 max = (unsigned char)*s++;
4397 for ( ; i <= max; i++) {
4400 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4401 for (entry = HvARRAY(stash)[i];
4403 entry = HeNEXT(entry))
4405 if (!todo[(U8)*HeKEY(entry)])
4407 gv = (GV*)HeVAL(entry);
4409 if (SvTHINKFIRST(sv)) {
4410 if (!SvREADONLY(sv) && SvROK(sv))
4415 if (SvTYPE(sv) >= SVt_PV) {
4417 if (SvPVX(sv) != Nullch)
4424 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4426 #ifndef VMS /* VMS has no environ array */
4428 environ[0] = Nullch;
4437 Perl_sv_2io(pTHX_ SV *sv)
4443 switch (SvTYPE(sv)) {
4451 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4455 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4457 return sv_2io(SvRV(sv));
4458 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4464 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4471 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4478 return *gvp = Nullgv, Nullcv;
4479 switch (SvTYPE(sv)) {
4499 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4500 tryAMAGICunDEREF(to_cv);
4503 if (SvTYPE(sv) == SVt_PVCV) {
4512 Perl_croak(aTHX_ "Not a subroutine reference");
4517 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4523 if (lref && !GvCVu(gv)) {
4526 tmpsv = NEWSV(704,0);
4527 gv_efullname3(tmpsv, gv, Nullch);
4528 /* XXX this is probably not what they think they're getting.
4529 * It has the same effect as "sub name;", i.e. just a forward
4531 newSUB(start_subparse(FALSE, 0),
4532 newSVOP(OP_CONST, 0, tmpsv),
4537 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4544 Perl_sv_true(pTHX_ register SV *sv)
4551 if ((tXpv = (XPV*)SvANY(sv)) &&
4552 (*tXpv->xpv_pv > '0' ||
4553 tXpv->xpv_cur > 1 ||
4554 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4561 return SvIVX(sv) != 0;
4564 return SvNVX(sv) != 0.0;
4566 return sv_2bool(sv);
4572 Perl_sv_iv(pTHX_ register SV *sv)
4576 return (IV)SvUVX(sv);
4583 Perl_sv_uv(pTHX_ register SV *sv)
4588 return (UV)SvIVX(sv);
4594 Perl_sv_nv(pTHX_ register SV *sv)
4602 Perl_sv_pv(pTHX_ SV *sv)
4609 return sv_2pv(sv, &n_a);
4613 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4619 return sv_2pv(sv, lp);
4623 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4627 if (SvTHINKFIRST(sv) && !SvROK(sv))
4628 sv_force_normal(sv);
4634 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4636 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4637 PL_op_name[PL_op->op_type]);
4641 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4646 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4647 SvGROW(sv, len + 1);
4648 Move(s,SvPVX(sv),len,char);
4653 SvPOK_on(sv); /* validate pointer */
4655 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4656 PTR2UV(sv),SvPVX(sv)));
4663 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4665 if (ob && SvOBJECT(sv))
4666 return HvNAME(SvSTASH(sv));
4668 switch (SvTYPE(sv)) {
4682 case SVt_PVLV: return "LVALUE";
4683 case SVt_PVAV: return "ARRAY";
4684 case SVt_PVHV: return "HASH";
4685 case SVt_PVCV: return "CODE";
4686 case SVt_PVGV: return "GLOB";
4687 case SVt_PVFM: return "FORMAT";
4688 default: return "UNKNOWN";
4694 Perl_sv_isobject(pTHX_ SV *sv)
4709 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4721 return strEQ(HvNAME(SvSTASH(sv)), name);
4725 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4732 SV_CHECK_THINKFIRST(rv);
4735 if (SvTYPE(rv) < SVt_RV)
4736 sv_upgrade(rv, SVt_RV);
4743 HV* stash = gv_stashpv(classname, TRUE);
4744 (void)sv_bless(rv, stash);
4750 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4753 sv_setsv(rv, &PL_sv_undef);
4757 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4762 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4764 sv_setiv(newSVrv(rv,classname), iv);
4769 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4771 sv_setnv(newSVrv(rv,classname), nv);
4776 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4778 sv_setpvn(newSVrv(rv,classname), pv, n);
4783 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4788 Perl_croak(aTHX_ "Can't bless non-reference value");
4790 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4791 if (SvREADONLY(tmpRef))
4792 Perl_croak(aTHX_ PL_no_modify);
4793 if (SvOBJECT(tmpRef)) {
4794 if (SvTYPE(tmpRef) != SVt_PVIO)
4796 SvREFCNT_dec(SvSTASH(tmpRef));
4799 SvOBJECT_on(tmpRef);
4800 if (SvTYPE(tmpRef) != SVt_PVIO)
4802 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4803 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4814 S_sv_unglob(pTHX_ SV *sv)
4816 assert(SvTYPE(sv) == SVt_PVGV);
4821 SvREFCNT_dec(GvSTASH(sv));
4822 GvSTASH(sv) = Nullhv;
4824 sv_unmagic(sv, '*');
4825 Safefree(GvNAME(sv));
4827 SvFLAGS(sv) &= ~SVTYPEMASK;
4828 SvFLAGS(sv) |= SVt_PVMG;
4832 Perl_sv_unref(pTHX_ SV *sv)
4836 if (SvWEAKREF(sv)) {
4844 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4847 sv_2mortal(rv); /* Schedule for freeing later */
4851 Perl_sv_taint(pTHX_ SV *sv)
4853 sv_magic((sv), Nullsv, 't', Nullch, 0);
4857 Perl_sv_untaint(pTHX_ SV *sv)
4859 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4860 MAGIC *mg = mg_find(sv, 't');
4867 Perl_sv_tainted(pTHX_ SV *sv)
4869 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4870 MAGIC *mg = mg_find(sv, 't');
4871 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4878 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4880 char buf[TYPE_CHARS(UV)];
4882 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4884 sv_setpvn(sv, ptr, ebuf - ptr);
4889 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4891 char buf[TYPE_CHARS(UV)];
4893 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4895 sv_setpvn(sv, ptr, ebuf - ptr);
4899 #if defined(PERL_IMPLICIT_CONTEXT)
4901 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4905 va_start(args, pat);
4906 sv_vsetpvf(sv, pat, &args);
4912 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4916 va_start(args, pat);
4917 sv_vsetpvf_mg(sv, pat, &args);
4923 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4926 va_start(args, pat);
4927 sv_vsetpvf(sv, pat, &args);
4932 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4934 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4938 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4941 va_start(args, pat);
4942 sv_vsetpvf_mg(sv, pat, &args);
4947 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4949 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4953 #if defined(PERL_IMPLICIT_CONTEXT)
4955 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4959 va_start(args, pat);
4960 sv_vcatpvf(sv, pat, &args);
4965 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4969 va_start(args, pat);
4970 sv_vcatpvf_mg(sv, pat, &args);
4976 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4979 va_start(args, pat);
4980 sv_vcatpvf(sv, pat, &args);
4985 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4987 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4991 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4994 va_start(args, pat);
4995 sv_vcatpvf_mg(sv, pat, &args);
5000 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5002 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5007 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5009 sv_setpvn(sv, "", 0);
5010 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5014 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5022 static char nullstr[] = "(null)";
5024 /* no matter what, this is a string now */
5025 (void)SvPV_force(sv, origlen);
5027 /* special-case "", "%s", and "%_" */
5030 if (patlen == 2 && pat[0] == '%') {
5034 char *s = va_arg(*args, char*);
5035 sv_catpv(sv, s ? s : nullstr);
5037 else if (svix < svmax)
5038 sv_catsv(sv, *svargs);
5042 sv_catsv(sv, va_arg(*args, SV*));
5045 /* See comment on '_' below */
5050 patend = (char*)pat + patlen;
5051 for (p = (char*)pat; p < patend; p = q) {
5059 bool has_precis = FALSE;
5064 STRLEN esignlen = 0;
5066 char *eptr = Nullch;
5068 /* Times 4: a decimal digit takes more than 3 binary digits.
5069 * NV_DIG: mantissa takes than many decimal digits.
5070 * Plus 32: Playing safe. */
5071 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5072 /* large enough for "%#.#f" --chip */
5073 /* what about long double NVs? --jhi */
5084 for (q = p; q < patend && *q != '%'; ++q) ;
5086 sv_catpvn(sv, p, q - p);
5124 case '1': case '2': case '3':
5125 case '4': case '5': case '6':
5126 case '7': case '8': case '9':
5129 width = width * 10 + (*q++ - '0');
5134 i = va_arg(*args, int);
5136 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5138 width = (i < 0) ? -i : i;
5149 i = va_arg(*args, int);
5151 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5152 precis = (i < 0) ? 0 : i;
5158 precis = precis * 10 + (*q++ - '0');
5175 if (*(q + 1) == 'l') { /* lld */
5203 uv = va_arg(*args, int);
5205 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5207 eptr = (char*)utf8buf;
5208 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5212 c = va_arg(*args, int);
5214 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5221 eptr = va_arg(*args, char*);
5223 #ifdef MACOS_TRADITIONAL
5224 /* On MacOS, %#s format is used for Pascal strings */
5229 elen = strlen(eptr);
5232 elen = sizeof nullstr - 1;
5235 else if (svix < svmax) {
5236 eptr = SvPVx(svargs[svix++], elen);
5238 if (has_precis && precis < elen) {
5240 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5243 if (width) { /* fudge width (can't fudge elen) */
5244 width += elen - sv_len_utf8(svargs[svix - 1]);
5252 * The "%_" hack might have to be changed someday,
5253 * if ISO or ANSI decide to use '_' for something.
5254 * So we keep it hidden from users' code.
5258 eptr = SvPVx(va_arg(*args, SV*), elen);
5261 if (has_precis && elen > precis)
5269 uv = PTR2UV(va_arg(*args, void*));
5271 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5286 case 'h': iv = (short)va_arg(*args, int); break;
5287 default: iv = va_arg(*args, int); break;
5288 case 'l': iv = va_arg(*args, long); break;
5289 case 'V': iv = va_arg(*args, IV); break;
5291 case 'q': iv = va_arg(*args, Quad_t); break;
5296 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5298 case 'h': iv = (short)iv; break;
5299 default: iv = (int)iv; break;
5300 case 'l': iv = (long)iv; break;
5303 case 'q': iv = (Quad_t)iv; break;
5310 esignbuf[esignlen++] = plus;
5314 esignbuf[esignlen++] = '-';
5352 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5353 default: uv = va_arg(*args, unsigned); break;
5354 case 'l': uv = va_arg(*args, unsigned long); break;
5355 case 'V': uv = va_arg(*args, UV); break;
5357 case 'q': uv = va_arg(*args, Quad_t); break;
5362 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5364 case 'h': uv = (unsigned short)uv; break;
5365 default: uv = (unsigned)uv; break;
5366 case 'l': uv = (unsigned long)uv; break;
5369 case 'q': uv = (Quad_t)uv; break;
5375 eptr = ebuf + sizeof ebuf;
5381 p = (char*)((c == 'X')
5382 ? "0123456789ABCDEF" : "0123456789abcdef");
5388 esignbuf[esignlen++] = '0';
5389 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5395 *--eptr = '0' + dig;
5397 if (alt && *eptr != '0')
5403 *--eptr = '0' + dig;
5406 esignbuf[esignlen++] = '0';
5407 esignbuf[esignlen++] = 'b';
5410 default: /* it had better be ten or less */
5411 #if defined(PERL_Y2KWARN)
5412 if (ckWARN(WARN_MISC)) {
5414 char *s = SvPV(sv,n);
5415 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5416 && (n == 2 || !isDIGIT(s[n-3])))
5418 Perl_warner(aTHX_ WARN_MISC,
5419 "Possible Y2K bug: %%%c %s",
5420 c, "format string following '19'");
5426 *--eptr = '0' + dig;
5427 } while (uv /= base);
5430 elen = (ebuf + sizeof ebuf) - eptr;
5433 zeros = precis - elen;
5434 else if (precis == 0 && elen == 1 && *eptr == '0')
5439 /* FLOATING POINT */
5442 c = 'f'; /* maybe %F isn't supported here */
5448 /* This is evil, but floating point is even more evil */
5451 nv = va_arg(*args, NV);
5453 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5456 if (c != 'e' && c != 'E') {
5458 (void)frexp(nv, &i);
5459 if (i == PERL_INT_MIN)
5460 Perl_die(aTHX_ "panic: frexp");
5462 need = BIT_DIGITS(i);
5464 need += has_precis ? precis : 6; /* known default */
5468 need += 20; /* fudge factor */
5469 if (PL_efloatsize < need) {
5470 Safefree(PL_efloatbuf);
5471 PL_efloatsize = need + 20; /* more fudge */
5472 New(906, PL_efloatbuf, PL_efloatsize, char);
5473 PL_efloatbuf[0] = '\0';
5476 eptr = ebuf + sizeof ebuf;
5479 #ifdef USE_LONG_DOUBLE
5481 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5482 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5487 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5492 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5505 RESTORE_NUMERIC_STANDARD();
5506 (void)sprintf(PL_efloatbuf, eptr, nv);
5507 RESTORE_NUMERIC_LOCAL();
5510 eptr = PL_efloatbuf;
5511 elen = strlen(PL_efloatbuf);
5517 i = SvCUR(sv) - origlen;
5520 case 'h': *(va_arg(*args, short*)) = i; break;
5521 default: *(va_arg(*args, int*)) = i; break;
5522 case 'l': *(va_arg(*args, long*)) = i; break;
5523 case 'V': *(va_arg(*args, IV*)) = i; break;
5525 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5529 else if (svix < svmax)
5530 sv_setuv(svargs[svix++], (UV)i);
5531 continue; /* not "break" */
5537 if (!args && ckWARN(WARN_PRINTF) &&
5538 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5539 SV *msg = sv_newmortal();
5540 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5541 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5544 Perl_sv_catpvf(aTHX_ msg,
5545 "\"%%%c\"", c & 0xFF);
5547 Perl_sv_catpvf(aTHX_ msg,
5548 "\"%%\\%03"UVof"\"",
5551 sv_catpv(msg, "end of string");
5552 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5555 /* output mangled stuff ... */
5561 /* ... right here, because formatting flags should not apply */
5562 SvGROW(sv, SvCUR(sv) + elen + 1);
5564 memcpy(p, eptr, elen);
5567 SvCUR(sv) = p - SvPVX(sv);
5568 continue; /* not "break" */
5571 have = esignlen + zeros + elen;
5572 need = (have > width ? have : width);
5575 SvGROW(sv, SvCUR(sv) + need + 1);
5577 if (esignlen && fill == '0') {
5578 for (i = 0; i < esignlen; i++)
5582 memset(p, fill, gap);
5585 if (esignlen && fill != '0') {
5586 for (i = 0; i < esignlen; i++)
5590 for (i = zeros; i; i--)
5594 memcpy(p, eptr, elen);
5598 memset(p, ' ', gap);
5602 SvCUR(sv) = p - SvPVX(sv);
5606 #if defined(USE_ITHREADS)
5608 #if defined(USE_THREADS)
5609 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
5612 #ifndef OpREFCNT_inc
5613 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
5616 #ifndef GpREFCNT_inc
5617 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5621 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5622 #define av_dup(s) (AV*)sv_dup((SV*)s)
5623 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5624 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5625 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5626 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5627 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5628 #define io_dup(s) (IO*)sv_dup((SV*)s)
5629 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5630 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5631 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5632 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5633 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5636 Perl_re_dup(pTHX_ REGEXP *r)
5638 /* XXX fix when pmop->op_pmregexp becomes shared */
5639 return ReREFCNT_inc(r);
5643 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5646 return (PerlIO*)NULL;
5647 return fp; /* XXX */
5648 /* return PerlIO_fdopen(PerlIO_fileno(fp),
5649 type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5653 Perl_dirp_dup(pTHX_ DIR *dp)
5662 Perl_gp_dup(pTHX_ GP *gp)
5667 /* look for it in the table first */
5668 ret = ptr_table_fetch(PL_ptr_table, gp);
5672 /* create anew and remember what it is */
5673 Newz(0, ret, 1, GP);
5674 ptr_table_store(PL_ptr_table, gp, ret);
5677 ret->gp_refcnt = 0; /* must be before any other dups! */
5678 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5679 ret->gp_io = io_dup_inc(gp->gp_io);
5680 ret->gp_form = cv_dup_inc(gp->gp_form);
5681 ret->gp_av = av_dup_inc(gp->gp_av);
5682 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5683 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
5684 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5685 ret->gp_cvgen = gp->gp_cvgen;
5686 ret->gp_flags = gp->gp_flags;
5687 ret->gp_line = gp->gp_line;
5688 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5693 Perl_mg_dup(pTHX_ MAGIC *mg)
5695 MAGIC *mgret = (MAGIC*)NULL;
5698 return (MAGIC*)NULL;
5699 /* XXX need to handle aliases here? */
5701 for (; mg; mg = mg->mg_moremagic) {
5703 Newz(0, nmg, 1, MAGIC);
5707 mgprev->mg_moremagic = nmg;
5708 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5709 nmg->mg_private = mg->mg_private;
5710 nmg->mg_type = mg->mg_type;
5711 nmg->mg_flags = mg->mg_flags;
5712 if (mg->mg_type == 'r') {
5713 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5716 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5717 ? sv_dup_inc(mg->mg_obj)
5718 : sv_dup(mg->mg_obj);
5720 nmg->mg_len = mg->mg_len;
5721 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5722 if (mg->mg_ptr && mg->mg_type != 'g') {
5723 if (mg->mg_len >= 0) {
5724 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5725 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5726 AMT *amtp = (AMT*)mg->mg_ptr;
5727 AMT *namtp = (AMT*)nmg->mg_ptr;
5729 for (i = 1; i < NofAMmeth; i++) {
5730 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5734 else if (mg->mg_len == HEf_SVKEY)
5735 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5743 Perl_ptr_table_new(pTHX)
5746 Newz(0, tbl, 1, PTR_TBL_t);
5749 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5754 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5756 PTR_TBL_ENT_t *tblent;
5759 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5760 for (; tblent; tblent = tblent->next) {
5761 if (tblent->oldval == sv)
5762 return tblent->newval;
5768 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *old, void *new)
5770 PTR_TBL_ENT_t *tblent, **otblent;
5771 /* XXX this may be pessimal on platforms where pointers aren't good
5772 * hash values e.g. if they grow faster in the most significant
5778 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5779 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5780 if (tblent->oldval == old) {
5781 tblent->newval = new;
5786 Newz(0, tblent, 1, PTR_TBL_ENT_t);
5787 tblent->oldval = old;
5788 tblent->newval = new;
5789 tblent->next = *otblent;
5792 if (i && tbl->tbl_items > tbl->tbl_max)
5793 ptr_table_split(tbl);
5797 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5799 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5800 UV oldsize = tbl->tbl_max + 1;
5801 UV newsize = oldsize * 2;
5804 Renew(ary, newsize, PTR_TBL_ENT_t*);
5805 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5806 tbl->tbl_max = --newsize;
5808 for (i=0; i < oldsize; i++, ary++) {
5809 PTR_TBL_ENT_t **curentp, **entp, *ent;
5812 curentp = ary + oldsize;
5813 for (entp = ary, ent = *ary; ent; ent = *entp) {
5814 if ((newsize & (UV)ent->oldval) != i) {
5816 ent->next = *curentp;
5827 DllExport char *PL_watch_pvx;
5831 Perl_sv_dup(pTHX_ SV *sstr)
5838 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5840 /* look for it in the table first */
5841 dstr = ptr_table_fetch(PL_ptr_table, sstr);
5845 /* create anew and remember what it is */
5847 ptr_table_store(PL_ptr_table, sstr, dstr);
5850 SvFLAGS(dstr) = SvFLAGS(sstr);
5851 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5852 SvREFCNT(dstr) = 0; /* must be before any other dups! */
5855 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5856 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5857 PL_watch_pvx, SvPVX(sstr));
5860 switch (SvTYPE(sstr)) {
5865 SvANY(dstr) = new_XIV();
5866 SvIVX(dstr) = SvIVX(sstr);
5869 SvANY(dstr) = new_XNV();
5870 SvNVX(dstr) = SvNVX(sstr);
5873 SvANY(dstr) = new_XRV();
5874 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5877 SvANY(dstr) = new_XPV();
5878 SvCUR(dstr) = SvCUR(sstr);
5879 SvLEN(dstr) = SvLEN(sstr);
5881 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5882 else if (SvPVX(sstr) && SvLEN(sstr))
5883 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5885 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5888 SvANY(dstr) = new_XPVIV();
5889 SvCUR(dstr) = SvCUR(sstr);
5890 SvLEN(dstr) = SvLEN(sstr);
5891 SvIVX(dstr) = SvIVX(sstr);
5893 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5894 else if (SvPVX(sstr) && SvLEN(sstr))
5895 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5897 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5900 SvANY(dstr) = new_XPVNV();
5901 SvCUR(dstr) = SvCUR(sstr);
5902 SvLEN(dstr) = SvLEN(sstr);
5903 SvIVX(dstr) = SvIVX(sstr);
5904 SvNVX(dstr) = SvNVX(sstr);
5906 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5907 else if (SvPVX(sstr) && SvLEN(sstr))
5908 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5910 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5913 SvANY(dstr) = new_XPVMG();
5914 SvCUR(dstr) = SvCUR(sstr);
5915 SvLEN(dstr) = SvLEN(sstr);
5916 SvIVX(dstr) = SvIVX(sstr);
5917 SvNVX(dstr) = SvNVX(sstr);
5918 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5919 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5921 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5922 else if (SvPVX(sstr) && SvLEN(sstr))
5923 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5925 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5928 SvANY(dstr) = new_XPVBM();
5929 SvCUR(dstr) = SvCUR(sstr);
5930 SvLEN(dstr) = SvLEN(sstr);
5931 SvIVX(dstr) = SvIVX(sstr);
5932 SvNVX(dstr) = SvNVX(sstr);
5933 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5934 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5936 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5937 else if (SvPVX(sstr) && SvLEN(sstr))
5938 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5940 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5941 BmRARE(dstr) = BmRARE(sstr);
5942 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5943 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5946 SvANY(dstr) = new_XPVLV();
5947 SvCUR(dstr) = SvCUR(sstr);
5948 SvLEN(dstr) = SvLEN(sstr);
5949 SvIVX(dstr) = SvIVX(sstr);
5950 SvNVX(dstr) = SvNVX(sstr);
5951 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5952 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5954 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5955 else if (SvPVX(sstr) && SvLEN(sstr))
5956 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5958 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5959 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5960 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5961 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5962 LvTYPE(dstr) = LvTYPE(sstr);
5965 SvANY(dstr) = new_XPVGV();
5966 SvCUR(dstr) = SvCUR(sstr);
5967 SvLEN(dstr) = SvLEN(sstr);
5968 SvIVX(dstr) = SvIVX(sstr);
5969 SvNVX(dstr) = SvNVX(sstr);
5970 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5971 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5973 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5974 else if (SvPVX(sstr) && SvLEN(sstr))
5975 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5977 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5978 GvNAMELEN(dstr) = GvNAMELEN(sstr);
5979 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5980 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
5981 GvFLAGS(dstr) = GvFLAGS(sstr);
5982 GvGP(dstr) = gp_dup(GvGP(sstr));
5983 (void)GpREFCNT_inc(GvGP(dstr));
5986 SvANY(dstr) = new_XPVIO();
5987 SvCUR(dstr) = SvCUR(sstr);
5988 SvLEN(dstr) = SvLEN(sstr);
5989 SvIVX(dstr) = SvIVX(sstr);
5990 SvNVX(dstr) = SvNVX(sstr);
5991 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5992 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5995 else if (SvPVX(sstr) && SvLEN(sstr))
5996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5999 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6000 if (IoOFP(sstr) == IoIFP(sstr))
6001 IoOFP(dstr) = IoIFP(dstr);
6003 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6004 /* PL_rsfp_filters entries have fake IoDIRP() */
6005 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6006 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6008 IoDIRP(dstr) = IoDIRP(sstr);
6009 IoLINES(dstr) = IoLINES(sstr);
6010 IoPAGE(dstr) = IoPAGE(sstr);
6011 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6012 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6013 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6014 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6015 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6016 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6017 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6018 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6019 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6020 IoTYPE(dstr) = IoTYPE(sstr);
6021 IoFLAGS(dstr) = IoFLAGS(sstr);
6024 SvANY(dstr) = new_XPVAV();
6025 SvCUR(dstr) = SvCUR(sstr);
6026 SvLEN(dstr) = SvLEN(sstr);
6027 SvIVX(dstr) = SvIVX(sstr);
6028 SvNVX(dstr) = SvNVX(sstr);
6029 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6030 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6031 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6032 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6033 if (AvARRAY((AV*)sstr)) {
6034 SV **dst_ary, **src_ary;
6035 SSize_t items = AvFILLp((AV*)sstr) + 1;
6037 src_ary = AvARRAY((AV*)sstr);
6038 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6039 SvPVX(dstr) = (char*)dst_ary;
6040 AvALLOC((AV*)dstr) = dst_ary;
6041 if (AvREAL((AV*)sstr)) {
6043 *dst_ary++ = sv_dup_inc(*src_ary++);
6047 *dst_ary++ = sv_dup(*src_ary++);
6049 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6050 while (items-- > 0) {
6051 *dst_ary++ = &PL_sv_undef;
6055 SvPVX(dstr) = Nullch;
6056 AvALLOC((AV*)dstr) = (SV**)NULL;
6060 SvANY(dstr) = new_XPVHV();
6061 SvCUR(dstr) = SvCUR(sstr);
6062 SvLEN(dstr) = SvLEN(sstr);
6063 SvIVX(dstr) = SvIVX(sstr);
6064 SvNVX(dstr) = SvNVX(sstr);
6065 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6066 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6067 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6068 if (HvARRAY((HV*)sstr)) {
6071 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6072 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6073 Newz(0, dxhv->xhv_array,
6074 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6075 while (i <= sxhv->xhv_max) {
6076 HE *dentry, *oentry;
6077 entry = ((HE**)sxhv->xhv_array)[i];
6078 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6079 ((HE**)dxhv->xhv_array)[i] = dentry;
6081 entry = HeNEXT(entry);
6083 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6084 HeNEXT(oentry) = dentry;
6088 if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6089 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6090 while (entry && entry != sxhv->xhv_eiter)
6091 entry = HeNEXT(entry);
6092 dxhv->xhv_eiter = entry;
6095 dxhv->xhv_eiter = (HE*)NULL;
6098 SvPVX(dstr) = Nullch;
6099 HvEITER((HV*)dstr) = (HE*)NULL;
6101 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6102 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6105 SvANY(dstr) = new_XPVFM();
6106 FmLINES(dstr) = FmLINES(sstr);
6110 SvANY(dstr) = new_XPVCV();
6112 SvCUR(dstr) = SvCUR(sstr);
6113 SvLEN(dstr) = SvLEN(sstr);
6114 SvIVX(dstr) = SvIVX(sstr);
6115 SvNVX(dstr) = SvNVX(sstr);
6116 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6117 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6118 if (SvPVX(sstr) && SvLEN(sstr))
6119 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6121 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6122 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6123 CvSTART(dstr) = CvSTART(sstr);
6124 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6125 CvXSUB(dstr) = CvXSUB(sstr);
6126 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6127 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6128 CvDEPTH(dstr) = CvDEPTH(sstr);
6129 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6130 /* XXX padlists are real, but pretend to be not */
6131 AvREAL_on(CvPADLIST(sstr));
6132 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6133 AvREAL_off(CvPADLIST(sstr));
6134 AvREAL_off(CvPADLIST(dstr));
6137 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6138 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6139 CvFLAGS(dstr) = CvFLAGS(sstr);
6142 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6146 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6153 Perl_cx_dup(pTHX_ PERL_CONTEXT *cx, I32 ix, I32 max)
6158 return (PERL_CONTEXT*)NULL;
6160 /* look for it in the table first */
6161 ncx = ptr_table_fetch(PL_ptr_table, cx);
6165 /* create anew and remember what it is */
6166 Newz(56, ncx, max + 1, PERL_CONTEXT);
6167 ptr_table_store(PL_ptr_table, cx, ncx);
6176 Perl_si_dup(pTHX_ PERL_SI *si)
6181 return (PERL_SI*)NULL;
6183 /* look for it in the table first */
6184 nsi = ptr_table_fetch(PL_ptr_table, si);
6188 /* create anew and remember what it is */
6189 Newz(56, nsi, 1, PERL_SI);
6190 ptr_table_store(PL_ptr_table, si, nsi);
6192 nsi->si_stack = av_dup_inc(si->si_stack);
6193 nsi->si_cxix = si->si_cxix;
6194 nsi->si_cxmax = si->si_cxmax;
6195 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6196 nsi->si_type = si->si_type;
6197 nsi->si_prev = si_dup(si->si_prev);
6198 nsi->si_next = si_dup(si->si_next);
6199 nsi->si_markoff = si->si_markoff;
6205 Perl_ss_dup(pTHX_ ANY *ss, I32 ix, I32 max)
6212 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6213 struct IPerlMem* ipM, struct IPerlEnv* ipE,
6214 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6215 struct IPerlDir* ipD, struct IPerlSock* ipS,
6216 struct IPerlProc* ipP)
6221 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6222 PERL_SET_INTERP(my_perl);
6225 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6231 Zero(my_perl, 1, PerlInterpreter);
6233 Copy(proto_perl, my_perl, 1, PerlInterpreter);
6237 /* XXX many of the string copies here can be optimized if they're
6238 * constants; they need to be allocated as common memory and just
6239 * their pointers copied. */
6251 PL_xiv_arenaroot = NULL;
6256 PL_xpviv_root = NULL;
6257 PL_xpvnv_root = NULL;
6258 PL_xpvcv_root = NULL;
6259 PL_xpvav_root = NULL;
6260 PL_xpvhv_root = NULL;
6261 PL_xpvmg_root = NULL;
6262 PL_xpvlv_root = NULL;
6263 PL_xpvbm_root = NULL;
6265 PL_nice_chunk = NULL;
6266 PL_nice_chunk_size = 0;
6269 PL_sv_root = Nullsv;
6270 PL_sv_arenaroot = Nullsv;
6272 PL_debug = proto_perl->Idebug;
6274 /* create SV map for pointer relocation */
6275 PL_ptr_table = ptr_table_new();
6277 /* initialize these special pointers as early as possible */
6278 SvANY(&PL_sv_undef) = NULL;
6279 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6280 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6281 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6283 SvANY(&PL_sv_no) = new_XPVNV();
6284 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6285 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6286 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6287 SvCUR(&PL_sv_no) = 0;
6288 SvLEN(&PL_sv_no) = 1;
6289 SvNVX(&PL_sv_no) = 0;
6290 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6292 SvANY(&PL_sv_yes) = new_XPVNV();
6293 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6294 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6295 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6296 SvCUR(&PL_sv_yes) = 1;
6297 SvLEN(&PL_sv_yes) = 2;
6298 SvNVX(&PL_sv_yes) = 1;
6299 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6301 /* create shared string table */
6302 PL_strtab = newHV();
6303 HvSHAREKEYS_off(PL_strtab);
6304 hv_ksplit(PL_strtab, 512);
6305 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6307 PL_compiling = proto_perl->Icompiling;
6308 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6309 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6310 if (!specialWARN(PL_compiling.cop_warnings))
6311 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6312 if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6313 PL_curcop = &PL_compiling;
6315 PL_curcop = proto_perl->Tcurcop;
6317 /* pseudo environmental stuff */
6318 PL_origargc = proto_perl->Iorigargc;
6320 New(0, PL_origargv, i+1, char*);
6321 PL_origargv[i] = '\0';
6323 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6325 PL_envgv = gv_dup(proto_perl->Ienvgv);
6326 PL_incgv = gv_dup(proto_perl->Iincgv);
6327 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6328 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6329 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6330 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6333 PL_minus_c = proto_perl->Iminus_c;
6334 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6335 PL_localpatches = proto_perl->Ilocalpatches;
6336 PL_splitstr = proto_perl->Isplitstr;
6337 PL_preprocess = proto_perl->Ipreprocess;
6338 PL_minus_n = proto_perl->Iminus_n;
6339 PL_minus_p = proto_perl->Iminus_p;
6340 PL_minus_l = proto_perl->Iminus_l;
6341 PL_minus_a = proto_perl->Iminus_a;
6342 PL_minus_F = proto_perl->Iminus_F;
6343 PL_doswitches = proto_perl->Idoswitches;
6344 PL_dowarn = proto_perl->Idowarn;
6345 PL_doextract = proto_perl->Idoextract;
6346 PL_sawampersand = proto_perl->Isawampersand;
6347 PL_unsafe = proto_perl->Iunsafe;
6348 PL_inplace = SAVEPV(proto_perl->Iinplace);
6349 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6350 PL_perldb = proto_perl->Iperldb;
6351 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6353 /* magical thingies */
6354 /* XXX time(&PL_basetime) when asked for? */
6355 PL_basetime = proto_perl->Ibasetime;
6356 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6358 PL_maxsysfd = proto_perl->Imaxsysfd;
6359 PL_multiline = proto_perl->Imultiline;
6360 PL_statusvalue = proto_perl->Istatusvalue;
6362 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6365 /* shortcuts to various I/O objects */
6366 PL_stdingv = gv_dup(proto_perl->Istdingv);
6367 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6368 PL_defgv = gv_dup(proto_perl->Idefgv);
6369 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6370 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6371 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6373 /* shortcuts to regexp stuff */
6374 PL_replgv = gv_dup(proto_perl->Ireplgv);
6376 /* shortcuts to misc objects */
6377 PL_errgv = gv_dup(proto_perl->Ierrgv);
6379 /* shortcuts to debugging objects */
6380 PL_DBgv = gv_dup(proto_perl->IDBgv);
6381 PL_DBline = gv_dup(proto_perl->IDBline);
6382 PL_DBsub = gv_dup(proto_perl->IDBsub);
6383 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6384 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6385 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6386 PL_lineary = av_dup(proto_perl->Ilineary);
6387 PL_dbargs = av_dup(proto_perl->Idbargs);
6390 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6391 PL_curstash = hv_dup(proto_perl->Tcurstash);
6392 PL_debstash = hv_dup(proto_perl->Idebstash);
6393 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6394 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6396 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6397 PL_endav = av_dup_inc(proto_perl->Iendav);
6398 PL_stopav = av_dup_inc(proto_perl->Istopav);
6399 PL_initav = av_dup_inc(proto_perl->Iinitav);
6401 PL_sub_generation = proto_perl->Isub_generation;
6403 /* funky return mechanisms */
6404 PL_forkprocess = proto_perl->Iforkprocess;
6406 /* subprocess state */
6407 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6409 /* internal state */
6410 PL_tainting = proto_perl->Itainting;
6411 PL_maxo = proto_perl->Imaxo;
6412 if (proto_perl->Iop_mask)
6413 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6415 PL_op_mask = Nullch;
6417 /* current interpreter roots */
6418 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6419 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6420 PL_main_start = proto_perl->Imain_start;
6421 PL_eval_root = proto_perl->Ieval_root;
6422 PL_eval_start = proto_perl->Ieval_start;
6424 /* runtime control stuff */
6425 if (proto_perl->Icurcopdb == &proto_perl->Icompiling)
6426 PL_curcopdb = &PL_compiling;
6428 PL_curcopdb = proto_perl->Icurcopdb;
6429 PL_copline = proto_perl->Icopline;
6431 PL_filemode = proto_perl->Ifilemode;
6432 PL_lastfd = proto_perl->Ilastfd;
6433 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
6436 PL_gensym = proto_perl->Igensym;
6437 PL_preambled = proto_perl->Ipreambled;
6438 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6439 PL_laststatval = proto_perl->Ilaststatval;
6440 PL_laststype = proto_perl->Ilaststype;
6441 PL_mess_sv = Nullsv;
6443 PL_orslen = proto_perl->Iorslen;
6444 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6445 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6447 /* interpreter atexit processing */
6448 PL_exitlistlen = proto_perl->Iexitlistlen;
6449 if (PL_exitlistlen) {
6450 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6451 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6454 PL_exitlist = (PerlExitListEntry*)NULL;
6455 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6457 PL_profiledata = NULL;
6458 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6459 /* PL_rsfp_filters entries have fake IoDIRP() */
6460 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6462 PL_compcv = cv_dup(proto_perl->Icompcv);
6463 PL_comppad = av_dup(proto_perl->Icomppad);
6464 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6465 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6466 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6467 PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
6469 #ifdef HAVE_INTERP_INTERN
6470 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6473 /* more statics moved here */
6474 PL_generation = proto_perl->Igeneration;
6475 PL_DBcv = cv_dup(proto_perl->IDBcv);
6476 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6478 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6479 PL_in_clean_all = proto_perl->Iin_clean_all;
6481 PL_uid = proto_perl->Iuid;
6482 PL_euid = proto_perl->Ieuid;
6483 PL_gid = proto_perl->Igid;
6484 PL_egid = proto_perl->Iegid;
6485 PL_nomemok = proto_perl->Inomemok;
6486 PL_an = proto_perl->Ian;
6487 PL_cop_seqmax = proto_perl->Icop_seqmax;
6488 PL_op_seqmax = proto_perl->Iop_seqmax;
6489 PL_evalseq = proto_perl->Ievalseq;
6490 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
6491 PL_origalen = proto_perl->Iorigalen;
6492 PL_pidstatus = newHV(); /* XXX flag for cloning? */
6493 PL_osname = SAVEPV(proto_perl->Iosname);
6494 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6495 PL_sighandlerp = proto_perl->Isighandlerp;
6498 PL_runops = proto_perl->Irunops;
6500 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6503 PL_cshlen = proto_perl->Icshlen;
6504 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6507 PL_lex_state = proto_perl->Ilex_state;
6508 PL_lex_defer = proto_perl->Ilex_defer;
6509 PL_lex_expect = proto_perl->Ilex_expect;
6510 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6511 PL_lex_fakebrack = proto_perl->Ilex_fakebrack;
6512 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6513 PL_lex_starts = proto_perl->Ilex_starts;
6514 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
6515 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
6516 PL_lex_op = proto_perl->Ilex_op;
6517 PL_lex_inpat = proto_perl->Ilex_inpat;
6518 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6519 PL_lex_brackets = proto_perl->Ilex_brackets;
6520 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6521 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6522 PL_lex_casemods = proto_perl->Ilex_casemods;
6523 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6524 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6526 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6527 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6528 PL_nexttoke = proto_perl->Inexttoke;
6530 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6531 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6532 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6533 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6534 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6535 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6536 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6537 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6538 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6539 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6540 PL_pending_ident = proto_perl->Ipending_ident;
6541 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
6543 PL_expect = proto_perl->Iexpect;
6545 PL_multi_start = proto_perl->Imulti_start;
6546 PL_multi_end = proto_perl->Imulti_end;
6547 PL_multi_open = proto_perl->Imulti_open;
6548 PL_multi_close = proto_perl->Imulti_close;
6550 PL_error_count = proto_perl->Ierror_count;
6551 PL_subline = proto_perl->Isubline;
6552 PL_subname = sv_dup_inc(proto_perl->Isubname);
6554 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6555 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6556 PL_padix = proto_perl->Ipadix;
6557 PL_padix_floor = proto_perl->Ipadix_floor;
6558 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6560 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6561 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6562 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6563 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6564 PL_last_lop_op = proto_perl->Ilast_lop_op;
6565 PL_in_my = proto_perl->Iin_my;
6566 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6568 PL_cryptseen = proto_perl->Icryptseen;
6571 PL_hints = proto_perl->Ihints;
6573 PL_amagic_generation = proto_perl->Iamagic_generation;
6575 #ifdef USE_LOCALE_COLLATE
6576 PL_collation_ix = proto_perl->Icollation_ix;
6577 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6578 PL_collation_standard = proto_perl->Icollation_standard;
6579 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6580 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6581 #endif /* USE_LOCALE_COLLATE */
6583 #ifdef USE_LOCALE_NUMERIC
6584 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6585 PL_numeric_standard = proto_perl->Inumeric_standard;
6586 PL_numeric_local = proto_perl->Inumeric_local;
6587 PL_numeric_radix = proto_perl->Inumeric_radix;
6588 #endif /* !USE_LOCALE_NUMERIC */
6590 /* utf8 character classes */
6591 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6592 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6593 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6594 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6595 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6596 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6597 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6598 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6599 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6600 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6601 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6602 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6603 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6604 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6605 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6606 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6607 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6610 PL_last_swash_hv = Nullhv; /* reinits on demand */
6611 PL_last_swash_klen = 0;
6612 PL_last_swash_key[0]= '\0';
6613 PL_last_swash_tmps = Nullch;
6614 PL_last_swash_slen = 0;
6616 /* perly.c globals */
6617 PL_yydebug = proto_perl->Iyydebug;
6618 PL_yynerrs = proto_perl->Iyynerrs;
6619 PL_yyerrflag = proto_perl->Iyyerrflag;
6620 PL_yychar = proto_perl->Iyychar;
6621 PL_yyval = proto_perl->Iyyval;
6622 PL_yylval = proto_perl->Iyylval;
6624 PL_glob_index = proto_perl->Iglob_index;
6625 PL_srand_called = proto_perl->Isrand_called;
6626 PL_uudmap['M'] = 0; /* reinits on demand */
6627 PL_bitcount = Nullch; /* reinits on demand */
6630 /* thrdvar.h stuff */
6633 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
6634 PL_tmps_ix = proto_perl->Ttmps_ix;
6635 PL_tmps_max = proto_perl->Ttmps_max;
6636 PL_tmps_floor = proto_perl->Ttmps_floor;
6637 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
6639 while (i <= PL_tmps_ix) {
6640 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
6644 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
6645 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
6646 Newz(54, PL_markstack, i, I32);
6647 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
6648 - proto_perl->Tmarkstack);
6649 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
6650 - proto_perl->Tmarkstack);
6651 Copy(proto_perl->Tmarkstack, PL_markstack,
6652 PL_markstack_ptr - PL_markstack + 1, I32);
6654 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
6655 * NOTE: unlike the others! */
6656 PL_scopestack_ix = proto_perl->Tscopestack_ix;
6657 PL_scopestack_max = proto_perl->Tscopestack_max;
6658 Newz(54, PL_scopestack, PL_scopestack_max, I32);
6659 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
6661 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
6662 * NOTE: unlike the others! */
6663 PL_savestack_ix = proto_perl->Tsavestack_ix;
6664 PL_savestack_max = proto_perl->Tsavestack_max;
6665 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
6666 PL_savestack = ss_dup(proto_perl->Tsavestack,
6670 /* next push_return() sets PL_retstack[PL_retstack_ix]
6671 * NOTE: unlike the others! */
6672 PL_retstack_ix = proto_perl->Tretstack_ix;
6673 PL_retstack_max = proto_perl->Tretstack_max;
6674 Newz(54, PL_retstack, PL_retstack_max, OP*);
6675 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
6677 /* NOTE: si_dup() looks at PL_markstack */
6678 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
6680 /* PL_curstack = PL_curstackinfo->si_stack; */
6681 PL_curstack = av_dup(proto_perl->Tcurstack);
6682 PL_mainstack = av_dup(proto_perl->Tmainstack);
6684 /* next PUSHs() etc. set *(PL_stack_sp+1) */
6685 PL_stack_base = AvARRAY(PL_curstack);
6686 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
6687 - proto_perl->Tstack_base);
6688 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
6694 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
6695 PL_top_env = &PL_start_env;
6697 PL_op = proto_perl->Top;
6700 PL_Xpv = (XPV*)NULL;
6701 PL_na = proto_perl->Tna;
6703 PL_statbuf = proto_perl->Tstatbuf;
6704 PL_statcache = proto_perl->Tstatcache;
6705 PL_statgv = gv_dup(proto_perl->Tstatgv);
6706 PL_statname = sv_dup_inc(proto_perl->Tstatname);
6708 PL_timesbuf = proto_perl->Ttimesbuf;
6711 PL_tainted = proto_perl->Ttainted;
6712 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
6713 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
6714 PL_rs = sv_dup_inc(proto_perl->Trs);
6715 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
6716 PL_ofslen = proto_perl->Tofslen;
6717 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6718 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
6719 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
6720 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
6721 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
6722 PL_formtarget = sv_dup(proto_perl->Tformtarget);
6724 PL_restartop = proto_perl->Trestartop;
6725 PL_in_eval = proto_perl->Tin_eval;
6726 PL_delaymagic = proto_perl->Tdelaymagic;
6727 PL_dirty = proto_perl->Tdirty;
6728 PL_localizing = proto_perl->Tlocalizing;
6730 PL_protect = proto_perl->Tprotect;
6731 PL_errors = sv_dup_inc(proto_perl->Terrors);
6732 PL_av_fetch_sv = Nullsv;
6733 PL_hv_fetch_sv = Nullsv;
6734 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
6735 PL_modcount = proto_perl->Tmodcount;
6736 PL_lastgotoprobe = Nullop;
6737 PL_dumpindent = proto_perl->Tdumpindent;
6739 if (proto_perl->Tsortcop == (OP*)&proto_perl->Icompiling)
6740 PL_sortcop = (OP*)&PL_compiling;
6742 PL_sortcop = proto_perl->Tsortcop;
6743 PL_sortstash = hv_dup(proto_perl->Tsortstash);
6744 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
6745 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
6746 PL_sortcxix = proto_perl->Tsortcxix;
6747 PL_efloatbuf = Nullch; /* reinits on demand */
6748 PL_efloatsize = 0; /* reinits on demand */
6752 PL_screamfirst = NULL;
6753 PL_screamnext = NULL;
6754 PL_maxscream = -1; /* reinits on demand */
6755 PL_lastscream = Nullsv;
6757 PL_watchaddr = NULL;
6758 PL_watchok = Nullch;
6760 PL_regdummy = proto_perl->Tregdummy;
6761 PL_regcomp_parse = Nullch;
6762 PL_regxend = Nullch;
6763 PL_regcode = (regnode*)NULL;
6766 PL_regprecomp = Nullch;
6771 PL_seen_zerolen = 0;
6773 PL_regcomp_rx = (regexp*)NULL;
6775 PL_colorset = 0; /* reinits PL_colors[] */
6776 /*PL_colors[6] = {0,0,0,0,0,0};*/
6777 PL_reg_whilem_seen = 0;
6778 PL_reginput = Nullch;
6781 PL_regstartp = (I32*)NULL;
6782 PL_regendp = (I32*)NULL;
6783 PL_reglastparen = (U32*)NULL;
6784 PL_regtill = Nullch;
6786 PL_reg_start_tmp = (char**)NULL;
6787 PL_reg_start_tmpl = 0;
6788 PL_regdata = (struct reg_data*)NULL;
6791 PL_reg_eval_set = 0;
6793 PL_regprogram = (regnode*)NULL;
6795 PL_regcc = (CURCUR*)NULL;
6796 PL_reg_call_cc = (struct re_cc_state*)NULL;
6797 PL_reg_re = (regexp*)NULL;
6798 PL_reg_ganch = Nullch;
6800 PL_reg_magic = (MAGIC*)NULL;
6802 PL_reg_oldcurpm = (PMOP*)NULL;
6803 PL_reg_curpm = (PMOP*)NULL;
6804 PL_reg_oldsaved = Nullch;
6805 PL_reg_oldsavedlen = 0;
6807 PL_reg_leftiter = 0;
6808 PL_reg_poscache = Nullch;
6809 PL_reg_poscache_size= 0;
6811 /* RE engine - function pointers */
6812 PL_regcompp = proto_perl->Tregcompp;
6813 PL_regexecp = proto_perl->Tregexecp;
6814 PL_regint_start = proto_perl->Tregint_start;
6815 PL_regint_string = proto_perl->Tregint_string;
6816 PL_regfree = proto_perl->Tregfree;
6818 PL_reginterp_cnt = 0;
6819 PL_reg_starttry = 0;
6825 perl_clone(pTHXx_ UV flags)
6827 return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6828 PL_Dir, PL_Sock, PL_Proc);
6831 #endif /* USE_ITHREADS */
6838 do_report_used(pTHXo_ SV *sv)
6840 if (SvTYPE(sv) != SVTYPEMASK) {
6841 PerlIO_printf(Perl_debug_log, "****\n");
6847 do_clean_objs(pTHXo_ SV *sv)
6851 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6852 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6858 /* XXX Might want to check arrays, etc. */
6861 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6863 do_clean_named_objs(pTHXo_ SV *sv)
6865 if (SvTYPE(sv) == SVt_PVGV) {
6866 if ( SvOBJECT(GvSV(sv)) ||
6867 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6868 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6869 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6870 GvCV(sv) && SvOBJECT(GvCV(sv)) )
6872 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6880 do_clean_all(pTHXo_ SV *sv)
6882 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6883 SvFLAGS(sv) |= SVf_BREAK;