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",
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(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(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);
2466 GvGP(dstr)->gp_refcnt--;
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(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(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(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(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
5616 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5617 #define av_dup(s) (AV*)sv_dup((SV*)s)
5618 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5619 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5620 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5621 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5622 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5623 #define io_dup(s) (IO*)sv_dup((SV*)s)
5624 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5625 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5626 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5627 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5628 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5631 Perl_re_dup(pTHX_ REGEXP *r)
5633 /* XXX fix when pmop->op_pmregexp becomes shared */
5634 return ReREFCNT_inc(r);
5638 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5641 return (PerlIO*)NULL;
5642 return fp; /* XXX */
5643 /* return PerlIO_fdopen(PerlIO_fileno(fp),
5644 type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5648 Perl_dirp_dup(pTHX_ DIR *dp)
5657 Perl_gp_dup(pTHX_ GP *gp)
5662 Newz(0, ret, 1, GP);
5663 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5664 ret->gp_io = io_dup_inc(gp->gp_io);
5665 ret->gp_form = cv_dup_inc(gp->gp_form);
5666 ret->gp_av = av_dup_inc(gp->gp_av);
5667 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5668 ret->gp_egv = gv_dup_inc(gp->gp_egv);
5669 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5670 ret->gp_cvgen = gp->gp_cvgen;
5671 ret->gp_flags = gp->gp_flags;
5672 ret->gp_line = gp->gp_line;
5673 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5679 Perl_mg_dup(pTHX_ MAGIC *mg)
5681 MAGIC *mgret = (MAGIC*)NULL;
5684 return (MAGIC*)NULL;
5685 for (; mg; mg = mg->mg_moremagic) {
5687 Newz(0, nmg, 1, MAGIC);
5691 mgprev->mg_moremagic = nmg;
5692 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5693 nmg->mg_private = mg->mg_private;
5694 nmg->mg_type = mg->mg_type;
5695 nmg->mg_flags = mg->mg_flags;
5696 if (mg->mg_type == 'r') {
5697 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5700 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5701 ? sv_dup_inc(mg->mg_obj)
5702 : sv_dup(mg->mg_obj);
5704 nmg->mg_len = mg->mg_len;
5705 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5706 if (mg->mg_ptr && mg->mg_type != 'g') {
5707 if (mg->mg_len >= 0)
5708 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5709 else if (mg->mg_len == HEf_SVKEY)
5710 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5718 Perl_sv_table_new(pTHX)
5721 Newz(0, tbl, 1, SVTBL);
5724 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*);
5729 Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv)
5734 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5735 for (; tblent; tblent = tblent->next) {
5736 if (tblent->oldval == sv)
5737 return tblent->newval;
5743 Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new)
5745 SVTBLENT *tblent, **otblent;
5749 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5750 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5751 if (tblent->oldval == old) {
5752 tblent->newval = new;
5757 Newz(0, tblent, 1, SVTBLENT);
5758 tblent->oldval = old;
5759 tblent->newval = new;
5760 tblent->next = *otblent;
5763 if (i && tbl->tbl_items > tbl->tbl_max)
5764 sv_table_split(tbl);
5768 Perl_sv_table_split(pTHX_ SVTBL *tbl)
5770 SVTBLENT **ary = tbl->tbl_ary;
5771 UV oldsize = tbl->tbl_max + 1;
5772 UV newsize = oldsize * 2;
5775 Renew(ary, newsize, SVTBLENT*);
5776 Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*);
5777 tbl->tbl_max = --newsize;
5779 for (i=0; i < oldsize; i++, ary++) {
5780 SVTBLENT **curentp, **entp, *ent;
5783 curentp = ary + oldsize;
5784 for (entp = ary, ent = *ary; ent; ent = *entp) {
5785 if ((newsize & (UV)ent->oldval) != i) {
5787 ent->next = *curentp;
5798 Perl_sv_dup(pTHX_ SV *sstr)
5807 /* look for it in the table first */
5808 dstr = sv_table_fetch(PL_sv_table, sstr);
5812 /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */
5814 /* create anew and remember what it is */
5816 sv_table_store(PL_sv_table, sstr, dstr);
5819 SvFLAGS(dstr) = SvFLAGS(sstr);
5820 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5823 switch (SvTYPE(sstr)) {
5828 SvANY(dstr) = new_XIV();
5829 SvIVX(dstr) = SvIVX(sstr);
5832 SvANY(dstr) = new_XNV();
5833 SvNVX(dstr) = SvNVX(sstr);
5836 SvANY(dstr) = new_XRV();
5837 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5840 SvANY(dstr) = new_XPV();
5841 SvCUR(dstr) = SvCUR(sstr);
5842 SvLEN(dstr) = SvLEN(sstr);
5843 if (SvPOKp(sstr) && SvLEN(sstr))
5844 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5846 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5849 SvANY(dstr) = new_XPVIV();
5850 SvCUR(dstr) = SvCUR(sstr);
5851 SvLEN(dstr) = SvLEN(sstr);
5852 SvIVX(dstr) = SvIVX(sstr);
5853 if (SvPOKp(sstr) && SvLEN(sstr))
5854 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5856 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5859 SvANY(dstr) = new_XPVNV();
5860 SvCUR(dstr) = SvCUR(sstr);
5861 SvLEN(dstr) = SvLEN(sstr);
5862 SvIVX(dstr) = SvIVX(sstr);
5863 SvNVX(dstr) = SvNVX(sstr);
5864 if (SvPOKp(sstr) && SvLEN(sstr))
5865 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5867 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5870 SvANY(dstr) = new_XPVMG();
5871 SvCUR(dstr) = SvCUR(sstr);
5872 SvLEN(dstr) = SvLEN(sstr);
5873 SvIVX(dstr) = SvIVX(sstr);
5874 SvNVX(dstr) = SvNVX(sstr);
5875 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5876 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5877 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
5879 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5880 if (SvPOKp(sstr) && SvLEN(sstr))
5881 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5883 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5886 SvANY(dstr) = new_XPVBM();
5887 SvCUR(dstr) = SvCUR(sstr);
5888 SvLEN(dstr) = SvLEN(sstr);
5889 SvIVX(dstr) = SvIVX(sstr);
5890 SvNVX(dstr) = SvNVX(sstr);
5891 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5892 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5893 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
5895 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5896 if (SvPOKp(sstr) && SvLEN(sstr))
5897 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5899 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5900 BmRARE(dstr) = BmRARE(sstr);
5901 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5902 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5905 SvANY(dstr) = new_XPVLV();
5906 SvCUR(dstr) = SvCUR(sstr);
5907 SvLEN(dstr) = SvLEN(sstr);
5908 SvIVX(dstr) = SvIVX(sstr);
5909 SvNVX(dstr) = SvNVX(sstr);
5910 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5911 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5912 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
5914 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5915 if (SvPOKp(sstr) && SvLEN(sstr))
5916 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5918 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5919 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5920 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5921 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5922 LvTYPE(dstr) = LvTYPE(sstr);
5925 SvANY(dstr) = new_XPVGV();
5926 SvCUR(dstr) = SvCUR(sstr);
5927 SvLEN(dstr) = SvLEN(sstr);
5928 SvIVX(dstr) = SvIVX(sstr);
5929 SvNVX(dstr) = SvNVX(sstr);
5930 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5931 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5932 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
5934 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5935 if (SvPOKp(sstr) && SvLEN(sstr))
5936 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5938 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5939 GvNAMELEN(dstr) = GvNAMELEN(sstr);
5940 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5941 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
5942 GvFLAGS(dstr) = GvFLAGS(sstr);
5943 GvGP(dstr) = gp_dup(GvGP(sstr));
5944 GvGP(dstr)->gp_refcnt++;
5947 SvANY(dstr) = new_XPVIO();
5948 SvCUR(dstr) = SvCUR(sstr);
5949 SvLEN(dstr) = SvLEN(sstr);
5950 SvIVX(dstr) = SvIVX(sstr);
5951 SvNVX(dstr) = SvNVX(sstr);
5952 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5953 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5954 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
5956 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5957 if (SvPOKp(sstr) && SvLEN(sstr))
5958 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5960 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5961 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
5962 if (IoOFP(sstr) == IoIFP(sstr))
5963 IoOFP(dstr) = IoIFP(dstr);
5965 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
5966 /* PL_rsfp_filters entries have fake IoDIRP() */
5967 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
5968 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
5970 IoDIRP(dstr) = IoDIRP(sstr);
5971 IoLINES(dstr) = IoLINES(sstr);
5972 IoPAGE(dstr) = IoPAGE(sstr);
5973 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
5974 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
5975 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
5976 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
5977 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
5978 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
5979 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
5980 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
5981 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
5982 IoTYPE(dstr) = IoTYPE(sstr);
5983 IoFLAGS(dstr) = IoFLAGS(sstr);
5986 SvANY(dstr) = new_XPVAV();
5987 SvCUR(dstr) = SvCUR(sstr);
5988 SvLEN(dstr) = SvLEN(sstr);
5989 SvIVX(dstr) = SvIVX(sstr);
5990 SvNVX(dstr) = SvNVX(sstr);
5991 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5992 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5993 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
5994 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
5995 if (AvALLOC((AV*)sstr)) {
5996 SV **dst_ary, **src_ary;
5997 SSize_t items = AvFILLp((AV*)sstr) + 1;
5999 src_ary = AvALLOC((AV*)sstr);
6000 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6001 SvPVX(dstr) = (char*)dst_ary;
6002 AvALLOC((AV*)dstr) = dst_ary;
6003 if (AvREAL((AV*)sstr)) {
6005 *dst_ary++ = sv_dup_inc(*src_ary++);
6009 *dst_ary++ = sv_dup(*src_ary++);
6011 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6012 while (items-- > 0) {
6013 *dst_ary++ = &PL_sv_undef;
6017 SvPVX(dstr) = Nullch;
6018 AvALLOC((AV*)dstr) = (SV**)NULL;
6022 SvANY(dstr) = new_XPVHV();
6023 SvCUR(dstr) = SvCUR(sstr);
6024 SvLEN(dstr) = SvLEN(sstr);
6025 SvIVX(dstr) = SvIVX(sstr);
6026 SvNVX(dstr) = SvNVX(sstr);
6027 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6028 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6029 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6030 if (HvARRAY((HV*)sstr)) {
6033 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6034 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6035 Newz(0, dxhv->xhv_array,
6036 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6037 while (i <= sxhv->xhv_max) {
6038 HE *dentry, *oentry;
6039 entry = ((HE**)sxhv->xhv_array)[i];
6040 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6041 ((HE**)dxhv->xhv_array)[i] = dentry;
6043 entry = HeNEXT(entry);
6045 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6046 HeNEXT(oentry) = dentry;
6050 if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6051 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6052 while (entry && entry != sxhv->xhv_eiter)
6053 entry = HeNEXT(entry);
6054 dxhv->xhv_eiter = entry;
6057 dxhv->xhv_eiter = (HE*)NULL;
6060 SvPVX(dstr) = Nullch;
6061 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6062 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6065 SvANY(dstr) = new_XPVFM();
6069 SvANY(dstr) = new_XPVCV();
6071 SvCUR(dstr) = SvCUR(sstr);
6072 SvLEN(dstr) = SvLEN(sstr);
6073 SvIVX(dstr) = SvIVX(sstr);
6074 SvNVX(dstr) = SvNVX(sstr);
6075 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6076 if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
6077 SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */
6079 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6080 if (SvPOKp(sstr) && SvLEN(sstr))
6081 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
6083 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6084 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6085 CvSTART(dstr) = CvSTART(sstr);
6086 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6087 CvXSUB(dstr) = CvXSUB(sstr);
6088 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6089 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6090 CvDEPTH(dstr) = CvDEPTH(sstr);
6091 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6092 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6093 CvFLAGS(dstr) = CvFLAGS(sstr);
6096 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6107 perl_clone_using(PerlInterpreter *proto_perl, IV flags,
6108 struct IPerlMem* ipM, struct IPerlEnv* ipE,
6109 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6110 struct IPerlDir* ipD, struct IPerlSock* ipS,
6111 struct IPerlProc* ipP)
6116 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6117 PERL_SET_INTERP(my_perl);
6120 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6127 Copy(proto_perl, my_perl, 1, PerlInterpreter);
6131 /* XXX many of the string copies here can be optimized if they're
6132 * constants; they need to be allocated as common memory and just
6133 * their pointers copied. */
6145 PL_xiv_arenaroot = NULL;
6150 PL_xpviv_root = NULL;
6151 PL_xpvnv_root = NULL;
6152 PL_xpvcv_root = NULL;
6153 PL_xpvav_root = NULL;
6154 PL_xpvhv_root = NULL;
6155 PL_xpvmg_root = NULL;
6156 PL_xpvlv_root = NULL;
6157 PL_xpvbm_root = NULL;
6159 PL_nice_chunk = NULL;
6160 PL_nice_chunk_size = 0;
6163 PL_sv_root = Nullsv;
6164 PL_sv_arenaroot = Nullsv;
6166 PL_debug = proto_perl->Idebug;
6168 /* create SV map for pointer relocation */
6169 PL_sv_table = sv_table_new();
6171 /* initialize these special pointers as early as possible */
6172 SvANY(&PL_sv_undef) = NULL;
6173 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6174 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6175 sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef);
6177 SvANY(&PL_sv_no) = new_XPVNV();
6178 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6179 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6180 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6181 SvCUR(&PL_sv_no) = 0;
6182 SvLEN(&PL_sv_no) = 1;
6183 SvNVX(&PL_sv_no) = 0;
6184 sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no);
6186 SvANY(&PL_sv_yes) = new_XPVNV();
6187 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6188 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6189 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6190 SvCUR(&PL_sv_yes) = 1;
6191 SvLEN(&PL_sv_yes) = 2;
6192 SvNVX(&PL_sv_yes) = 1;
6193 sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes);
6195 /* create shared string table */
6196 PL_strtab = newHV();
6197 HvSHAREKEYS_off(PL_strtab);
6198 hv_ksplit(PL_strtab, 512);
6199 sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab);
6201 PL_compiling = proto_perl->Icompiling;
6202 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6203 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6204 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6205 if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6206 PL_curcop = &PL_compiling;
6208 PL_curcop = proto_perl->Tcurcop;
6210 /* pseudo environmental stuff */
6211 PL_origargc = proto_perl->Iorigargc;
6213 New(0, PL_origargv, i+1, char*);
6214 PL_origargv[i] = '\0';
6216 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6218 PL_envgv = gv_dup(proto_perl->Ienvgv);
6219 PL_incgv = gv_dup(proto_perl->Iincgv);
6220 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6221 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6222 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6223 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6226 PL_minus_c = proto_perl->Iminus_c;
6227 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6228 PL_localpatches = proto_perl->Ilocalpatches;
6229 PL_splitstr = proto_perl->Isplitstr;
6230 PL_preprocess = proto_perl->Ipreprocess;
6231 PL_minus_n = proto_perl->Iminus_n;
6232 PL_minus_p = proto_perl->Iminus_p;
6233 PL_minus_l = proto_perl->Iminus_l;
6234 PL_minus_a = proto_perl->Iminus_a;
6235 PL_minus_F = proto_perl->Iminus_F;
6236 PL_doswitches = proto_perl->Idoswitches;
6237 PL_dowarn = proto_perl->Idowarn;
6238 PL_doextract = proto_perl->Idoextract;
6239 PL_sawampersand = proto_perl->Isawampersand;
6240 PL_unsafe = proto_perl->Iunsafe;
6241 PL_inplace = SAVEPV(proto_perl->Iinplace);
6242 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6243 PL_perldb = proto_perl->Iperldb;
6244 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6246 /* magical thingies */
6247 /* XXX time(&PL_basetime) instead? */
6248 PL_basetime = proto_perl->Ibasetime;
6249 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6251 PL_maxsysfd = proto_perl->Imaxsysfd;
6252 PL_multiline = proto_perl->Imultiline;
6253 PL_statusvalue = proto_perl->Istatusvalue;
6255 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6258 /* shortcuts to various I/O objects */
6259 PL_stdingv = gv_dup(proto_perl->Istdingv);
6260 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6261 PL_defgv = gv_dup(proto_perl->Idefgv);
6262 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6263 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6264 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6266 /* shortcuts to regexp stuff */
6267 PL_replgv = gv_dup(proto_perl->Ireplgv);
6269 /* shortcuts to misc objects */
6270 PL_errgv = gv_dup(proto_perl->Ierrgv);
6272 /* shortcuts to debugging objects */
6273 PL_DBgv = gv_dup(proto_perl->IDBgv);
6274 PL_DBline = gv_dup(proto_perl->IDBline);
6275 PL_DBsub = gv_dup(proto_perl->IDBsub);
6276 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6277 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6278 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6279 PL_lineary = av_dup(proto_perl->Ilineary);
6280 PL_dbargs = av_dup(proto_perl->Idbargs);
6283 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6284 PL_curstash = hv_dup(proto_perl->Tcurstash);
6285 PL_debstash = hv_dup(proto_perl->Idebstash);
6286 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6287 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6289 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6290 PL_endav = av_dup_inc(proto_perl->Iendav);
6291 PL_stopav = av_dup_inc(proto_perl->Istopav);
6292 PL_initav = av_dup_inc(proto_perl->Iinitav);
6294 PL_sub_generation = proto_perl->Isub_generation;
6296 /* funky return mechanisms */
6297 PL_forkprocess = proto_perl->Iforkprocess;
6299 /* subprocess state */
6300 PL_fdpid = av_dup(proto_perl->Ifdpid);
6302 /* internal state */
6303 PL_tainting = proto_perl->Itainting;
6304 PL_maxo = proto_perl->Imaxo;
6305 if (proto_perl->Iop_mask)
6306 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6308 PL_op_mask = Nullch;
6310 /* current interpreter roots */
6311 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6312 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6313 PL_main_start = proto_perl->Imain_start;
6314 PL_eval_root = proto_perl->Ieval_root;
6315 PL_eval_start = proto_perl->Ieval_start;
6317 /* runtime control stuff */
6318 PL_curcopdb = proto_perl->Icurcopdb;
6319 PL_copline = proto_perl->Icopline;
6321 PL_filemode = proto_perl->Ifilemode;
6322 PL_lastfd = proto_perl->Ilastfd;
6323 PL_oldname = proto_perl->Ioldname; /* XXX */
6326 PL_gensym = proto_perl->Igensym;
6327 PL_preambled = proto_perl->Ipreambled;
6328 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6329 PL_laststatval = proto_perl->Ilaststatval;
6330 PL_laststype = proto_perl->Ilaststype;
6331 PL_mess_sv = Nullsv;
6333 PL_orslen = proto_perl->Iorslen;
6334 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6335 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6337 /* interpreter atexit processing */
6338 PL_exitlistlen = proto_perl->Iexitlistlen;
6339 if (PL_exitlistlen) {
6340 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6341 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6344 PL_exitlist = (PerlExitListEntry*)NULL;
6345 PL_modglobal = hv_dup(proto_perl->Imodglobal);
6347 PL_profiledata = NULL; /* XXX */
6348 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6349 /* XXX PL_rsfp_filters entries have fake IoDIRP() */
6350 PL_rsfp_filters = av_dup(proto_perl->Irsfp_filters);
6352 PL_compcv = cv_dup(proto_perl->Icompcv);
6353 PL_comppad = av_dup(proto_perl->Icomppad);
6354 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6355 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6356 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6357 PL_curpad = AvARRAY(PL_comppad); /* XXX */
6359 #ifdef HAVE_INTERP_INTERN
6360 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6363 /* more statics moved here */
6364 PL_generation = proto_perl->Igeneration;
6365 PL_DBcv = cv_dup(proto_perl->IDBcv);
6366 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6368 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6369 PL_in_clean_all = proto_perl->Iin_clean_all;
6371 PL_uid = proto_perl->Iuid;
6372 PL_euid = proto_perl->Ieuid;
6373 PL_gid = proto_perl->Igid;
6374 PL_egid = proto_perl->Iegid;
6375 PL_nomemok = proto_perl->Inomemok;
6376 PL_an = proto_perl->Ian;
6377 PL_cop_seqmax = proto_perl->Icop_seqmax;
6378 PL_op_seqmax = proto_perl->Iop_seqmax;
6379 PL_evalseq = proto_perl->Ievalseq;
6380 PL_origenviron = proto_perl->Iorigenviron; /* XXX */
6381 PL_origalen = proto_perl->Iorigalen;
6382 PL_pidstatus = newHV();
6383 PL_osname = SAVEPV(proto_perl->Iosname);
6384 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6385 PL_sighandlerp = proto_perl->Isighandlerp;
6388 PL_runops = proto_perl->Irunops;
6390 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */
6393 PL_cshlen = proto_perl->Icshlen;
6394 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6397 PL_lex_state = proto_perl->Ilex_state;
6398 PL_lex_defer = proto_perl->Ilex_defer;
6399 PL_lex_expect = proto_perl->Ilex_expect;
6400 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6401 PL_lex_fakebrack = proto_perl->Ilex_fakebrack;
6402 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6403 PL_lex_starts = proto_perl->Ilex_starts;
6404 PL_lex_stuff = Nullsv; /* XXX */
6405 PL_lex_repl = Nullsv; /* XXX */
6406 PL_lex_op = proto_perl->Ilex_op;
6407 PL_lex_inpat = proto_perl->Ilex_inpat;
6408 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6409 PL_lex_brackets = proto_perl->Ilex_brackets;
6410 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6411 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6412 PL_lex_casemods = proto_perl->Ilex_casemods;
6413 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6414 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6416 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6417 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6418 PL_nexttoke = proto_perl->Inexttoke;
6420 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6421 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6422 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6423 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6424 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6425 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6426 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6427 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6428 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6429 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6430 PL_pending_ident = proto_perl->Ipending_ident;
6431 PL_sublex_info = proto_perl->Isublex_info; /* XXX */
6433 PL_expect = proto_perl->Iexpect;
6435 PL_multi_start = proto_perl->Imulti_start;
6436 PL_multi_end = proto_perl->Imulti_end;
6437 PL_multi_open = proto_perl->Imulti_open;
6438 PL_multi_close = proto_perl->Imulti_close;
6440 PL_error_count = proto_perl->Ierror_count;
6441 PL_subline = proto_perl->Isubline;
6442 PL_subname = sv_dup_inc(proto_perl->Isubname);
6444 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6445 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6446 PL_padix = proto_perl->Ipadix;
6447 PL_padix_floor = proto_perl->Ipadix_floor;
6448 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6450 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6451 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6452 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6453 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6454 PL_last_lop_op = proto_perl->Ilast_lop_op;
6455 PL_in_my = proto_perl->Iin_my;
6456 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6458 PL_cryptseen = proto_perl->Icryptseen;
6461 PL_hints = proto_perl->Ihints;
6463 PL_amagic_generation = proto_perl->Iamagic_generation;
6465 #ifdef USE_LOCALE_COLLATE
6466 PL_collation_ix = proto_perl->Icollation_ix;
6467 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6468 PL_collation_standard = proto_perl->Icollation_standard;
6469 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6470 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6471 #endif /* USE_LOCALE_COLLATE */
6473 #ifdef USE_LOCALE_NUMERIC
6474 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6475 PL_numeric_standard = proto_perl->Inumeric_standard;
6476 PL_numeric_local = proto_perl->Inumeric_local;
6477 PL_numeric_radix = proto_perl->Inumeric_radix;
6478 #endif /* !USE_LOCALE_NUMERIC */
6480 /* utf8 character classes */
6481 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6482 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6483 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6484 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6485 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6486 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6487 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6488 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6489 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6490 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6491 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6492 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6493 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6494 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6495 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6496 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6497 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6500 PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */
6501 PL_last_swash_klen = 0;
6502 PL_last_swash_key[0]= '\0';
6503 PL_last_swash_tmps = Nullch;
6504 PL_last_swash_slen = 0;
6506 /* perly.c globals */
6507 PL_yydebug = proto_perl->Iyydebug;
6508 PL_yynerrs = proto_perl->Iyynerrs;
6509 PL_yyerrflag = proto_perl->Iyyerrflag;
6510 PL_yychar = proto_perl->Iyychar;
6511 PL_yyval = proto_perl->Iyyval;
6512 PL_yylval = proto_perl->Iyylval;
6514 PL_glob_index = proto_perl->Iglob_index;
6515 PL_srand_called = proto_perl->Isrand_called;
6516 PL_uudmap['M'] = 0; /* reinit on demand */
6517 PL_bitcount = Nullch; /* reinit on demand */
6520 /* thrdvar.h stuff */
6522 /* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo);
6524 PL_mainstack = av_dup(proto_perl->Tmainstack);
6525 PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */
6528 PL_op = proto_perl->Top;
6529 PL_statbuf = proto_perl->Tstatbuf;
6530 PL_statcache = proto_perl->Tstatcache;
6531 PL_statgv = gv_dup(proto_perl->Tstatgv);
6532 PL_statname = sv_dup(proto_perl->Tstatname);
6534 PL_timesbuf = proto_perl->Ttimesbuf;
6537 PL_tainted = proto_perl->Ttainted;
6538 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
6539 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
6540 PL_rs = sv_dup_inc(proto_perl->Trs);
6541 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
6542 PL_ofslen = proto_perl->Tofslen;
6543 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6544 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
6545 PL_chopset = proto_perl->Tchopset; /* XXX */
6546 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
6547 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
6548 PL_formtarget = sv_dup(proto_perl->Tformtarget);
6550 PL_restartop = proto_perl->Trestartop;
6551 PL_in_eval = proto_perl->Tin_eval;
6552 PL_delaymagic = proto_perl->Tdelaymagic;
6553 PL_dirty = proto_perl->Tdirty;
6554 PL_localizing = proto_perl->Tlocalizing;
6556 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
6557 PL_top_env = &PL_start_env;
6558 PL_protect = proto_perl->Tprotect;
6559 PL_errors = sv_dup_inc(proto_perl->Terrors);
6560 PL_av_fetch_sv = Nullsv;
6561 PL_hv_fetch_sv = Nullsv;
6562 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
6563 PL_modcount = proto_perl->Tmodcount;
6564 PL_lastgotoprobe = Nullop;
6565 PL_dumpindent = proto_perl->Tdumpindent;
6566 PL_sortstash = hv_dup(proto_perl->Tsortstash);
6567 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
6568 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
6569 PL_sortcxix = proto_perl->Tsortcxix;
6570 PL_efloatbuf = Nullch;
6573 PL_screamfirst = NULL;
6574 PL_screamnext = NULL;
6576 PL_lastscream = Nullsv;
6578 /* RE engine - function pointers */
6579 PL_regcompp = proto_perl->Tregcompp;
6580 PL_regexecp = proto_perl->Tregexecp;
6581 PL_regint_start = proto_perl->Tregint_start;
6582 PL_regint_string = proto_perl->Tregint_string;
6583 PL_regfree = proto_perl->Tregfree;
6586 PL_reginterp_cnt = 0;
6587 PL_reg_start_tmp = 0;
6588 PL_reg_start_tmpl = 0;
6589 PL_reg_poscache = Nullch;
6591 PL_watchaddr = NULL;
6592 PL_watchok = Nullch;
6598 perl_clone(pTHXx_ IV flags)
6600 return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6601 PL_Dir, PL_Sock, PL_Proc);
6604 #endif /* USE_ITHREADS */
6611 do_report_used(pTHXo_ SV *sv)
6613 if (SvTYPE(sv) != SVTYPEMASK) {
6614 PerlIO_printf(Perl_debug_log, "****\n");
6620 do_clean_objs(pTHXo_ SV *sv)
6624 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6625 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6631 /* XXX Might want to check arrays, etc. */
6634 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6636 do_clean_named_objs(pTHXo_ SV *sv)
6638 if (SvTYPE(sv) == SVt_PVGV) {
6639 if ( SvOBJECT(GvSV(sv)) ||
6640 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6641 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6642 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6643 GvCV(sv) && SvOBJECT(GvCV(sv)) )
6645 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6653 do_clean_all(pTHXo_ SV *sv)
6655 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6656 SvFLAGS(sv) |= SVf_BREAK;