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)
5647 return (PerlIO*)NULL;
5649 /* look for it in the table first */
5650 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
5654 /* create anew and remember what it is */
5655 ret = PerlIO_fdupopen(fp);
5656 ptr_table_store(PL_ptr_table, fp, ret);
5661 Perl_dirp_dup(pTHX_ DIR *dp)
5670 Perl_gp_dup(pTHX_ GP *gp)
5675 /* look for it in the table first */
5676 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
5680 /* create anew and remember what it is */
5681 Newz(0, ret, 1, GP);
5682 ptr_table_store(PL_ptr_table, gp, ret);
5685 ret->gp_refcnt = 0; /* must be before any other dups! */
5686 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5687 ret->gp_io = io_dup_inc(gp->gp_io);
5688 ret->gp_form = cv_dup_inc(gp->gp_form);
5689 ret->gp_av = av_dup_inc(gp->gp_av);
5690 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5691 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
5692 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5693 ret->gp_cvgen = gp->gp_cvgen;
5694 ret->gp_flags = gp->gp_flags;
5695 ret->gp_line = gp->gp_line;
5696 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5701 Perl_mg_dup(pTHX_ MAGIC *mg)
5703 MAGIC *mgret = (MAGIC*)NULL;
5706 return (MAGIC*)NULL;
5707 /* look for it in the table first */
5708 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
5712 for (; mg; mg = mg->mg_moremagic) {
5714 Newz(0, nmg, 1, MAGIC);
5718 mgprev->mg_moremagic = nmg;
5719 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5720 nmg->mg_private = mg->mg_private;
5721 nmg->mg_type = mg->mg_type;
5722 nmg->mg_flags = mg->mg_flags;
5723 if (mg->mg_type == 'r') {
5724 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5727 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5728 ? sv_dup_inc(mg->mg_obj)
5729 : sv_dup(mg->mg_obj);
5731 nmg->mg_len = mg->mg_len;
5732 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5733 if (mg->mg_ptr && mg->mg_type != 'g') {
5734 if (mg->mg_len >= 0) {
5735 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5736 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5737 AMT *amtp = (AMT*)mg->mg_ptr;
5738 AMT *namtp = (AMT*)nmg->mg_ptr;
5740 for (i = 1; i < NofAMmeth; i++) {
5741 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5745 else if (mg->mg_len == HEf_SVKEY)
5746 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5754 Perl_ptr_table_new(pTHX)
5757 Newz(0, tbl, 1, PTR_TBL_t);
5760 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5765 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5767 PTR_TBL_ENT_t *tblent;
5770 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5771 for (; tblent; tblent = tblent->next) {
5772 if (tblent->oldval == sv)
5773 return tblent->newval;
5779 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
5781 PTR_TBL_ENT_t *tblent, **otblent;
5782 /* XXX this may be pessimal on platforms where pointers aren't good
5783 * hash values e.g. if they grow faster in the most significant
5789 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5790 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5791 if (tblent->oldval == oldv) {
5792 tblent->newval = newv;
5797 Newz(0, tblent, 1, PTR_TBL_ENT_t);
5798 tblent->oldval = oldv;
5799 tblent->newval = newv;
5800 tblent->next = *otblent;
5803 if (i && tbl->tbl_items > tbl->tbl_max)
5804 ptr_table_split(tbl);
5808 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5810 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5811 UV oldsize = tbl->tbl_max + 1;
5812 UV newsize = oldsize * 2;
5815 Renew(ary, newsize, PTR_TBL_ENT_t*);
5816 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5817 tbl->tbl_max = --newsize;
5819 for (i=0; i < oldsize; i++, ary++) {
5820 PTR_TBL_ENT_t **curentp, **entp, *ent;
5823 curentp = ary + oldsize;
5824 for (entp = ary, ent = *ary; ent; ent = *entp) {
5825 if ((newsize & (UV)ent->oldval) != i) {
5827 ent->next = *curentp;
5842 Perl_sv_dup(pTHX_ SV *sstr)
5849 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5851 /* look for it in the table first */
5852 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
5856 /* create anew and remember what it is */
5858 ptr_table_store(PL_ptr_table, sstr, dstr);
5861 SvFLAGS(dstr) = SvFLAGS(sstr);
5862 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5863 SvREFCNT(dstr) = 0; /* must be before any other dups! */
5866 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5867 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5868 PL_watch_pvx, SvPVX(sstr));
5871 switch (SvTYPE(sstr)) {
5876 SvANY(dstr) = new_XIV();
5877 SvIVX(dstr) = SvIVX(sstr);
5880 SvANY(dstr) = new_XNV();
5881 SvNVX(dstr) = SvNVX(sstr);
5884 SvANY(dstr) = new_XRV();
5885 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5888 SvANY(dstr) = new_XPV();
5889 SvCUR(dstr) = SvCUR(sstr);
5890 SvLEN(dstr) = SvLEN(sstr);
5892 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5893 else if (SvPVX(sstr) && SvLEN(sstr))
5894 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5896 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5899 SvANY(dstr) = new_XPVIV();
5900 SvCUR(dstr) = SvCUR(sstr);
5901 SvLEN(dstr) = SvLEN(sstr);
5902 SvIVX(dstr) = SvIVX(sstr);
5904 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5905 else if (SvPVX(sstr) && SvLEN(sstr))
5906 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5908 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5911 SvANY(dstr) = new_XPVNV();
5912 SvCUR(dstr) = SvCUR(sstr);
5913 SvLEN(dstr) = SvLEN(sstr);
5914 SvIVX(dstr) = SvIVX(sstr);
5915 SvNVX(dstr) = SvNVX(sstr);
5917 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5918 else if (SvPVX(sstr) && SvLEN(sstr))
5919 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5921 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5924 SvANY(dstr) = new_XPVMG();
5925 SvCUR(dstr) = SvCUR(sstr);
5926 SvLEN(dstr) = SvLEN(sstr);
5927 SvIVX(dstr) = SvIVX(sstr);
5928 SvNVX(dstr) = SvNVX(sstr);
5929 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5930 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5932 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5933 else if (SvPVX(sstr) && SvLEN(sstr))
5934 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5936 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5939 SvANY(dstr) = new_XPVBM();
5940 SvCUR(dstr) = SvCUR(sstr);
5941 SvLEN(dstr) = SvLEN(sstr);
5942 SvIVX(dstr) = SvIVX(sstr);
5943 SvNVX(dstr) = SvNVX(sstr);
5944 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5945 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5947 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5948 else if (SvPVX(sstr) && SvLEN(sstr))
5949 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5951 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5952 BmRARE(dstr) = BmRARE(sstr);
5953 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5954 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5957 SvANY(dstr) = new_XPVLV();
5958 SvCUR(dstr) = SvCUR(sstr);
5959 SvLEN(dstr) = SvLEN(sstr);
5960 SvIVX(dstr) = SvIVX(sstr);
5961 SvNVX(dstr) = SvNVX(sstr);
5962 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5963 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5965 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5966 else if (SvPVX(sstr) && SvLEN(sstr))
5967 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5969 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5970 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5971 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5972 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5973 LvTYPE(dstr) = LvTYPE(sstr);
5976 SvANY(dstr) = new_XPVGV();
5977 SvCUR(dstr) = SvCUR(sstr);
5978 SvLEN(dstr) = SvLEN(sstr);
5979 SvIVX(dstr) = SvIVX(sstr);
5980 SvNVX(dstr) = SvNVX(sstr);
5981 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5982 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5984 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5985 else if (SvPVX(sstr) && SvLEN(sstr))
5986 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5988 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5989 GvNAMELEN(dstr) = GvNAMELEN(sstr);
5990 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5991 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
5992 GvFLAGS(dstr) = GvFLAGS(sstr);
5993 GvGP(dstr) = gp_dup(GvGP(sstr));
5994 (void)GpREFCNT_inc(GvGP(dstr));
5997 SvANY(dstr) = new_XPVIO();
5998 SvCUR(dstr) = SvCUR(sstr);
5999 SvLEN(dstr) = SvLEN(sstr);
6000 SvIVX(dstr) = SvIVX(sstr);
6001 SvNVX(dstr) = SvNVX(sstr);
6002 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6003 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6005 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6006 else if (SvPVX(sstr) && SvLEN(sstr))
6007 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6009 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6010 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6011 if (IoOFP(sstr) == IoIFP(sstr))
6012 IoOFP(dstr) = IoIFP(dstr);
6014 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6015 /* PL_rsfp_filters entries have fake IoDIRP() */
6016 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6017 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6019 IoDIRP(dstr) = IoDIRP(sstr);
6020 IoLINES(dstr) = IoLINES(sstr);
6021 IoPAGE(dstr) = IoPAGE(sstr);
6022 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6023 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6024 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6025 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6026 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6027 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6028 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6029 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6030 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6031 IoTYPE(dstr) = IoTYPE(sstr);
6032 IoFLAGS(dstr) = IoFLAGS(sstr);
6035 SvANY(dstr) = new_XPVAV();
6036 SvCUR(dstr) = SvCUR(sstr);
6037 SvLEN(dstr) = SvLEN(sstr);
6038 SvIVX(dstr) = SvIVX(sstr);
6039 SvNVX(dstr) = SvNVX(sstr);
6040 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6041 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6042 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6043 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6044 if (AvARRAY((AV*)sstr)) {
6045 SV **dst_ary, **src_ary;
6046 SSize_t items = AvFILLp((AV*)sstr) + 1;
6048 src_ary = AvARRAY((AV*)sstr);
6049 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6050 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6051 SvPVX(dstr) = (char*)dst_ary;
6052 AvALLOC((AV*)dstr) = dst_ary;
6053 if (AvREAL((AV*)sstr)) {
6055 *dst_ary++ = sv_dup_inc(*src_ary++);
6059 *dst_ary++ = sv_dup(*src_ary++);
6061 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6062 while (items-- > 0) {
6063 *dst_ary++ = &PL_sv_undef;
6067 SvPVX(dstr) = Nullch;
6068 AvALLOC((AV*)dstr) = (SV**)NULL;
6072 SvANY(dstr) = new_XPVHV();
6073 SvCUR(dstr) = SvCUR(sstr);
6074 SvLEN(dstr) = SvLEN(sstr);
6075 SvIVX(dstr) = SvIVX(sstr);
6076 SvNVX(dstr) = SvNVX(sstr);
6077 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6078 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6079 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6080 if (HvARRAY((HV*)sstr)) {
6083 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6084 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6085 Newz(0, dxhv->xhv_array,
6086 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6087 while (i <= sxhv->xhv_max) {
6088 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6089 !!HvSHAREKEYS(sstr));
6092 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6095 SvPVX(dstr) = Nullch;
6096 HvEITER((HV*)dstr) = (HE*)NULL;
6098 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6099 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6102 SvANY(dstr) = new_XPVFM();
6103 FmLINES(dstr) = FmLINES(sstr);
6107 SvANY(dstr) = new_XPVCV();
6109 SvCUR(dstr) = SvCUR(sstr);
6110 SvLEN(dstr) = SvLEN(sstr);
6111 SvIVX(dstr) = SvIVX(sstr);
6112 SvNVX(dstr) = SvNVX(sstr);
6113 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6114 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6115 if (SvPVX(sstr) && SvLEN(sstr))
6116 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6118 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6119 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6120 CvSTART(dstr) = CvSTART(sstr);
6121 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6122 CvXSUB(dstr) = CvXSUB(sstr);
6123 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6124 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6125 CvDEPTH(dstr) = CvDEPTH(sstr);
6126 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6127 /* XXX padlists are real, but pretend to be not */
6128 AvREAL_on(CvPADLIST(sstr));
6129 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6130 AvREAL_off(CvPADLIST(sstr));
6131 AvREAL_off(CvPADLIST(dstr));
6134 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6135 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6136 CvFLAGS(dstr) = CvFLAGS(sstr);
6139 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6143 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6150 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6155 return (PERL_CONTEXT*)NULL;
6157 /* look for it in the table first */
6158 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6162 /* create anew and remember what it is */
6163 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6164 ptr_table_store(PL_ptr_table, cxs, ncxs);
6167 PERL_CONTEXT *cx = &cxs[ix];
6168 PERL_CONTEXT *ncx = &ncxs[ix];
6169 ncx->cx_type = cx->cx_type;
6170 if (CxTYPE(cx) == CXt_SUBST) {
6171 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6174 ncx->blk_oldsp = cx->blk_oldsp;
6175 ncx->blk_oldcop = cx->blk_oldcop;
6176 ncx->blk_oldretsp = cx->blk_oldretsp;
6177 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6178 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6179 ncx->blk_oldpm = cx->blk_oldpm;
6180 ncx->blk_gimme = cx->blk_gimme;
6181 switch (CxTYPE(cx)) {
6183 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6184 ? cv_dup_inc(cx->blk_sub.cv)
6185 : cv_dup(cx->blk_sub.cv));
6186 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6187 ? av_dup_inc(cx->blk_sub.argarray)
6189 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6190 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6191 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6192 ncx->blk_sub.lval = cx->blk_sub.lval;
6195 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6196 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6197 ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
6198 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6199 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6202 ncx->blk_loop.label = cx->blk_loop.label;
6203 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6204 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6205 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6206 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6207 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6208 ? cx->blk_loop.iterdata
6209 : gv_dup((GV*)cx->blk_loop.iterdata));
6210 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6211 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6212 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6213 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6214 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6217 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6218 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6219 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6220 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6233 Perl_si_dup(pTHX_ PERL_SI *si)
6238 return (PERL_SI*)NULL;
6240 /* look for it in the table first */
6241 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6245 /* create anew and remember what it is */
6246 Newz(56, nsi, 1, PERL_SI);
6247 ptr_table_store(PL_ptr_table, si, nsi);
6249 nsi->si_stack = av_dup_inc(si->si_stack);
6250 nsi->si_cxix = si->si_cxix;
6251 nsi->si_cxmax = si->si_cxmax;
6252 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6253 nsi->si_type = si->si_type;
6254 nsi->si_prev = si_dup(si->si_prev);
6255 nsi->si_next = si_dup(si->si_next);
6256 nsi->si_markoff = si->si_markoff;
6261 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6262 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6263 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6264 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6265 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6266 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6267 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6268 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6269 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6270 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6271 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6272 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6275 #define pv_dup_inc(p) SAVEPV(p)
6276 #define pv_dup(p) SAVEPV(p)
6277 #define svp_dup_inc(p,pp) any_dup(p,pp)
6280 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6287 /* look for it in the table first */
6288 ret = ptr_table_fetch(PL_ptr_table, v);
6292 /* see if it is part of the interpreter structure */
6293 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6294 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6302 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6304 ANY *ss = proto_perl->Tsavestack;
6305 I32 ix = proto_perl->Tsavestack_ix;
6306 I32 max = proto_perl->Tsavestack_max;
6319 void (*dptr) (void*);
6320 void (*dxptr) (pTHXo_ void*);
6322 Newz(54, nss, max, ANY);
6328 case SAVEt_ITEM: /* normal string */
6329 sv = (SV*)POPPTR(ss,ix);
6330 TOPPTR(nss,ix) = sv_dup_inc(sv);
6331 sv = (SV*)POPPTR(ss,ix);
6332 TOPPTR(nss,ix) = sv_dup_inc(sv);
6334 case SAVEt_SV: /* scalar reference */
6335 sv = (SV*)POPPTR(ss,ix);
6336 TOPPTR(nss,ix) = sv_dup_inc(sv);
6337 gv = (GV*)POPPTR(ss,ix);
6338 TOPPTR(nss,ix) = gv_dup_inc(gv);
6340 case SAVEt_GENERIC_SVREF: /* generic sv */
6341 case SAVEt_SVREF: /* scalar reference */
6342 sv = (SV*)POPPTR(ss,ix);
6343 TOPPTR(nss,ix) = sv_dup_inc(sv);
6344 ptr = POPPTR(ss,ix);
6345 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6347 case SAVEt_AV: /* array reference */
6348 av = (AV*)POPPTR(ss,ix);
6349 TOPPTR(nss,ix) = av_dup_inc(av);
6350 gv = (GV*)POPPTR(ss,ix);
6351 TOPPTR(nss,ix) = gv_dup(gv);
6353 case SAVEt_HV: /* hash reference */
6354 hv = (HV*)POPPTR(ss,ix);
6355 TOPPTR(nss,ix) = hv_dup_inc(hv);
6356 gv = (GV*)POPPTR(ss,ix);
6357 TOPPTR(nss,ix) = gv_dup(gv);
6359 case SAVEt_INT: /* int reference */
6360 ptr = POPPTR(ss,ix);
6361 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6362 intval = (int)POPINT(ss,ix);
6363 TOPINT(nss,ix) = intval;
6365 case SAVEt_LONG: /* long reference */
6366 ptr = POPPTR(ss,ix);
6367 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6368 longval = (long)POPLONG(ss,ix);
6369 TOPLONG(nss,ix) = longval;
6371 case SAVEt_I32: /* I32 reference */
6372 ptr = POPPTR(ss,ix);
6373 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6377 case SAVEt_I16: /* I16 reference */
6378 ptr = POPPTR(ss,ix);
6379 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6383 case SAVEt_IV: /* IV reference */
6384 ptr = POPPTR(ss,ix);
6385 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6389 case SAVEt_SPTR: /* SV* reference */
6390 ptr = POPPTR(ss,ix);
6391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6392 sv = (SV*)POPPTR(ss,ix);
6393 TOPPTR(nss,ix) = sv_dup(sv);
6395 case SAVEt_VPTR: /* random* reference */
6396 ptr = POPPTR(ss,ix);
6397 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6398 ptr = POPPTR(ss,ix);
6399 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6401 case SAVEt_PPTR: /* char* reference */
6402 ptr = POPPTR(ss,ix);
6403 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6404 c = (char*)POPPTR(ss,ix);
6405 TOPPTR(nss,ix) = pv_dup(c);
6407 case SAVEt_HPTR: /* HV* reference */
6408 ptr = POPPTR(ss,ix);
6409 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6410 hv = (HV*)POPPTR(ss,ix);
6411 TOPPTR(nss,ix) = hv_dup(hv);
6413 case SAVEt_APTR: /* AV* reference */
6414 ptr = POPPTR(ss,ix);
6415 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6416 av = (AV*)POPPTR(ss,ix);
6417 TOPPTR(nss,ix) = av_dup(av);
6420 gv = (GV*)POPPTR(ss,ix);
6421 TOPPTR(nss,ix) = gv_dup(gv);
6423 case SAVEt_GP: /* scalar reference */
6424 gp = (GP*)POPPTR(ss,ix);
6425 TOPPTR(nss,ix) = gp = gp_dup(gp);
6426 (void)GpREFCNT_inc(gp);
6427 gv = (GV*)POPPTR(ss,ix);
6428 TOPPTR(nss,ix) = gv_dup_inc(c);
6429 c = (char*)POPPTR(ss,ix);
6430 TOPPTR(nss,ix) = pv_dup(c);
6437 sv = (SV*)POPPTR(ss,ix);
6438 TOPPTR(nss,ix) = sv_dup_inc(sv);
6441 ptr = POPPTR(ss,ix);
6442 TOPPTR(nss,ix) = ptr;
6445 c = (char*)POPPTR(ss,ix);
6446 TOPPTR(nss,ix) = pv_dup_inc(c);
6449 longval = POPLONG(ss,ix);
6450 TOPLONG(nss,ix) = longval;
6453 hv = (HV*)POPPTR(ss,ix);
6454 TOPPTR(nss,ix) = hv_dup_inc(hv);
6455 c = (char*)POPPTR(ss,ix);
6456 TOPPTR(nss,ix) = pv_dup_inc(c);
6460 case SAVEt_DESTRUCTOR:
6461 ptr = POPPTR(ss,ix);
6462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6463 dptr = POPDPTR(ss,ix);
6464 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
6466 case SAVEt_DESTRUCTOR_X:
6467 ptr = POPPTR(ss,ix);
6468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6469 dxptr = POPDXPTR(ss,ix);
6470 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
6472 case SAVEt_REGCONTEXT:
6478 case SAVEt_STACK_POS: /* Position on Perl stack */
6482 case SAVEt_AELEM: /* array element */
6483 sv = (SV*)POPPTR(ss,ix);
6484 TOPPTR(nss,ix) = sv_dup_inc(sv);
6487 av = (AV*)POPPTR(ss,ix);
6488 TOPPTR(nss,ix) = av_dup_inc(av);
6490 case SAVEt_HELEM: /* hash element */
6491 sv = (SV*)POPPTR(ss,ix);
6492 TOPPTR(nss,ix) = sv_dup_inc(sv);
6493 sv = (SV*)POPPTR(ss,ix);
6494 TOPPTR(nss,ix) = sv_dup_inc(sv);
6495 hv = (HV*)POPPTR(ss,ix);
6496 TOPPTR(nss,ix) = hv_dup_inc(hv);
6499 ptr = POPPTR(ss,ix);
6500 TOPPTR(nss,ix) = ptr;
6507 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
6519 perl_clone(PerlInterpreter *my_perl, UV flags)
6522 CPerlObj *pPerl = (CPerlObj*)my_perl;
6524 return perl_clone_using(my_perl, flags, PL_Mem, PL_MemShared, PL_MemParse,
6525 PL_Env, PL_StdIO, PL_LIO, PL_Dir, PL_Sock, PL_Proc);
6529 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6530 struct IPerlMem* ipM, struct IPerlMem* ipMS,
6531 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
6532 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6533 struct IPerlDir* ipD, struct IPerlSock* ipS,
6534 struct IPerlProc* ipP)
6536 /* XXX many of the string copies here can be optimized if they're
6537 * constants; they need to be allocated as common memory and just
6538 * their pointers copied. */
6544 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
6546 PERL_SET_INTERP(pPerl);
6548 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6549 PERL_SET_INTERP(my_perl);
6552 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6558 Zero(my_perl, 1, PerlInterpreter);
6563 PL_MemShared = ipMS;
6574 PL_xiv_arenaroot = NULL;
6579 PL_xpviv_root = NULL;
6580 PL_xpvnv_root = NULL;
6581 PL_xpvcv_root = NULL;
6582 PL_xpvav_root = NULL;
6583 PL_xpvhv_root = NULL;
6584 PL_xpvmg_root = NULL;
6585 PL_xpvlv_root = NULL;
6586 PL_xpvbm_root = NULL;
6588 PL_nice_chunk = NULL;
6589 PL_nice_chunk_size = 0;
6592 PL_sv_root = Nullsv;
6593 PL_sv_arenaroot = Nullsv;
6595 PL_debug = proto_perl->Idebug;
6597 /* create SV map for pointer relocation */
6598 PL_ptr_table = ptr_table_new();
6600 /* initialize these special pointers as early as possible */
6601 SvANY(&PL_sv_undef) = NULL;
6602 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6603 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6604 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6607 SvUPGRADE(&PL_sv_no, SVt_PVNV);
6609 SvANY(&PL_sv_no) = new_XPVNV();
6611 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6612 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6613 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6614 SvCUR(&PL_sv_no) = 0;
6615 SvLEN(&PL_sv_no) = 1;
6616 SvNVX(&PL_sv_no) = 0;
6617 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6620 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
6622 SvANY(&PL_sv_yes) = new_XPVNV();
6624 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6625 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6626 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6627 SvCUR(&PL_sv_yes) = 1;
6628 SvLEN(&PL_sv_yes) = 2;
6629 SvNVX(&PL_sv_yes) = 1;
6630 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6632 /* create shared string table */
6633 PL_strtab = newHV();
6634 HvSHAREKEYS_off(PL_strtab);
6635 hv_ksplit(PL_strtab, 512);
6636 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6638 PL_compiling = proto_perl->Icompiling;
6639 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6640 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6641 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
6642 if (!specialWARN(PL_compiling.cop_warnings))
6643 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6644 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
6646 /* pseudo environmental stuff */
6647 PL_origargc = proto_perl->Iorigargc;
6649 New(0, PL_origargv, i+1, char*);
6650 PL_origargv[i] = '\0';
6652 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6654 PL_envgv = gv_dup(proto_perl->Ienvgv);
6655 PL_incgv = gv_dup(proto_perl->Iincgv);
6656 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6657 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6658 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6659 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6662 PL_minus_c = proto_perl->Iminus_c;
6663 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6664 PL_localpatches = proto_perl->Ilocalpatches;
6665 PL_splitstr = proto_perl->Isplitstr;
6666 PL_preprocess = proto_perl->Ipreprocess;
6667 PL_minus_n = proto_perl->Iminus_n;
6668 PL_minus_p = proto_perl->Iminus_p;
6669 PL_minus_l = proto_perl->Iminus_l;
6670 PL_minus_a = proto_perl->Iminus_a;
6671 PL_minus_F = proto_perl->Iminus_F;
6672 PL_doswitches = proto_perl->Idoswitches;
6673 PL_dowarn = proto_perl->Idowarn;
6674 PL_doextract = proto_perl->Idoextract;
6675 PL_sawampersand = proto_perl->Isawampersand;
6676 PL_unsafe = proto_perl->Iunsafe;
6677 PL_inplace = SAVEPV(proto_perl->Iinplace);
6678 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6679 PL_perldb = proto_perl->Iperldb;
6680 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6682 /* magical thingies */
6683 /* XXX time(&PL_basetime) when asked for? */
6684 PL_basetime = proto_perl->Ibasetime;
6685 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6687 PL_maxsysfd = proto_perl->Imaxsysfd;
6688 PL_multiline = proto_perl->Imultiline;
6689 PL_statusvalue = proto_perl->Istatusvalue;
6691 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6694 /* shortcuts to various I/O objects */
6695 PL_stdingv = gv_dup(proto_perl->Istdingv);
6696 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6697 PL_defgv = gv_dup(proto_perl->Idefgv);
6698 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6699 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6700 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6702 /* shortcuts to regexp stuff */
6703 PL_replgv = gv_dup(proto_perl->Ireplgv);
6705 /* shortcuts to misc objects */
6706 PL_errgv = gv_dup(proto_perl->Ierrgv);
6708 /* shortcuts to debugging objects */
6709 PL_DBgv = gv_dup(proto_perl->IDBgv);
6710 PL_DBline = gv_dup(proto_perl->IDBline);
6711 PL_DBsub = gv_dup(proto_perl->IDBsub);
6712 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6713 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6714 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6715 PL_lineary = av_dup(proto_perl->Ilineary);
6716 PL_dbargs = av_dup(proto_perl->Idbargs);
6719 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6720 PL_curstash = hv_dup(proto_perl->Tcurstash);
6721 PL_debstash = hv_dup(proto_perl->Idebstash);
6722 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6723 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6725 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6726 PL_endav = av_dup_inc(proto_perl->Iendav);
6727 PL_stopav = av_dup_inc(proto_perl->Istopav);
6728 PL_initav = av_dup_inc(proto_perl->Iinitav);
6730 PL_sub_generation = proto_perl->Isub_generation;
6732 /* funky return mechanisms */
6733 PL_forkprocess = proto_perl->Iforkprocess;
6735 /* subprocess state */
6736 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6738 /* internal state */
6739 PL_tainting = proto_perl->Itainting;
6740 PL_maxo = proto_perl->Imaxo;
6741 if (proto_perl->Iop_mask)
6742 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6744 PL_op_mask = Nullch;
6746 /* current interpreter roots */
6747 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6748 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6749 PL_main_start = proto_perl->Imain_start;
6750 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
6751 PL_eval_start = proto_perl->Ieval_start;
6753 /* runtime control stuff */
6754 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
6755 PL_copline = proto_perl->Icopline;
6757 PL_filemode = proto_perl->Ifilemode;
6758 PL_lastfd = proto_perl->Ilastfd;
6759 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
6762 PL_gensym = proto_perl->Igensym;
6763 PL_preambled = proto_perl->Ipreambled;
6764 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6765 PL_laststatval = proto_perl->Ilaststatval;
6766 PL_laststype = proto_perl->Ilaststype;
6767 PL_mess_sv = Nullsv;
6769 PL_orslen = proto_perl->Iorslen;
6770 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6771 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6773 /* interpreter atexit processing */
6774 PL_exitlistlen = proto_perl->Iexitlistlen;
6775 if (PL_exitlistlen) {
6776 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6777 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6780 PL_exitlist = (PerlExitListEntry*)NULL;
6781 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6783 PL_profiledata = NULL;
6784 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6785 /* PL_rsfp_filters entries have fake IoDIRP() */
6786 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6788 PL_compcv = cv_dup(proto_perl->Icompcv);
6789 PL_comppad = av_dup(proto_perl->Icomppad);
6790 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6791 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6792 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6793 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
6794 proto_perl->Tcurpad);
6796 #ifdef HAVE_INTERP_INTERN
6797 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6800 /* more statics moved here */
6801 PL_generation = proto_perl->Igeneration;
6802 PL_DBcv = cv_dup(proto_perl->IDBcv);
6803 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6805 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6806 PL_in_clean_all = proto_perl->Iin_clean_all;
6808 PL_uid = proto_perl->Iuid;
6809 PL_euid = proto_perl->Ieuid;
6810 PL_gid = proto_perl->Igid;
6811 PL_egid = proto_perl->Iegid;
6812 PL_nomemok = proto_perl->Inomemok;
6813 PL_an = proto_perl->Ian;
6814 PL_cop_seqmax = proto_perl->Icop_seqmax;
6815 PL_op_seqmax = proto_perl->Iop_seqmax;
6816 PL_evalseq = proto_perl->Ievalseq;
6817 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
6818 PL_origalen = proto_perl->Iorigalen;
6819 PL_pidstatus = newHV(); /* XXX flag for cloning? */
6820 PL_osname = SAVEPV(proto_perl->Iosname);
6821 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6822 PL_sighandlerp = proto_perl->Isighandlerp;
6825 PL_runops = proto_perl->Irunops;
6827 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6830 PL_cshlen = proto_perl->Icshlen;
6831 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6834 PL_lex_state = proto_perl->Ilex_state;
6835 PL_lex_defer = proto_perl->Ilex_defer;
6836 PL_lex_expect = proto_perl->Ilex_expect;
6837 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6838 PL_lex_fakebrack = proto_perl->Ilex_fakebrack;
6839 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6840 PL_lex_starts = proto_perl->Ilex_starts;
6841 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
6842 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
6843 PL_lex_op = proto_perl->Ilex_op;
6844 PL_lex_inpat = proto_perl->Ilex_inpat;
6845 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6846 PL_lex_brackets = proto_perl->Ilex_brackets;
6847 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6848 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6849 PL_lex_casemods = proto_perl->Ilex_casemods;
6850 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6851 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6853 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6854 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6855 PL_nexttoke = proto_perl->Inexttoke;
6857 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6858 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6859 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6860 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6861 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6862 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6863 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6864 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6865 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6866 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6867 PL_pending_ident = proto_perl->Ipending_ident;
6868 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
6870 PL_expect = proto_perl->Iexpect;
6872 PL_multi_start = proto_perl->Imulti_start;
6873 PL_multi_end = proto_perl->Imulti_end;
6874 PL_multi_open = proto_perl->Imulti_open;
6875 PL_multi_close = proto_perl->Imulti_close;
6877 PL_error_count = proto_perl->Ierror_count;
6878 PL_subline = proto_perl->Isubline;
6879 PL_subname = sv_dup_inc(proto_perl->Isubname);
6881 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6882 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6883 PL_padix = proto_perl->Ipadix;
6884 PL_padix_floor = proto_perl->Ipadix_floor;
6885 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6887 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6888 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6889 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6890 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6891 PL_last_lop_op = proto_perl->Ilast_lop_op;
6892 PL_in_my = proto_perl->Iin_my;
6893 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6895 PL_cryptseen = proto_perl->Icryptseen;
6898 PL_hints = proto_perl->Ihints;
6900 PL_amagic_generation = proto_perl->Iamagic_generation;
6902 #ifdef USE_LOCALE_COLLATE
6903 PL_collation_ix = proto_perl->Icollation_ix;
6904 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6905 PL_collation_standard = proto_perl->Icollation_standard;
6906 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6907 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6908 #endif /* USE_LOCALE_COLLATE */
6910 #ifdef USE_LOCALE_NUMERIC
6911 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6912 PL_numeric_standard = proto_perl->Inumeric_standard;
6913 PL_numeric_local = proto_perl->Inumeric_local;
6914 PL_numeric_radix = proto_perl->Inumeric_radix;
6915 #endif /* !USE_LOCALE_NUMERIC */
6917 /* utf8 character classes */
6918 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6919 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6920 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6921 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6922 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6923 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6924 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6925 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6926 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6927 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6928 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6929 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6930 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6931 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6932 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6933 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6934 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6937 PL_last_swash_hv = Nullhv; /* reinits on demand */
6938 PL_last_swash_klen = 0;
6939 PL_last_swash_key[0]= '\0';
6940 PL_last_swash_tmps = (U8*)NULL;
6941 PL_last_swash_slen = 0;
6943 /* perly.c globals */
6944 PL_yydebug = proto_perl->Iyydebug;
6945 PL_yynerrs = proto_perl->Iyynerrs;
6946 PL_yyerrflag = proto_perl->Iyyerrflag;
6947 PL_yychar = proto_perl->Iyychar;
6948 PL_yyval = proto_perl->Iyyval;
6949 PL_yylval = proto_perl->Iyylval;
6951 PL_glob_index = proto_perl->Iglob_index;
6952 PL_srand_called = proto_perl->Isrand_called;
6953 PL_uudmap['M'] = 0; /* reinits on demand */
6954 PL_bitcount = Nullch; /* reinits on demand */
6956 if (proto_perl->Ipsig_ptr) {
6957 int sig_num[] = { SIG_NUM };
6958 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
6959 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
6960 for (i = 1; PL_sig_name[i]; i++) {
6961 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
6962 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
6966 PL_psig_ptr = (SV**)NULL;
6967 PL_psig_name = (SV**)NULL;
6970 /* thrdvar.h stuff */
6973 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
6974 PL_tmps_ix = proto_perl->Ttmps_ix;
6975 PL_tmps_max = proto_perl->Ttmps_max;
6976 PL_tmps_floor = proto_perl->Ttmps_floor;
6977 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
6979 while (i <= PL_tmps_ix) {
6980 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
6984 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
6985 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
6986 Newz(54, PL_markstack, i, I32);
6987 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
6988 - proto_perl->Tmarkstack);
6989 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
6990 - proto_perl->Tmarkstack);
6991 Copy(proto_perl->Tmarkstack, PL_markstack,
6992 PL_markstack_ptr - PL_markstack + 1, I32);
6994 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
6995 * NOTE: unlike the others! */
6996 PL_scopestack_ix = proto_perl->Tscopestack_ix;
6997 PL_scopestack_max = proto_perl->Tscopestack_max;
6998 Newz(54, PL_scopestack, PL_scopestack_max, I32);
6999 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7001 /* next push_return() sets PL_retstack[PL_retstack_ix]
7002 * NOTE: unlike the others! */
7003 PL_retstack_ix = proto_perl->Tretstack_ix;
7004 PL_retstack_max = proto_perl->Tretstack_max;
7005 Newz(54, PL_retstack, PL_retstack_max, OP*);
7006 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7008 /* NOTE: si_dup() looks at PL_markstack */
7009 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7011 /* PL_curstack = PL_curstackinfo->si_stack; */
7012 PL_curstack = av_dup(proto_perl->Tcurstack);
7013 PL_mainstack = av_dup(proto_perl->Tmainstack);
7015 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7016 PL_stack_base = AvARRAY(PL_curstack);
7017 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7018 - proto_perl->Tstack_base);
7019 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7021 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7022 * NOTE: unlike the others! */
7023 PL_savestack_ix = proto_perl->Tsavestack_ix;
7024 PL_savestack_max = proto_perl->Tsavestack_max;
7025 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7026 PL_savestack = ss_dup(proto_perl);
7032 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7033 PL_top_env = &PL_start_env;
7035 PL_op = proto_perl->Top;
7038 PL_Xpv = (XPV*)NULL;
7039 PL_na = proto_perl->Tna;
7041 PL_statbuf = proto_perl->Tstatbuf;
7042 PL_statcache = proto_perl->Tstatcache;
7043 PL_statgv = gv_dup(proto_perl->Tstatgv);
7044 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7046 PL_timesbuf = proto_perl->Ttimesbuf;
7049 PL_tainted = proto_perl->Ttainted;
7050 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7051 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7052 PL_rs = sv_dup_inc(proto_perl->Trs);
7053 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7054 PL_ofslen = proto_perl->Tofslen;
7055 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7056 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7057 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7058 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7059 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7060 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7062 PL_restartop = proto_perl->Trestartop;
7063 PL_in_eval = proto_perl->Tin_eval;
7064 PL_delaymagic = proto_perl->Tdelaymagic;
7065 PL_dirty = proto_perl->Tdirty;
7066 PL_localizing = proto_perl->Tlocalizing;
7068 PL_protect = proto_perl->Tprotect;
7069 PL_errors = sv_dup_inc(proto_perl->Terrors);
7070 PL_av_fetch_sv = Nullsv;
7071 PL_hv_fetch_sv = Nullsv;
7072 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7073 PL_modcount = proto_perl->Tmodcount;
7074 PL_lastgotoprobe = Nullop;
7075 PL_dumpindent = proto_perl->Tdumpindent;
7077 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7078 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7079 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7080 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7081 PL_sortcxix = proto_perl->Tsortcxix;
7082 PL_efloatbuf = Nullch; /* reinits on demand */
7083 PL_efloatsize = 0; /* reinits on demand */
7087 PL_screamfirst = NULL;
7088 PL_screamnext = NULL;
7089 PL_maxscream = -1; /* reinits on demand */
7090 PL_lastscream = Nullsv;
7092 PL_watchaddr = NULL;
7093 PL_watchok = Nullch;
7095 PL_regdummy = proto_perl->Tregdummy;
7096 PL_regcomp_parse = Nullch;
7097 PL_regxend = Nullch;
7098 PL_regcode = (regnode*)NULL;
7101 PL_regprecomp = Nullch;
7106 PL_seen_zerolen = 0;
7108 PL_regcomp_rx = (regexp*)NULL;
7110 PL_colorset = 0; /* reinits PL_colors[] */
7111 /*PL_colors[6] = {0,0,0,0,0,0};*/
7112 PL_reg_whilem_seen = 0;
7113 PL_reginput = Nullch;
7116 PL_regstartp = (I32*)NULL;
7117 PL_regendp = (I32*)NULL;
7118 PL_reglastparen = (U32*)NULL;
7119 PL_regtill = Nullch;
7121 PL_reg_start_tmp = (char**)NULL;
7122 PL_reg_start_tmpl = 0;
7123 PL_regdata = (struct reg_data*)NULL;
7126 PL_reg_eval_set = 0;
7128 PL_regprogram = (regnode*)NULL;
7130 PL_regcc = (CURCUR*)NULL;
7131 PL_reg_call_cc = (struct re_cc_state*)NULL;
7132 PL_reg_re = (regexp*)NULL;
7133 PL_reg_ganch = Nullch;
7135 PL_reg_magic = (MAGIC*)NULL;
7137 PL_reg_oldcurpm = (PMOP*)NULL;
7138 PL_reg_curpm = (PMOP*)NULL;
7139 PL_reg_oldsaved = Nullch;
7140 PL_reg_oldsavedlen = 0;
7142 PL_reg_leftiter = 0;
7143 PL_reg_poscache = Nullch;
7144 PL_reg_poscache_size= 0;
7146 /* RE engine - function pointers */
7147 PL_regcompp = proto_perl->Tregcompp;
7148 PL_regexecp = proto_perl->Tregexecp;
7149 PL_regint_start = proto_perl->Tregint_start;
7150 PL_regint_string = proto_perl->Tregint_string;
7151 PL_regfree = proto_perl->Tregfree;
7153 PL_reginterp_cnt = 0;
7154 PL_reg_starttry = 0;
7157 return (PerlInterpreter*)pPerl;
7163 #else /* !USE_ITHREADS */
7169 #endif /* USE_ITHREADS */
7172 do_report_used(pTHXo_ SV *sv)
7174 if (SvTYPE(sv) != SVTYPEMASK) {
7175 PerlIO_printf(Perl_debug_log, "****\n");
7181 do_clean_objs(pTHXo_ SV *sv)
7185 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7186 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7192 /* XXX Might want to check arrays, etc. */
7195 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7197 do_clean_named_objs(pTHXo_ SV *sv)
7199 if (SvTYPE(sv) == SVt_PVGV) {
7200 if ( SvOBJECT(GvSV(sv)) ||
7201 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7202 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7203 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7204 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7206 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7214 do_clean_all(pTHXo_ SV *sv)
7216 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7217 SvFLAGS(sv) |= SVf_BREAK;