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 elen = strlen(eptr);
5226 elen = sizeof nullstr - 1;
5229 else if (svix < svmax) {
5230 eptr = SvPVx(svargs[svix++], elen);
5232 if (has_precis && precis < elen) {
5234 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5237 if (width) { /* fudge width (can't fudge elen) */
5238 width += elen - sv_len_utf8(svargs[svix - 1]);
5246 * The "%_" hack might have to be changed someday,
5247 * if ISO or ANSI decide to use '_' for something.
5248 * So we keep it hidden from users' code.
5252 eptr = SvPVx(va_arg(*args, SV*), elen);
5255 if (has_precis && elen > precis)
5263 uv = PTR2UV(va_arg(*args, void*));
5265 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5280 case 'h': iv = (short)va_arg(*args, int); break;
5281 default: iv = va_arg(*args, int); break;
5282 case 'l': iv = va_arg(*args, long); break;
5283 case 'V': iv = va_arg(*args, IV); break;
5285 case 'q': iv = va_arg(*args, Quad_t); break;
5290 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5292 case 'h': iv = (short)iv; break;
5293 default: iv = (int)iv; break;
5294 case 'l': iv = (long)iv; break;
5297 case 'q': iv = (Quad_t)iv; break;
5304 esignbuf[esignlen++] = plus;
5308 esignbuf[esignlen++] = '-';
5346 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5347 default: uv = va_arg(*args, unsigned); break;
5348 case 'l': uv = va_arg(*args, unsigned long); break;
5349 case 'V': uv = va_arg(*args, UV); break;
5351 case 'q': uv = va_arg(*args, Quad_t); break;
5356 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5358 case 'h': uv = (unsigned short)uv; break;
5359 default: uv = (unsigned)uv; break;
5360 case 'l': uv = (unsigned long)uv; break;
5363 case 'q': uv = (Quad_t)uv; break;
5369 eptr = ebuf + sizeof ebuf;
5375 p = (char*)((c == 'X')
5376 ? "0123456789ABCDEF" : "0123456789abcdef");
5382 esignbuf[esignlen++] = '0';
5383 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5389 *--eptr = '0' + dig;
5391 if (alt && *eptr != '0')
5397 *--eptr = '0' + dig;
5400 esignbuf[esignlen++] = '0';
5401 esignbuf[esignlen++] = 'b';
5404 default: /* it had better be ten or less */
5405 #if defined(PERL_Y2KWARN)
5406 if (ckWARN(WARN_MISC)) {
5408 char *s = SvPV(sv,n);
5409 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5410 && (n == 2 || !isDIGIT(s[n-3])))
5412 Perl_warner(aTHX_ WARN_MISC,
5413 "Possible Y2K bug: %%%c %s",
5414 c, "format string following '19'");
5420 *--eptr = '0' + dig;
5421 } while (uv /= base);
5424 elen = (ebuf + sizeof ebuf) - eptr;
5427 zeros = precis - elen;
5428 else if (precis == 0 && elen == 1 && *eptr == '0')
5433 /* FLOATING POINT */
5436 c = 'f'; /* maybe %F isn't supported here */
5442 /* This is evil, but floating point is even more evil */
5445 nv = va_arg(*args, NV);
5447 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5450 if (c != 'e' && c != 'E') {
5452 (void)frexp(nv, &i);
5453 if (i == PERL_INT_MIN)
5454 Perl_die(aTHX_ "panic: frexp");
5456 need = BIT_DIGITS(i);
5458 need += has_precis ? precis : 6; /* known default */
5462 need += 20; /* fudge factor */
5463 if (PL_efloatsize < need) {
5464 Safefree(PL_efloatbuf);
5465 PL_efloatsize = need + 20; /* more fudge */
5466 New(906, PL_efloatbuf, PL_efloatsize, char);
5467 PL_efloatbuf[0] = '\0';
5470 eptr = ebuf + sizeof ebuf;
5473 #ifdef USE_LONG_DOUBLE
5475 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5476 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5481 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5486 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5499 RESTORE_NUMERIC_STANDARD();
5500 (void)sprintf(PL_efloatbuf, eptr, nv);
5501 RESTORE_NUMERIC_LOCAL();
5504 eptr = PL_efloatbuf;
5505 elen = strlen(PL_efloatbuf);
5511 i = SvCUR(sv) - origlen;
5514 case 'h': *(va_arg(*args, short*)) = i; break;
5515 default: *(va_arg(*args, int*)) = i; break;
5516 case 'l': *(va_arg(*args, long*)) = i; break;
5517 case 'V': *(va_arg(*args, IV*)) = i; break;
5519 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5523 else if (svix < svmax)
5524 sv_setuv(svargs[svix++], (UV)i);
5525 continue; /* not "break" */
5531 if (!args && ckWARN(WARN_PRINTF) &&
5532 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5533 SV *msg = sv_newmortal();
5534 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5535 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5538 Perl_sv_catpvf(aTHX_ msg,
5539 "\"%%%c\"", c & 0xFF);
5541 Perl_sv_catpvf(aTHX_ msg,
5542 "\"%%\\%03"UVof"\"",
5545 sv_catpv(msg, "end of string");
5546 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5549 /* output mangled stuff ... */
5555 /* ... right here, because formatting flags should not apply */
5556 SvGROW(sv, SvCUR(sv) + elen + 1);
5558 memcpy(p, eptr, elen);
5561 SvCUR(sv) = p - SvPVX(sv);
5562 continue; /* not "break" */
5565 have = esignlen + zeros + elen;
5566 need = (have > width ? have : width);
5569 SvGROW(sv, SvCUR(sv) + need + 1);
5571 if (esignlen && fill == '0') {
5572 for (i = 0; i < esignlen; i++)
5576 memset(p, fill, gap);
5579 if (esignlen && fill != '0') {
5580 for (i = 0; i < esignlen; i++)
5584 for (i = zeros; i; i--)
5588 memcpy(p, eptr, elen);
5592 memset(p, ' ', gap);
5596 SvCUR(sv) = p - SvPVX(sv);
5600 #if defined(USE_ITHREADS)
5602 #if defined(USE_THREADS)
5603 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
5606 #ifndef OpREFCNT_inc
5607 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
5610 #ifndef GpREFCNT_inc
5611 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5615 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5616 #define av_dup(s) (AV*)sv_dup((SV*)s)
5617 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5618 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5619 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5620 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5621 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5622 #define io_dup(s) (IO*)sv_dup((SV*)s)
5623 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5624 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5625 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5626 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5627 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5630 Perl_re_dup(pTHX_ REGEXP *r)
5632 /* XXX fix when pmop->op_pmregexp becomes shared */
5633 return ReREFCNT_inc(r);
5637 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5640 return (PerlIO*)NULL;
5641 return fp; /* XXX */
5642 /* return PerlIO_fdopen(PerlIO_fileno(fp),
5643 type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5647 Perl_dirp_dup(pTHX_ DIR *dp)
5656 Perl_gp_dup(pTHX_ GP *gp)
5661 /* look for it in the table first */
5662 ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp);
5666 /* create anew and remember what it is */
5667 Newz(0, ret, 1, GP);
5668 sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret);
5671 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5672 ret->gp_io = io_dup_inc(gp->gp_io);
5673 ret->gp_form = cv_dup_inc(gp->gp_form);
5674 ret->gp_av = av_dup_inc(gp->gp_av);
5675 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5677 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5678 ret->gp_cvgen = gp->gp_cvgen;
5679 ret->gp_flags = gp->gp_flags;
5680 ret->gp_line = gp->gp_line;
5681 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5687 Perl_mg_dup(pTHX_ MAGIC *mg)
5689 MAGIC *mgret = (MAGIC*)NULL;
5692 return (MAGIC*)NULL;
5693 /* XXX need to handle aliases here? */
5695 for (; mg; mg = mg->mg_moremagic) {
5697 Newz(0, nmg, 1, MAGIC);
5701 mgprev->mg_moremagic = nmg;
5702 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5703 nmg->mg_private = mg->mg_private;
5704 nmg->mg_type = mg->mg_type;
5705 nmg->mg_flags = mg->mg_flags;
5706 if (mg->mg_type == 'r') {
5707 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5710 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5711 ? sv_dup_inc(mg->mg_obj)
5712 : sv_dup(mg->mg_obj);
5714 nmg->mg_len = mg->mg_len;
5715 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5716 if (mg->mg_ptr && mg->mg_type != 'g') {
5717 if (mg->mg_len >= 0) {
5718 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5719 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5720 AMT *amtp = (AMT*)mg->mg_ptr;
5721 AMT *namtp = (AMT*)nmg->mg_ptr;
5723 for (i = 1; i < NofAMmeth; i++) {
5724 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5728 else if (mg->mg_len == HEf_SVKEY)
5729 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5737 Perl_sv_table_new(pTHX)
5740 Newz(0, tbl, 1, SVTBL);
5743 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*);
5748 Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv)
5753 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5754 for (; tblent; tblent = tblent->next) {
5755 if (tblent->oldval == sv)
5756 return tblent->newval;
5762 Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new)
5764 SVTBLENT *tblent, **otblent;
5768 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5769 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5770 if (tblent->oldval == old) {
5771 tblent->newval = new;
5776 Newz(0, tblent, 1, SVTBLENT);
5777 tblent->oldval = old;
5778 tblent->newval = new;
5779 tblent->next = *otblent;
5782 if (i && tbl->tbl_items > tbl->tbl_max)
5783 sv_table_split(tbl);
5787 Perl_sv_table_split(pTHX_ SVTBL *tbl)
5789 SVTBLENT **ary = tbl->tbl_ary;
5790 UV oldsize = tbl->tbl_max + 1;
5791 UV newsize = oldsize * 2;
5794 Renew(ary, newsize, SVTBLENT*);
5795 Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*);
5796 tbl->tbl_max = --newsize;
5798 for (i=0; i < oldsize; i++, ary++) {
5799 SVTBLENT **curentp, **entp, *ent;
5802 curentp = ary + oldsize;
5803 for (entp = ary, ent = *ary; ent; ent = *entp) {
5804 if ((newsize & (UV)ent->oldval) != i) {
5806 ent->next = *curentp;
5817 DllExport char *PL_watch_pvx;
5821 Perl_sv_dup(pTHX_ SV *sstr)
5828 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5830 /* look for it in the table first */
5831 dstr = sv_table_fetch(PL_sv_table, sstr);
5835 /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */
5837 /* create anew and remember what it is */
5839 sv_table_store(PL_sv_table, sstr, dstr);
5842 SvFLAGS(dstr) = SvFLAGS(sstr);
5843 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5847 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5848 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5849 PL_watch_pvx, SvPVX(sstr));
5852 switch (SvTYPE(sstr)) {
5857 SvANY(dstr) = new_XIV();
5858 SvIVX(dstr) = SvIVX(sstr);
5861 SvANY(dstr) = new_XNV();
5862 SvNVX(dstr) = SvNVX(sstr);
5865 SvANY(dstr) = new_XRV();
5866 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5869 SvANY(dstr) = new_XPV();
5870 SvCUR(dstr) = SvCUR(sstr);
5871 SvLEN(dstr) = SvLEN(sstr);
5873 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5874 else if (SvPVX(sstr) && SvLEN(sstr))
5875 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5877 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5880 SvANY(dstr) = new_XPVIV();
5881 SvCUR(dstr) = SvCUR(sstr);
5882 SvLEN(dstr) = SvLEN(sstr);
5883 SvIVX(dstr) = SvIVX(sstr);
5885 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5886 else if (SvPVX(sstr) && SvLEN(sstr))
5887 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5889 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5892 SvANY(dstr) = new_XPVNV();
5893 SvCUR(dstr) = SvCUR(sstr);
5894 SvLEN(dstr) = SvLEN(sstr);
5895 SvIVX(dstr) = SvIVX(sstr);
5896 SvNVX(dstr) = SvNVX(sstr);
5898 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5899 else if (SvPVX(sstr) && SvLEN(sstr))
5900 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5902 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5905 SvANY(dstr) = new_XPVMG();
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 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5913 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5914 else if (SvPVX(sstr) && SvLEN(sstr))
5915 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5917 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5920 SvANY(dstr) = new_XPVBM();
5921 SvCUR(dstr) = SvCUR(sstr);
5922 SvLEN(dstr) = SvLEN(sstr);
5923 SvIVX(dstr) = SvIVX(sstr);
5924 SvNVX(dstr) = SvNVX(sstr);
5925 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5926 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5928 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5929 else if (SvPVX(sstr) && SvLEN(sstr))
5930 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5932 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5933 BmRARE(dstr) = BmRARE(sstr);
5934 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5935 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5938 SvANY(dstr) = new_XPVLV();
5939 SvCUR(dstr) = SvCUR(sstr);
5940 SvLEN(dstr) = SvLEN(sstr);
5941 SvIVX(dstr) = SvIVX(sstr);
5942 SvNVX(dstr) = SvNVX(sstr);
5943 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5944 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5946 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5947 else if (SvPVX(sstr) && SvLEN(sstr))
5948 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5950 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5951 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5952 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5953 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5954 LvTYPE(dstr) = LvTYPE(sstr);
5957 SvANY(dstr) = new_XPVGV();
5958 SvCUR(dstr) = SvCUR(sstr);
5959 SvLEN(dstr) = SvLEN(sstr);
5960 SvIVX(dstr) = SvIVX(sstr);
5961 SvNVX(dstr) = SvNVX(sstr);
5962 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5963 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5965 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5966 else if (SvPVX(sstr) && SvLEN(sstr))
5967 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5969 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5970 GvNAMELEN(dstr) = GvNAMELEN(sstr);
5971 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5972 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
5973 GvFLAGS(dstr) = GvFLAGS(sstr);
5974 GvGP(dstr) = gp_dup(GvGP(sstr));
5975 (void)GpREFCNT_inc(GvGP(dstr));
5976 if (GvEGV(sstr) == (GV*)sstr)
5977 GvEGV(dstr) = (GV*)dstr;
5979 GvEGV(dstr) = gv_dup_inc(GvEGV(sstr));
5982 SvANY(dstr) = new_XPVIO();
5983 SvCUR(dstr) = SvCUR(sstr);
5984 SvLEN(dstr) = SvLEN(sstr);
5985 SvIVX(dstr) = SvIVX(sstr);
5986 SvNVX(dstr) = SvNVX(sstr);
5987 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5988 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5990 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5991 else if (SvPVX(sstr) && SvLEN(sstr))
5992 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5994 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5995 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
5996 if (IoOFP(sstr) == IoIFP(sstr))
5997 IoOFP(dstr) = IoIFP(dstr);
5999 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6000 /* PL_rsfp_filters entries have fake IoDIRP() */
6001 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6002 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6004 IoDIRP(dstr) = IoDIRP(sstr);
6005 IoLINES(dstr) = IoLINES(sstr);
6006 IoPAGE(dstr) = IoPAGE(sstr);
6007 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6008 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6009 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6010 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6011 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6012 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6013 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6014 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6015 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6016 IoTYPE(dstr) = IoTYPE(sstr);
6017 IoFLAGS(dstr) = IoFLAGS(sstr);
6020 SvANY(dstr) = new_XPVAV();
6021 SvCUR(dstr) = SvCUR(sstr);
6022 SvLEN(dstr) = SvLEN(sstr);
6023 SvIVX(dstr) = SvIVX(sstr);
6024 SvNVX(dstr) = SvNVX(sstr);
6025 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6026 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6027 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6028 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6029 if (AvALLOC((AV*)sstr)) {
6030 SV **dst_ary, **src_ary;
6031 SSize_t items = AvFILLp((AV*)sstr) + 1;
6033 src_ary = AvALLOC((AV*)sstr);
6034 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6035 SvPVX(dstr) = (char*)dst_ary;
6036 AvALLOC((AV*)dstr) = dst_ary;
6037 if (AvREAL((AV*)sstr)) {
6039 *dst_ary++ = sv_dup_inc(*src_ary++);
6043 *dst_ary++ = sv_dup(*src_ary++);
6045 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6046 while (items-- > 0) {
6047 *dst_ary++ = &PL_sv_undef;
6051 SvPVX(dstr) = Nullch;
6052 AvALLOC((AV*)dstr) = (SV**)NULL;
6056 SvANY(dstr) = new_XPVHV();
6057 SvCUR(dstr) = SvCUR(sstr);
6058 SvLEN(dstr) = SvLEN(sstr);
6059 SvIVX(dstr) = SvIVX(sstr);
6060 SvNVX(dstr) = SvNVX(sstr);
6061 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6062 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6063 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6064 if (HvARRAY((HV*)sstr)) {
6067 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6068 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6069 Newz(0, dxhv->xhv_array,
6070 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6071 while (i <= sxhv->xhv_max) {
6072 HE *dentry, *oentry;
6073 entry = ((HE**)sxhv->xhv_array)[i];
6074 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6075 ((HE**)dxhv->xhv_array)[i] = dentry;
6077 entry = HeNEXT(entry);
6079 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6080 HeNEXT(oentry) = dentry;
6084 if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6085 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6086 while (entry && entry != sxhv->xhv_eiter)
6087 entry = HeNEXT(entry);
6088 dxhv->xhv_eiter = entry;
6091 dxhv->xhv_eiter = (HE*)NULL;
6094 SvPVX(dstr) = Nullch;
6095 HvEITER((HV*)dstr) = (HE*)NULL;
6097 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6098 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6101 SvANY(dstr) = new_XPVFM();
6105 SvANY(dstr) = new_XPVCV();
6107 SvCUR(dstr) = SvCUR(sstr);
6108 SvLEN(dstr) = SvLEN(sstr);
6109 SvIVX(dstr) = SvIVX(sstr);
6110 SvNVX(dstr) = SvNVX(sstr);
6111 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6112 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6113 if (SvPVX(sstr) && SvLEN(sstr))
6114 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6116 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6117 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6118 CvSTART(dstr) = CvSTART(sstr);
6119 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6120 CvXSUB(dstr) = CvXSUB(sstr);
6121 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6122 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6123 CvDEPTH(dstr) = CvDEPTH(sstr);
6124 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6125 /* XXX padlists are real, but pretend to be not */
6126 AvREAL_on(CvPADLIST(sstr));
6127 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6128 AvREAL_off(CvPADLIST(sstr));
6129 AvREAL_off(CvPADLIST(dstr));
6132 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6133 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6134 CvFLAGS(dstr) = CvFLAGS(sstr);
6137 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6148 perl_clone_using(PerlInterpreter *proto_perl, IV flags,
6149 struct IPerlMem* ipM, struct IPerlEnv* ipE,
6150 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6151 struct IPerlDir* ipD, struct IPerlSock* ipS,
6152 struct IPerlProc* ipP)
6157 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6158 PERL_SET_INTERP(my_perl);
6161 memset(my_perl, 0x0, sizeof(PerlInterpreter));
6168 Copy(proto_perl, my_perl, 1, PerlInterpreter);
6172 /* XXX many of the string copies here can be optimized if they're
6173 * constants; they need to be allocated as common memory and just
6174 * their pointers copied. */
6186 PL_xiv_arenaroot = NULL;
6191 PL_xpviv_root = NULL;
6192 PL_xpvnv_root = NULL;
6193 PL_xpvcv_root = NULL;
6194 PL_xpvav_root = NULL;
6195 PL_xpvhv_root = NULL;
6196 PL_xpvmg_root = NULL;
6197 PL_xpvlv_root = NULL;
6198 PL_xpvbm_root = NULL;
6200 PL_nice_chunk = NULL;
6201 PL_nice_chunk_size = 0;
6204 PL_sv_root = Nullsv;
6205 PL_sv_arenaroot = Nullsv;
6207 PL_debug = proto_perl->Idebug;
6209 /* create SV map for pointer relocation */
6210 PL_sv_table = sv_table_new();
6212 /* initialize these special pointers as early as possible */
6213 SvANY(&PL_sv_undef) = NULL;
6214 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6215 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6216 sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef);
6218 SvANY(&PL_sv_no) = new_XPVNV();
6219 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6220 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6221 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6222 SvCUR(&PL_sv_no) = 0;
6223 SvLEN(&PL_sv_no) = 1;
6224 SvNVX(&PL_sv_no) = 0;
6225 sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no);
6227 SvANY(&PL_sv_yes) = new_XPVNV();
6228 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6229 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6230 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6231 SvCUR(&PL_sv_yes) = 1;
6232 SvLEN(&PL_sv_yes) = 2;
6233 SvNVX(&PL_sv_yes) = 1;
6234 sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes);
6236 /* create shared string table */
6237 PL_strtab = newHV();
6238 HvSHAREKEYS_off(PL_strtab);
6239 hv_ksplit(PL_strtab, 512);
6240 sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab);
6242 PL_compiling = proto_perl->Icompiling;
6243 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6244 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6245 if (!specialWARN(PL_compiling.cop_warnings))
6246 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6247 if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6248 PL_curcop = &PL_compiling;
6250 PL_curcop = proto_perl->Tcurcop;
6252 /* pseudo environmental stuff */
6253 PL_origargc = proto_perl->Iorigargc;
6255 New(0, PL_origargv, i+1, char*);
6256 PL_origargv[i] = '\0';
6258 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6260 PL_envgv = gv_dup(proto_perl->Ienvgv);
6261 PL_incgv = gv_dup(proto_perl->Iincgv);
6262 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6263 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6264 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6265 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6268 PL_minus_c = proto_perl->Iminus_c;
6269 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6270 PL_localpatches = proto_perl->Ilocalpatches;
6271 PL_splitstr = proto_perl->Isplitstr;
6272 PL_preprocess = proto_perl->Ipreprocess;
6273 PL_minus_n = proto_perl->Iminus_n;
6274 PL_minus_p = proto_perl->Iminus_p;
6275 PL_minus_l = proto_perl->Iminus_l;
6276 PL_minus_a = proto_perl->Iminus_a;
6277 PL_minus_F = proto_perl->Iminus_F;
6278 PL_doswitches = proto_perl->Idoswitches;
6279 PL_dowarn = proto_perl->Idowarn;
6280 PL_doextract = proto_perl->Idoextract;
6281 PL_sawampersand = proto_perl->Isawampersand;
6282 PL_unsafe = proto_perl->Iunsafe;
6283 PL_inplace = SAVEPV(proto_perl->Iinplace);
6284 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6285 PL_perldb = proto_perl->Iperldb;
6286 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6288 /* magical thingies */
6289 /* XXX time(&PL_basetime) instead? */
6290 PL_basetime = proto_perl->Ibasetime;
6291 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6293 PL_maxsysfd = proto_perl->Imaxsysfd;
6294 PL_multiline = proto_perl->Imultiline;
6295 PL_statusvalue = proto_perl->Istatusvalue;
6297 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6300 /* shortcuts to various I/O objects */
6301 PL_stdingv = gv_dup(proto_perl->Istdingv);
6302 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6303 PL_defgv = gv_dup(proto_perl->Idefgv);
6304 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6305 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6306 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6308 /* shortcuts to regexp stuff */
6309 PL_replgv = gv_dup(proto_perl->Ireplgv);
6311 /* shortcuts to misc objects */
6312 PL_errgv = gv_dup(proto_perl->Ierrgv);
6314 /* shortcuts to debugging objects */
6315 PL_DBgv = gv_dup(proto_perl->IDBgv);
6316 PL_DBline = gv_dup(proto_perl->IDBline);
6317 PL_DBsub = gv_dup(proto_perl->IDBsub);
6318 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6319 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6320 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6321 PL_lineary = av_dup(proto_perl->Ilineary);
6322 PL_dbargs = av_dup(proto_perl->Idbargs);
6325 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6326 PL_curstash = hv_dup(proto_perl->Tcurstash);
6327 PL_debstash = hv_dup(proto_perl->Idebstash);
6328 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6329 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6331 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6332 PL_endav = av_dup_inc(proto_perl->Iendav);
6333 PL_stopav = av_dup_inc(proto_perl->Istopav);
6334 PL_initav = av_dup_inc(proto_perl->Iinitav);
6336 PL_sub_generation = proto_perl->Isub_generation;
6338 /* funky return mechanisms */
6339 PL_forkprocess = proto_perl->Iforkprocess;
6341 /* subprocess state */
6342 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6344 /* internal state */
6345 PL_tainting = proto_perl->Itainting;
6346 PL_maxo = proto_perl->Imaxo;
6347 if (proto_perl->Iop_mask)
6348 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6350 PL_op_mask = Nullch;
6352 /* current interpreter roots */
6353 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6354 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6355 PL_main_start = proto_perl->Imain_start;
6356 PL_eval_root = proto_perl->Ieval_root;
6357 PL_eval_start = proto_perl->Ieval_start;
6359 /* runtime control stuff */
6360 PL_curcopdb = proto_perl->Icurcopdb;
6361 PL_copline = proto_perl->Icopline;
6363 PL_filemode = proto_perl->Ifilemode;
6364 PL_lastfd = proto_perl->Ilastfd;
6365 PL_oldname = proto_perl->Ioldname; /* XXX */
6368 PL_gensym = proto_perl->Igensym;
6369 PL_preambled = proto_perl->Ipreambled;
6370 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6371 PL_laststatval = proto_perl->Ilaststatval;
6372 PL_laststype = proto_perl->Ilaststype;
6373 PL_mess_sv = Nullsv;
6375 PL_orslen = proto_perl->Iorslen;
6376 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6377 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6379 /* interpreter atexit processing */
6380 PL_exitlistlen = proto_perl->Iexitlistlen;
6381 if (PL_exitlistlen) {
6382 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6383 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6386 PL_exitlist = (PerlExitListEntry*)NULL;
6387 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6389 PL_profiledata = NULL; /* XXX */
6390 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6391 /* XXX PL_rsfp_filters entries have fake IoDIRP() */
6392 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6394 PL_compcv = cv_dup(proto_perl->Icompcv);
6395 PL_comppad = av_dup(proto_perl->Icomppad);
6396 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6397 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6398 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6399 PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
6401 #ifdef HAVE_INTERP_INTERN
6402 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6405 /* more statics moved here */
6406 PL_generation = proto_perl->Igeneration;
6407 PL_DBcv = cv_dup(proto_perl->IDBcv);
6408 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6410 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6411 PL_in_clean_all = proto_perl->Iin_clean_all;
6413 PL_uid = proto_perl->Iuid;
6414 PL_euid = proto_perl->Ieuid;
6415 PL_gid = proto_perl->Igid;
6416 PL_egid = proto_perl->Iegid;
6417 PL_nomemok = proto_perl->Inomemok;
6418 PL_an = proto_perl->Ian;
6419 PL_cop_seqmax = proto_perl->Icop_seqmax;
6420 PL_op_seqmax = proto_perl->Iop_seqmax;
6421 PL_evalseq = proto_perl->Ievalseq;
6422 PL_origenviron = proto_perl->Iorigenviron; /* XXX */
6423 PL_origalen = proto_perl->Iorigalen;
6424 PL_pidstatus = newHV();
6425 PL_osname = SAVEPV(proto_perl->Iosname);
6426 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6427 PL_sighandlerp = proto_perl->Isighandlerp;
6430 PL_runops = proto_perl->Irunops;
6432 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */
6435 PL_cshlen = proto_perl->Icshlen;
6436 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6439 PL_lex_state = proto_perl->Ilex_state;
6440 PL_lex_defer = proto_perl->Ilex_defer;
6441 PL_lex_expect = proto_perl->Ilex_expect;
6442 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6443 PL_lex_fakebrack = proto_perl->Ilex_fakebrack;
6444 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6445 PL_lex_starts = proto_perl->Ilex_starts;
6446 PL_lex_stuff = Nullsv; /* XXX */
6447 PL_lex_repl = Nullsv; /* XXX */
6448 PL_lex_op = proto_perl->Ilex_op;
6449 PL_lex_inpat = proto_perl->Ilex_inpat;
6450 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6451 PL_lex_brackets = proto_perl->Ilex_brackets;
6452 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6453 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6454 PL_lex_casemods = proto_perl->Ilex_casemods;
6455 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6456 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6458 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6459 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6460 PL_nexttoke = proto_perl->Inexttoke;
6462 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6463 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6464 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6465 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6466 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6467 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6468 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6469 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6470 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6471 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6472 PL_pending_ident = proto_perl->Ipending_ident;
6473 PL_sublex_info = proto_perl->Isublex_info; /* XXX */
6475 PL_expect = proto_perl->Iexpect;
6477 PL_multi_start = proto_perl->Imulti_start;
6478 PL_multi_end = proto_perl->Imulti_end;
6479 PL_multi_open = proto_perl->Imulti_open;
6480 PL_multi_close = proto_perl->Imulti_close;
6482 PL_error_count = proto_perl->Ierror_count;
6483 PL_subline = proto_perl->Isubline;
6484 PL_subname = sv_dup_inc(proto_perl->Isubname);
6486 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6487 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6488 PL_padix = proto_perl->Ipadix;
6489 PL_padix_floor = proto_perl->Ipadix_floor;
6490 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6492 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6493 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6494 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6495 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6496 PL_last_lop_op = proto_perl->Ilast_lop_op;
6497 PL_in_my = proto_perl->Iin_my;
6498 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6500 PL_cryptseen = proto_perl->Icryptseen;
6503 PL_hints = proto_perl->Ihints;
6505 PL_amagic_generation = proto_perl->Iamagic_generation;
6507 #ifdef USE_LOCALE_COLLATE
6508 PL_collation_ix = proto_perl->Icollation_ix;
6509 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6510 PL_collation_standard = proto_perl->Icollation_standard;
6511 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6512 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6513 #endif /* USE_LOCALE_COLLATE */
6515 #ifdef USE_LOCALE_NUMERIC
6516 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6517 PL_numeric_standard = proto_perl->Inumeric_standard;
6518 PL_numeric_local = proto_perl->Inumeric_local;
6519 PL_numeric_radix = proto_perl->Inumeric_radix;
6520 #endif /* !USE_LOCALE_NUMERIC */
6522 /* utf8 character classes */
6523 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6524 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6525 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6526 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6527 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6528 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6529 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6530 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6531 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6532 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6533 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6534 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6535 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6536 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6537 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6538 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6539 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6542 PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */
6543 PL_last_swash_klen = 0;
6544 PL_last_swash_key[0]= '\0';
6545 PL_last_swash_tmps = Nullch;
6546 PL_last_swash_slen = 0;
6548 /* perly.c globals */
6549 PL_yydebug = proto_perl->Iyydebug;
6550 PL_yynerrs = proto_perl->Iyynerrs;
6551 PL_yyerrflag = proto_perl->Iyyerrflag;
6552 PL_yychar = proto_perl->Iyychar;
6553 PL_yyval = proto_perl->Iyyval;
6554 PL_yylval = proto_perl->Iyylval;
6556 PL_glob_index = proto_perl->Iglob_index;
6557 PL_srand_called = proto_perl->Isrand_called;
6558 PL_uudmap['M'] = 0; /* reinit on demand */
6559 PL_bitcount = Nullch; /* reinit on demand */
6562 /* thrdvar.h stuff */
6564 /* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo);
6566 PL_mainstack = av_dup(proto_perl->Tmainstack);
6567 PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */
6570 PL_op = proto_perl->Top;
6571 PL_statbuf = proto_perl->Tstatbuf;
6572 PL_statcache = proto_perl->Tstatcache;
6573 PL_statgv = gv_dup(proto_perl->Tstatgv);
6574 PL_statname = sv_dup_inc(proto_perl->Tstatname);
6576 PL_timesbuf = proto_perl->Ttimesbuf;
6579 PL_tainted = proto_perl->Ttainted;
6580 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
6581 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
6582 PL_rs = sv_dup_inc(proto_perl->Trs);
6583 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
6584 PL_ofslen = proto_perl->Tofslen;
6585 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6586 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
6587 PL_chopset = proto_perl->Tchopset; /* XXX */
6588 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
6589 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
6590 PL_formtarget = sv_dup(proto_perl->Tformtarget);
6592 PL_restartop = proto_perl->Trestartop;
6593 PL_in_eval = proto_perl->Tin_eval;
6594 PL_delaymagic = proto_perl->Tdelaymagic;
6595 PL_dirty = proto_perl->Tdirty;
6596 PL_localizing = proto_perl->Tlocalizing;
6598 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
6599 PL_top_env = &PL_start_env;
6600 PL_protect = proto_perl->Tprotect;
6601 PL_errors = sv_dup_inc(proto_perl->Terrors);
6602 PL_av_fetch_sv = Nullsv;
6603 PL_hv_fetch_sv = Nullsv;
6604 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
6605 PL_modcount = proto_perl->Tmodcount;
6606 PL_lastgotoprobe = Nullop;
6607 PL_dumpindent = proto_perl->Tdumpindent;
6608 PL_sortstash = hv_dup(proto_perl->Tsortstash);
6609 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
6610 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
6611 PL_sortcxix = proto_perl->Tsortcxix;
6612 PL_efloatbuf = Nullch;
6615 PL_screamfirst = NULL;
6616 PL_screamnext = NULL;
6618 PL_lastscream = Nullsv;
6620 /* RE engine - function pointers */
6621 PL_regcompp = proto_perl->Tregcompp;
6622 PL_regexecp = proto_perl->Tregexecp;
6623 PL_regint_start = proto_perl->Tregint_start;
6624 PL_regint_string = proto_perl->Tregint_string;
6625 PL_regfree = proto_perl->Tregfree;
6628 PL_reginterp_cnt = 0;
6629 PL_reg_start_tmp = 0;
6630 PL_reg_start_tmpl = 0;
6631 PL_reg_poscache = Nullch;
6633 PL_watchaddr = NULL;
6634 PL_watchok = Nullch;
6640 perl_clone(pTHXx_ IV flags)
6642 return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6643 PL_Dir, PL_Sock, PL_Proc);
6646 #endif /* USE_ITHREADS */
6653 do_report_used(pTHXo_ SV *sv)
6655 if (SvTYPE(sv) != SVTYPEMASK) {
6656 PerlIO_printf(Perl_debug_log, "****\n");
6662 do_clean_objs(pTHXo_ SV *sv)
6666 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6667 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6673 /* XXX Might want to check arrays, etc. */
6676 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6678 do_clean_named_objs(pTHXo_ SV *sv)
6680 if (SvTYPE(sv) == SVt_PVGV) {
6681 if ( SvOBJECT(GvSV(sv)) ||
6682 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6683 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6684 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6685 GvCV(sv) && SvOBJECT(GvCV(sv)) )
6687 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6695 do_clean_all(pTHXo_ SV *sv)
6697 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6698 SvFLAGS(sv) |= SVf_BREAK;