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_ne(PL_curcop, GvSTASH(dstr)))
2375 GvIMPORTED_on(dstr);
2386 sv_upgrade(dstr, SVt_PV);
2389 if (dtype < SVt_PVIV)
2390 sv_upgrade(dstr, SVt_PVIV);
2393 if (dtype < SVt_PVNV)
2394 sv_upgrade(dstr, SVt_PVNV);
2401 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2402 PL_op_name[PL_op->op_type]);
2404 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2408 if (dtype <= SVt_PVGV) {
2410 if (dtype != SVt_PVGV) {
2411 char *name = GvNAME(sstr);
2412 STRLEN len = GvNAMELEN(sstr);
2413 sv_upgrade(dstr, SVt_PVGV);
2414 sv_magic(dstr, dstr, '*', name, len);
2415 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2416 GvNAME(dstr) = savepvn(name, len);
2417 GvNAMELEN(dstr) = len;
2418 SvFAKE_on(dstr); /* can coerce to non-glob */
2420 /* ahem, death to those who redefine active sort subs */
2421 else if (PL_curstackinfo->si_type == PERLSI_SORT
2422 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2423 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2425 (void)SvOK_off(dstr);
2426 GvINTRO_off(dstr); /* one-shot flag */
2428 GvGP(dstr) = gp_ref(GvGP(sstr));
2430 if (GvIMPORTED(dstr) != GVf_IMPORTED
2431 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2433 GvIMPORTED_on(dstr);
2441 if (SvGMAGICAL(sstr)) {
2443 if (SvTYPE(sstr) != stype) {
2444 stype = SvTYPE(sstr);
2445 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2449 if (stype == SVt_PVLV)
2450 (void)SvUPGRADE(dstr, SVt_PVNV);
2452 (void)SvUPGRADE(dstr, stype);
2455 sflags = SvFLAGS(sstr);
2457 if (sflags & SVf_ROK) {
2458 if (dtype >= SVt_PV) {
2459 if (dtype == SVt_PVGV) {
2460 SV *sref = SvREFCNT_inc(SvRV(sstr));
2462 int intro = GvINTRO(dstr);
2467 GvINTRO_off(dstr); /* one-shot flag */
2468 Newz(602,gp, 1, GP);
2469 GvGP(dstr) = gp_ref(gp);
2470 GvSV(dstr) = NEWSV(72,0);
2471 GvLINE(dstr) = CopLINE(PL_curcop);
2472 GvEGV(dstr) = (GV*)dstr;
2475 switch (SvTYPE(sref)) {
2478 SAVESPTR(GvAV(dstr));
2480 dref = (SV*)GvAV(dstr);
2481 GvAV(dstr) = (AV*)sref;
2482 if (GvIMPORTED_AV_off(dstr)
2483 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2485 GvIMPORTED_AV_on(dstr);
2490 SAVESPTR(GvHV(dstr));
2492 dref = (SV*)GvHV(dstr);
2493 GvHV(dstr) = (HV*)sref;
2494 if (GvIMPORTED_HV_off(dstr)
2495 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2497 GvIMPORTED_HV_on(dstr);
2502 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2503 SvREFCNT_dec(GvCV(dstr));
2504 GvCV(dstr) = Nullcv;
2505 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2506 PL_sub_generation++;
2508 SAVESPTR(GvCV(dstr));
2511 dref = (SV*)GvCV(dstr);
2512 if (GvCV(dstr) != (CV*)sref) {
2513 CV* cv = GvCV(dstr);
2515 if (!GvCVGEN((GV*)dstr) &&
2516 (CvROOT(cv) || CvXSUB(cv)))
2518 SV *const_sv = cv_const_sv(cv);
2519 bool const_changed = TRUE;
2521 const_changed = sv_cmp(const_sv,
2522 op_const_sv(CvSTART((CV*)sref),
2524 /* ahem, death to those who redefine
2525 * active sort subs */
2526 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2527 PL_sortcop == CvSTART(cv))
2529 "Can't redefine active sort subroutine %s",
2530 GvENAME((GV*)dstr));
2531 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2532 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2533 && HvNAME(GvSTASH(CvGV(cv)))
2534 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2536 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2537 "Constant subroutine %s redefined"
2538 : "Subroutine %s redefined",
2539 GvENAME((GV*)dstr));
2542 cv_ckproto(cv, (GV*)dstr,
2543 SvPOK(sref) ? SvPVX(sref) : Nullch);
2545 GvCV(dstr) = (CV*)sref;
2546 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2547 GvASSUMECV_on(dstr);
2548 PL_sub_generation++;
2550 if (GvIMPORTED_CV_off(dstr)
2551 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2553 GvIMPORTED_CV_on(dstr);
2558 SAVESPTR(GvIOp(dstr));
2560 dref = (SV*)GvIOp(dstr);
2561 GvIOp(dstr) = (IO*)sref;
2565 SAVESPTR(GvSV(dstr));
2567 dref = (SV*)GvSV(dstr);
2569 if (GvIMPORTED_SV_off(dstr)
2570 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2572 GvIMPORTED_SV_on(dstr);
2584 (void)SvOOK_off(dstr); /* backoff */
2586 Safefree(SvPVX(dstr));
2587 SvLEN(dstr)=SvCUR(dstr)=0;
2590 (void)SvOK_off(dstr);
2591 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2593 if (sflags & SVp_NOK) {
2595 SvNVX(dstr) = SvNVX(sstr);
2597 if (sflags & SVp_IOK) {
2598 (void)SvIOK_on(dstr);
2599 SvIVX(dstr) = SvIVX(sstr);
2603 if (SvAMAGIC(sstr)) {
2607 else if (sflags & SVp_POK) {
2610 * Check to see if we can just swipe the string. If so, it's a
2611 * possible small lose on short strings, but a big win on long ones.
2612 * It might even be a win on short strings if SvPVX(dstr)
2613 * has to be allocated and SvPVX(sstr) has to be freed.
2616 if (SvTEMP(sstr) && /* slated for free anyway? */
2617 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2618 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2620 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2622 SvFLAGS(dstr) &= ~SVf_OOK;
2623 Safefree(SvPVX(dstr) - SvIVX(dstr));
2625 else if (SvLEN(dstr))
2626 Safefree(SvPVX(dstr));
2628 (void)SvPOK_only(dstr);
2629 SvPV_set(dstr, SvPVX(sstr));
2630 SvLEN_set(dstr, SvLEN(sstr));
2631 SvCUR_set(dstr, SvCUR(sstr));
2633 (void)SvOK_off(sstr);
2634 SvPV_set(sstr, Nullch);
2639 else { /* have to copy actual string */
2640 STRLEN len = SvCUR(sstr);
2642 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2643 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2644 SvCUR_set(dstr, len);
2645 *SvEND(dstr) = '\0';
2646 (void)SvPOK_only(dstr);
2649 if (sflags & SVp_NOK) {
2651 SvNVX(dstr) = SvNVX(sstr);
2653 if (sflags & SVp_IOK) {
2654 (void)SvIOK_on(dstr);
2655 SvIVX(dstr) = SvIVX(sstr);
2660 else if (sflags & SVp_NOK) {
2661 SvNVX(dstr) = SvNVX(sstr);
2662 (void)SvNOK_only(dstr);
2664 (void)SvIOK_on(dstr);
2665 SvIVX(dstr) = SvIVX(sstr);
2666 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2671 else if (sflags & SVp_IOK) {
2672 (void)SvIOK_only(dstr);
2673 SvIVX(dstr) = SvIVX(sstr);
2678 if (dtype == SVt_PVGV) {
2679 if (ckWARN(WARN_UNSAFE))
2680 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2683 (void)SvOK_off(dstr);
2689 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2691 sv_setsv(dstr,sstr);
2696 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2698 register char *dptr;
2699 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2700 elicit a warning, but it won't hurt. */
2701 SV_CHECK_THINKFIRST(sv);
2706 (void)SvUPGRADE(sv, SVt_PV);
2708 SvGROW(sv, len + 1);
2710 Move(ptr,dptr,len,char);
2713 (void)SvPOK_only(sv); /* validate pointer */
2718 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2720 sv_setpvn(sv,ptr,len);
2725 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2727 register STRLEN len;
2729 SV_CHECK_THINKFIRST(sv);
2735 (void)SvUPGRADE(sv, SVt_PV);
2737 SvGROW(sv, len + 1);
2738 Move(ptr,SvPVX(sv),len+1,char);
2740 (void)SvPOK_only(sv); /* validate pointer */
2745 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2752 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2754 SV_CHECK_THINKFIRST(sv);
2755 (void)SvUPGRADE(sv, SVt_PV);
2760 (void)SvOOK_off(sv);
2761 if (SvPVX(sv) && SvLEN(sv))
2762 Safefree(SvPVX(sv));
2763 Renew(ptr, len+1, char);
2766 SvLEN_set(sv, len+1);
2768 (void)SvPOK_only(sv); /* validate pointer */
2773 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2775 sv_usepvn(sv,ptr,len);
2780 Perl_sv_force_normal(pTHX_ register SV *sv)
2782 if (SvREADONLY(sv)) {
2784 if (PL_curcop != &PL_compiling)
2785 Perl_croak(aTHX_ PL_no_modify);
2789 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2794 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2798 register STRLEN delta;
2800 if (!ptr || !SvPOKp(sv))
2802 SV_CHECK_THINKFIRST(sv);
2803 if (SvTYPE(sv) < SVt_PVIV)
2804 sv_upgrade(sv,SVt_PVIV);
2807 if (!SvLEN(sv)) { /* make copy of shared string */
2808 char *pvx = SvPVX(sv);
2809 STRLEN len = SvCUR(sv);
2810 SvGROW(sv, len + 1);
2811 Move(pvx,SvPVX(sv),len,char);
2815 SvFLAGS(sv) |= SVf_OOK;
2817 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2818 delta = ptr - SvPVX(sv);
2826 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2831 junk = SvPV_force(sv, tlen);
2832 SvGROW(sv, tlen + len + 1);
2835 Move(ptr,SvPVX(sv)+tlen,len,char);
2838 (void)SvPOK_only(sv); /* validate pointer */
2843 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2845 sv_catpvn(sv,ptr,len);
2850 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2856 if (s = SvPV(sstr, len))
2857 sv_catpvn(dstr,s,len);
2861 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2863 sv_catsv(dstr,sstr);
2868 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2870 register STRLEN len;
2876 junk = SvPV_force(sv, tlen);
2878 SvGROW(sv, tlen + len + 1);
2881 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2883 (void)SvPOK_only(sv); /* validate pointer */
2888 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2895 Perl_newSV(pTHX_ STRLEN len)
2901 sv_upgrade(sv, SVt_PV);
2902 SvGROW(sv, len + 1);
2907 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2910 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2914 if (SvREADONLY(sv)) {
2916 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2917 Perl_croak(aTHX_ PL_no_modify);
2919 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2920 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2927 (void)SvUPGRADE(sv, SVt_PVMG);
2929 Newz(702,mg, 1, MAGIC);
2930 mg->mg_moremagic = SvMAGIC(sv);
2933 if (!obj || obj == sv || how == '#' || how == 'r')
2937 mg->mg_obj = SvREFCNT_inc(obj);
2938 mg->mg_flags |= MGf_REFCOUNTED;
2941 mg->mg_len = namlen;
2944 mg->mg_ptr = savepvn(name, namlen);
2945 else if (namlen == HEf_SVKEY)
2946 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2950 mg->mg_virtual = &PL_vtbl_sv;
2953 mg->mg_virtual = &PL_vtbl_amagic;
2956 mg->mg_virtual = &PL_vtbl_amagicelem;
2962 mg->mg_virtual = &PL_vtbl_bm;
2965 mg->mg_virtual = &PL_vtbl_regdata;
2968 mg->mg_virtual = &PL_vtbl_regdatum;
2971 mg->mg_virtual = &PL_vtbl_env;
2974 mg->mg_virtual = &PL_vtbl_fm;
2977 mg->mg_virtual = &PL_vtbl_envelem;
2980 mg->mg_virtual = &PL_vtbl_mglob;
2983 mg->mg_virtual = &PL_vtbl_isa;
2986 mg->mg_virtual = &PL_vtbl_isaelem;
2989 mg->mg_virtual = &PL_vtbl_nkeys;
2996 mg->mg_virtual = &PL_vtbl_dbline;
3000 mg->mg_virtual = &PL_vtbl_mutex;
3002 #endif /* USE_THREADS */
3003 #ifdef USE_LOCALE_COLLATE
3005 mg->mg_virtual = &PL_vtbl_collxfrm;
3007 #endif /* USE_LOCALE_COLLATE */
3009 mg->mg_virtual = &PL_vtbl_pack;
3013 mg->mg_virtual = &PL_vtbl_packelem;
3016 mg->mg_virtual = &PL_vtbl_regexp;
3019 mg->mg_virtual = &PL_vtbl_sig;
3022 mg->mg_virtual = &PL_vtbl_sigelem;
3025 mg->mg_virtual = &PL_vtbl_taint;
3029 mg->mg_virtual = &PL_vtbl_uvar;
3032 mg->mg_virtual = &PL_vtbl_vec;
3035 mg->mg_virtual = &PL_vtbl_substr;
3038 mg->mg_virtual = &PL_vtbl_defelem;
3041 mg->mg_virtual = &PL_vtbl_glob;
3044 mg->mg_virtual = &PL_vtbl_arylen;
3047 mg->mg_virtual = &PL_vtbl_pos;
3050 mg->mg_virtual = &PL_vtbl_backref;
3052 case '~': /* Reserved for use by extensions not perl internals. */
3053 /* Useful for attaching extension internal data to perl vars. */
3054 /* Note that multiple extensions may clash if magical scalars */
3055 /* etc holding private data from one are passed to another. */
3059 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3063 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3067 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3071 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3074 for (mg = *mgp; mg; mg = *mgp) {
3075 if (mg->mg_type == type) {
3076 MGVTBL* vtbl = mg->mg_virtual;
3077 *mgp = mg->mg_moremagic;
3078 if (vtbl && vtbl->svt_free)
3079 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3080 if (mg->mg_ptr && mg->mg_type != 'g')
3081 if (mg->mg_len >= 0)
3082 Safefree(mg->mg_ptr);
3083 else if (mg->mg_len == HEf_SVKEY)
3084 SvREFCNT_dec((SV*)mg->mg_ptr);
3085 if (mg->mg_flags & MGf_REFCOUNTED)
3086 SvREFCNT_dec(mg->mg_obj);
3090 mgp = &mg->mg_moremagic;
3094 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3101 Perl_sv_rvweaken(pTHX_ SV *sv)
3104 if (!SvOK(sv)) /* let undefs pass */
3107 Perl_croak(aTHX_ "Can't weaken a nonreference");
3108 else if (SvWEAKREF(sv)) {
3110 if (ckWARN(WARN_MISC))
3111 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3115 sv_add_backref(tsv, sv);
3122 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3126 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3127 av = (AV*)mg->mg_obj;
3130 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3131 SvREFCNT_dec(av); /* for sv_magic */
3137 S_sv_del_backref(pTHX_ SV *sv)
3144 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3145 Perl_croak(aTHX_ "panic: del_backref");
3146 av = (AV *)mg->mg_obj;
3151 svp[i] = &PL_sv_undef; /* XXX */
3158 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3162 register char *midend;
3163 register char *bigend;
3169 Perl_croak(aTHX_ "Can't modify non-existent substring");
3170 SvPV_force(bigstr, curlen);
3171 if (offset + len > curlen) {
3172 SvGROW(bigstr, offset+len+1);
3173 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3174 SvCUR_set(bigstr, offset+len);
3177 i = littlelen - len;
3178 if (i > 0) { /* string might grow */
3179 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3180 mid = big + offset + len;
3181 midend = bigend = big + SvCUR(bigstr);
3184 while (midend > mid) /* shove everything down */
3185 *--bigend = *--midend;
3186 Move(little,big+offset,littlelen,char);
3192 Move(little,SvPVX(bigstr)+offset,len,char);
3197 big = SvPVX(bigstr);
3200 bigend = big + SvCUR(bigstr);
3202 if (midend > bigend)
3203 Perl_croak(aTHX_ "panic: sv_insert");
3205 if (mid - big > bigend - midend) { /* faster to shorten from end */
3207 Move(little, mid, littlelen,char);
3210 i = bigend - midend;
3212 Move(midend, mid, i,char);
3216 SvCUR_set(bigstr, mid - big);
3219 else if (i = mid - big) { /* faster from front */
3220 midend -= littlelen;
3222 sv_chop(bigstr,midend-i);
3227 Move(little, mid, littlelen,char);
3229 else if (littlelen) {
3230 midend -= littlelen;
3231 sv_chop(bigstr,midend);
3232 Move(little,midend,littlelen,char);
3235 sv_chop(bigstr,midend);
3240 /* make sv point to what nstr did */
3243 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3246 U32 refcnt = SvREFCNT(sv);
3247 SV_CHECK_THINKFIRST(sv);
3248 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3249 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3250 if (SvMAGICAL(sv)) {
3254 sv_upgrade(nsv, SVt_PVMG);
3255 SvMAGIC(nsv) = SvMAGIC(sv);
3256 SvFLAGS(nsv) |= SvMAGICAL(sv);
3262 assert(!SvREFCNT(sv));
3263 StructCopy(nsv,sv,SV);
3264 SvREFCNT(sv) = refcnt;
3265 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3270 Perl_sv_clear(pTHX_ register SV *sv)
3274 assert(SvREFCNT(sv) == 0);
3278 if (PL_defstash) { /* Still have a symbol table? */
3283 Zero(&tmpref, 1, SV);
3284 sv_upgrade(&tmpref, SVt_RV);
3286 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3287 SvREFCNT(&tmpref) = 1;
3290 stash = SvSTASH(sv);
3291 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3294 PUSHSTACKi(PERLSI_DESTROY);
3295 SvRV(&tmpref) = SvREFCNT_inc(sv);
3300 call_sv((SV*)GvCV(destructor),
3301 G_DISCARD|G_EVAL|G_KEEPERR);
3307 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3309 del_XRV(SvANY(&tmpref));
3312 if (PL_in_clean_objs)
3313 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3315 /* DESTROY gave object new lease on life */
3321 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3322 SvOBJECT_off(sv); /* Curse the object. */
3323 if (SvTYPE(sv) != SVt_PVIO)
3324 --PL_sv_objcount; /* XXX Might want something more general */
3327 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3330 switch (SvTYPE(sv)) {
3333 IoIFP(sv) != PerlIO_stdin() &&
3334 IoIFP(sv) != PerlIO_stdout() &&
3335 IoIFP(sv) != PerlIO_stderr())
3337 io_close((IO*)sv, FALSE);
3339 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3340 PerlDir_close(IoDIRP(sv));
3341 IoDIRP(sv) = (DIR*)NULL;
3342 Safefree(IoTOP_NAME(sv));
3343 Safefree(IoFMT_NAME(sv));
3344 Safefree(IoBOTTOM_NAME(sv));
3359 SvREFCNT_dec(LvTARG(sv));
3363 Safefree(GvNAME(sv));
3364 /* cannot decrease stash refcount yet, as we might recursively delete
3365 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3366 of stash until current sv is completely gone.
3367 -- JohnPC, 27 Mar 1998 */
3368 stash = GvSTASH(sv);
3374 (void)SvOOK_off(sv);
3382 SvREFCNT_dec(SvRV(sv));
3384 else if (SvPVX(sv) && SvLEN(sv))
3385 Safefree(SvPVX(sv));
3395 switch (SvTYPE(sv)) {
3411 del_XPVIV(SvANY(sv));
3414 del_XPVNV(SvANY(sv));
3417 del_XPVMG(SvANY(sv));
3420 del_XPVLV(SvANY(sv));
3423 del_XPVAV(SvANY(sv));
3426 del_XPVHV(SvANY(sv));
3429 del_XPVCV(SvANY(sv));
3432 del_XPVGV(SvANY(sv));
3433 /* code duplication for increased performance. */
3434 SvFLAGS(sv) &= SVf_BREAK;
3435 SvFLAGS(sv) |= SVTYPEMASK;
3436 /* decrease refcount of the stash that owns this GV, if any */
3438 SvREFCNT_dec(stash);
3439 return; /* not break, SvFLAGS reset already happened */
3441 del_XPVBM(SvANY(sv));
3444 del_XPVFM(SvANY(sv));
3447 del_XPVIO(SvANY(sv));
3450 SvFLAGS(sv) &= SVf_BREAK;
3451 SvFLAGS(sv) |= SVTYPEMASK;
3455 Perl_sv_newref(pTHX_ SV *sv)
3458 ATOMIC_INC(SvREFCNT(sv));
3463 Perl_sv_free(pTHX_ SV *sv)
3466 int refcount_is_zero;
3470 if (SvREFCNT(sv) == 0) {
3471 if (SvFLAGS(sv) & SVf_BREAK)
3473 if (PL_in_clean_all) /* All is fair */
3475 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3476 /* make sure SvREFCNT(sv)==0 happens very seldom */
3477 SvREFCNT(sv) = (~(U32)0)/2;
3480 if (ckWARN_d(WARN_INTERNAL))
3481 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3484 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3485 if (!refcount_is_zero)
3489 if (ckWARN_d(WARN_DEBUGGING))
3490 Perl_warner(aTHX_ WARN_DEBUGGING,
3491 "Attempt to free temp prematurely: SV 0x%"UVxf,
3496 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3497 /* make sure SvREFCNT(sv)==0 happens very seldom */
3498 SvREFCNT(sv) = (~(U32)0)/2;
3507 Perl_sv_len(pTHX_ register SV *sv)
3516 len = mg_length(sv);
3518 junk = SvPV(sv, len);
3523 Perl_sv_len_utf8(pTHX_ register SV *sv)
3534 len = mg_length(sv);
3537 s = (U8*)SvPV(sv, len);
3548 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3553 I32 uoffset = *offsetp;
3559 start = s = (U8*)SvPV(sv, len);
3561 while (s < send && uoffset--)
3565 *offsetp = s - start;
3569 while (s < send && ulen--)
3579 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3588 s = (U8*)SvPV(sv, len);
3590 Perl_croak(aTHX_ "panic: bad byte offset");
3591 send = s + *offsetp;
3599 if (ckWARN_d(WARN_UTF8))
3600 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3608 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3620 pv1 = SvPV(str1, cur1);
3625 pv2 = SvPV(str2, cur2);
3630 return memEQ(pv1, pv2, cur1);
3634 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3637 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3639 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3643 return cur2 ? -1 : 0;
3648 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3651 return retval < 0 ? -1 : 1;
3656 return cur1 < cur2 ? -1 : 1;
3660 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3662 #ifdef USE_LOCALE_COLLATE
3668 if (PL_collation_standard)
3672 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3674 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3676 if (!pv1 || !len1) {
3687 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3690 return retval < 0 ? -1 : 1;
3693 * When the result of collation is equality, that doesn't mean
3694 * that there are no differences -- some locales exclude some
3695 * characters from consideration. So to avoid false equalities,
3696 * we use the raw string as a tiebreaker.
3702 #endif /* USE_LOCALE_COLLATE */
3704 return sv_cmp(sv1, sv2);
3707 #ifdef USE_LOCALE_COLLATE
3709 * Any scalar variable may carry an 'o' magic that contains the
3710 * scalar data of the variable transformed to such a format that
3711 * a normal memory comparison can be used to compare the data
3712 * according to the locale settings.
3715 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3719 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3720 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3725 Safefree(mg->mg_ptr);
3727 if ((xf = mem_collxfrm(s, len, &xlen))) {
3728 if (SvREADONLY(sv)) {
3731 return xf + sizeof(PL_collation_ix);
3734 sv_magic(sv, 0, 'o', 0, 0);
3735 mg = mg_find(sv, 'o');
3748 if (mg && mg->mg_ptr) {
3750 return mg->mg_ptr + sizeof(PL_collation_ix);
3758 #endif /* USE_LOCALE_COLLATE */
3761 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3766 register STDCHAR rslast;
3767 register STDCHAR *bp;
3771 SV_CHECK_THINKFIRST(sv);
3772 (void)SvUPGRADE(sv, SVt_PV);
3776 if (RsSNARF(PL_rs)) {
3780 else if (RsRECORD(PL_rs)) {
3781 I32 recsize, bytesread;
3784 /* Grab the size of the record we're getting */
3785 recsize = SvIV(SvRV(PL_rs));
3786 (void)SvPOK_only(sv); /* Validate pointer */
3787 buffer = SvGROW(sv, recsize + 1);
3790 /* VMS wants read instead of fread, because fread doesn't respect */
3791 /* RMS record boundaries. This is not necessarily a good thing to be */
3792 /* doing, but we've got no other real choice */
3793 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3795 bytesread = PerlIO_read(fp, buffer, recsize);
3797 SvCUR_set(sv, bytesread);
3798 buffer[bytesread] = '\0';
3799 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3801 else if (RsPARA(PL_rs)) {
3806 rsptr = SvPV(PL_rs, rslen);
3807 rslast = rslen ? rsptr[rslen - 1] : '\0';
3809 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3810 do { /* to make sure file boundaries work right */
3813 i = PerlIO_getc(fp);
3817 PerlIO_ungetc(fp,i);
3823 /* See if we know enough about I/O mechanism to cheat it ! */
3825 /* This used to be #ifdef test - it is made run-time test for ease
3826 of abstracting out stdio interface. One call should be cheap
3827 enough here - and may even be a macro allowing compile
3831 if (PerlIO_fast_gets(fp)) {
3834 * We're going to steal some values from the stdio struct
3835 * and put EVERYTHING in the innermost loop into registers.
3837 register STDCHAR *ptr;
3841 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3842 /* An ungetc()d char is handled separately from the regular
3843 * buffer, so we getc() it back out and stuff it in the buffer.
3845 i = PerlIO_getc(fp);
3846 if (i == EOF) return 0;
3847 *(--((*fp)->_ptr)) = (unsigned char) i;
3851 /* Here is some breathtakingly efficient cheating */
3853 cnt = PerlIO_get_cnt(fp); /* get count into register */
3854 (void)SvPOK_only(sv); /* validate pointer */
3855 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3856 if (cnt > 80 && SvLEN(sv) > append) {
3857 shortbuffered = cnt - SvLEN(sv) + append + 1;
3858 cnt -= shortbuffered;
3862 /* remember that cnt can be negative */
3863 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3868 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3869 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3870 DEBUG_P(PerlIO_printf(Perl_debug_log,
3871 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3872 DEBUG_P(PerlIO_printf(Perl_debug_log,
3873 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3874 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3875 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3880 while (cnt > 0) { /* this | eat */
3882 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3883 goto thats_all_folks; /* screams | sed :-) */
3887 Copy(ptr, bp, cnt, char); /* this | eat */
3888 bp += cnt; /* screams | dust */
3889 ptr += cnt; /* louder | sed :-) */
3894 if (shortbuffered) { /* oh well, must extend */
3895 cnt = shortbuffered;
3897 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3899 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3900 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3904 DEBUG_P(PerlIO_printf(Perl_debug_log,
3905 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3906 PTR2UV(ptr),(long)cnt));
3907 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3908 DEBUG_P(PerlIO_printf(Perl_debug_log,
3909 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3910 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3911 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3912 /* This used to call 'filbuf' in stdio form, but as that behaves like
3913 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3914 another abstraction. */
3915 i = PerlIO_getc(fp); /* get more characters */
3916 DEBUG_P(PerlIO_printf(Perl_debug_log,
3917 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3918 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3919 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3920 cnt = PerlIO_get_cnt(fp);
3921 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3922 DEBUG_P(PerlIO_printf(Perl_debug_log,
3923 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3925 if (i == EOF) /* all done for ever? */
3926 goto thats_really_all_folks;
3928 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3930 SvGROW(sv, bpx + cnt + 2);
3931 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3933 *bp++ = i; /* store character from PerlIO_getc */
3935 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3936 goto thats_all_folks;
3940 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3941 memNE((char*)bp - rslen, rsptr, rslen))
3942 goto screamer; /* go back to the fray */
3943 thats_really_all_folks:
3945 cnt += shortbuffered;
3946 DEBUG_P(PerlIO_printf(Perl_debug_log,
3947 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3948 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3949 DEBUG_P(PerlIO_printf(Perl_debug_log,
3950 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3951 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3952 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3954 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3955 DEBUG_P(PerlIO_printf(Perl_debug_log,
3956 "Screamer: done, len=%ld, string=|%.*s|\n",
3957 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3962 /*The big, slow, and stupid way */
3965 /* Need to work around EPOC SDK features */
3966 /* On WINS: MS VC5 generates calls to _chkstk, */
3967 /* if a `large' stack frame is allocated */
3968 /* gcc on MARM does not generate calls like these */
3974 register STDCHAR *bpe = buf + sizeof(buf);
3976 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3977 ; /* keep reading */
3981 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3982 /* Accomodate broken VAXC compiler, which applies U8 cast to
3983 * both args of ?: operator, causing EOF to change into 255
3985 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3989 sv_catpvn(sv, (char *) buf, cnt);
3991 sv_setpvn(sv, (char *) buf, cnt);
3993 if (i != EOF && /* joy */
3995 SvCUR(sv) < rslen ||
3996 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4000 * If we're reading from a TTY and we get a short read,
4001 * indicating that the user hit his EOF character, we need
4002 * to notice it now, because if we try to read from the TTY
4003 * again, the EOF condition will disappear.
4005 * The comparison of cnt to sizeof(buf) is an optimization
4006 * that prevents unnecessary calls to feof().
4010 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4015 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4016 while (i != EOF) { /* to make sure file boundaries work right */
4017 i = PerlIO_getc(fp);
4019 PerlIO_ungetc(fp,i);
4026 win32_strip_return(sv);
4029 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4034 Perl_sv_inc(pTHX_ register SV *sv)
4043 if (SvTHINKFIRST(sv)) {
4044 if (SvREADONLY(sv)) {
4046 if (PL_curcop != &PL_compiling)
4047 Perl_croak(aTHX_ PL_no_modify);
4051 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4053 i = PTR2IV(SvRV(sv));
4058 flags = SvFLAGS(sv);
4059 if (flags & SVp_NOK) {
4060 (void)SvNOK_only(sv);
4064 if (flags & SVp_IOK) {
4066 if (SvUVX(sv) == UV_MAX)
4067 sv_setnv(sv, (NV)UV_MAX + 1.0);
4069 (void)SvIOK_only_UV(sv);
4072 if (SvIVX(sv) == IV_MAX)
4073 sv_setnv(sv, (NV)IV_MAX + 1.0);
4075 (void)SvIOK_only(sv);
4081 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4082 if ((flags & SVTYPEMASK) < SVt_PVNV)
4083 sv_upgrade(sv, SVt_NV);
4085 (void)SvNOK_only(sv);
4089 while (isALPHA(*d)) d++;
4090 while (isDIGIT(*d)) d++;
4092 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4096 while (d >= SvPVX(sv)) {
4104 /* MKS: The original code here died if letters weren't consecutive.
4105 * at least it didn't have to worry about non-C locales. The
4106 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4107 * arranged in order (although not consecutively) and that only
4108 * [A-Za-z] are accepted by isALPHA in the C locale.
4110 if (*d != 'z' && *d != 'Z') {
4111 do { ++*d; } while (!isALPHA(*d));
4114 *(d--) -= 'z' - 'a';
4119 *(d--) -= 'z' - 'a' + 1;
4123 /* oh,oh, the number grew */
4124 SvGROW(sv, SvCUR(sv) + 2);
4126 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4135 Perl_sv_dec(pTHX_ register SV *sv)
4143 if (SvTHINKFIRST(sv)) {
4144 if (SvREADONLY(sv)) {
4146 if (PL_curcop != &PL_compiling)
4147 Perl_croak(aTHX_ PL_no_modify);
4151 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4153 i = PTR2IV(SvRV(sv));
4158 flags = SvFLAGS(sv);
4159 if (flags & SVp_NOK) {
4161 (void)SvNOK_only(sv);
4164 if (flags & SVp_IOK) {
4166 if (SvUVX(sv) == 0) {
4167 (void)SvIOK_only(sv);
4171 (void)SvIOK_only_UV(sv);
4175 if (SvIVX(sv) == IV_MIN)
4176 sv_setnv(sv, (NV)IV_MIN - 1.0);
4178 (void)SvIOK_only(sv);
4184 if (!(flags & SVp_POK)) {
4185 if ((flags & SVTYPEMASK) < SVt_PVNV)
4186 sv_upgrade(sv, SVt_NV);
4188 (void)SvNOK_only(sv);
4191 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4194 /* Make a string that will exist for the duration of the expression
4195 * evaluation. Actually, it may have to last longer than that, but
4196 * hopefully we won't free it until it has been assigned to a
4197 * permanent location. */
4200 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4206 sv_setsv(sv,oldstr);
4208 PL_tmps_stack[++PL_tmps_ix] = sv;
4214 Perl_sv_newmortal(pTHX)
4220 SvFLAGS(sv) = SVs_TEMP;
4222 PL_tmps_stack[++PL_tmps_ix] = sv;
4226 /* same thing without the copying */
4229 Perl_sv_2mortal(pTHX_ register SV *sv)
4234 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4237 PL_tmps_stack[++PL_tmps_ix] = sv;
4243 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4250 sv_setpvn(sv,s,len);
4255 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4260 sv_setpvn(sv,s,len);
4264 #if defined(PERL_IMPLICIT_CONTEXT)
4266 Perl_newSVpvf_nocontext(const char* pat, ...)
4271 va_start(args, pat);
4272 sv = vnewSVpvf(pat, &args);
4279 Perl_newSVpvf(pTHX_ const char* pat, ...)
4283 va_start(args, pat);
4284 sv = vnewSVpvf(pat, &args);
4290 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4294 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4299 Perl_newSVnv(pTHX_ NV n)
4309 Perl_newSViv(pTHX_ IV i)
4319 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4325 sv_upgrade(sv, SVt_RV);
4333 Perl_newRV(pTHX_ SV *tmpRef)
4335 return newRV_noinc(SvREFCNT_inc(tmpRef));
4338 /* make an exact duplicate of old */
4341 Perl_newSVsv(pTHX_ register SV *old)
4348 if (SvTYPE(old) == SVTYPEMASK) {
4349 if (ckWARN_d(WARN_INTERNAL))
4350 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4365 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4373 char todo[PERL_UCHAR_MAX+1];
4378 if (!*s) { /* reset ?? searches */
4379 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4380 pm->op_pmdynflags &= ~PMdf_USED;
4385 /* reset variables */
4387 if (!HvARRAY(stash))
4390 Zero(todo, 256, char);
4392 i = (unsigned char)*s;
4396 max = (unsigned char)*s++;
4397 for ( ; i <= max; i++) {
4400 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4401 for (entry = HvARRAY(stash)[i];
4403 entry = HeNEXT(entry))
4405 if (!todo[(U8)*HeKEY(entry)])
4407 gv = (GV*)HeVAL(entry);
4409 if (SvTHINKFIRST(sv)) {
4410 if (!SvREADONLY(sv) && SvROK(sv))
4415 if (SvTYPE(sv) >= SVt_PV) {
4417 if (SvPVX(sv) != Nullch)
4424 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4426 #ifndef VMS /* VMS has no environ array */
4428 environ[0] = Nullch;
4437 Perl_sv_2io(pTHX_ SV *sv)
4443 switch (SvTYPE(sv)) {
4451 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4455 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4457 return sv_2io(SvRV(sv));
4458 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4464 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4471 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4478 return *gvp = Nullgv, Nullcv;
4479 switch (SvTYPE(sv)) {
4499 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4500 tryAMAGICunDEREF(to_cv);
4503 if (SvTYPE(sv) == SVt_PVCV) {
4512 Perl_croak(aTHX_ "Not a subroutine reference");
4517 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4523 if (lref && !GvCVu(gv)) {
4526 tmpsv = NEWSV(704,0);
4527 gv_efullname3(tmpsv, gv, Nullch);
4528 /* XXX this is probably not what they think they're getting.
4529 * It has the same effect as "sub name;", i.e. just a forward
4531 newSUB(start_subparse(FALSE, 0),
4532 newSVOP(OP_CONST, 0, tmpsv),
4537 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4544 Perl_sv_true(pTHX_ register SV *sv)
4551 if ((tXpv = (XPV*)SvANY(sv)) &&
4552 (*tXpv->xpv_pv > '0' ||
4553 tXpv->xpv_cur > 1 ||
4554 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4561 return SvIVX(sv) != 0;
4564 return SvNVX(sv) != 0.0;
4566 return sv_2bool(sv);
4572 Perl_sv_iv(pTHX_ register SV *sv)
4576 return (IV)SvUVX(sv);
4583 Perl_sv_uv(pTHX_ register SV *sv)
4588 return (UV)SvIVX(sv);
4594 Perl_sv_nv(pTHX_ register SV *sv)
4602 Perl_sv_pv(pTHX_ SV *sv)
4609 return sv_2pv(sv, &n_a);
4613 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4619 return sv_2pv(sv, lp);
4623 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4627 if (SvTHINKFIRST(sv) && !SvROK(sv))
4628 sv_force_normal(sv);
4634 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4636 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4637 PL_op_name[PL_op->op_type]);
4641 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4646 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4647 SvGROW(sv, len + 1);
4648 Move(s,SvPVX(sv),len,char);
4653 SvPOK_on(sv); /* validate pointer */
4655 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4656 PTR2UV(sv),SvPVX(sv)));
4663 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4665 if (ob && SvOBJECT(sv))
4666 return HvNAME(SvSTASH(sv));
4668 switch (SvTYPE(sv)) {
4682 case SVt_PVLV: return "LVALUE";
4683 case SVt_PVAV: return "ARRAY";
4684 case SVt_PVHV: return "HASH";
4685 case SVt_PVCV: return "CODE";
4686 case SVt_PVGV: return "GLOB";
4687 case SVt_PVFM: return "FORMAT";
4688 default: return "UNKNOWN";
4694 Perl_sv_isobject(pTHX_ SV *sv)
4709 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4721 return strEQ(HvNAME(SvSTASH(sv)), name);
4725 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4732 SV_CHECK_THINKFIRST(rv);
4735 if (SvTYPE(rv) < SVt_RV)
4736 sv_upgrade(rv, SVt_RV);
4743 HV* stash = gv_stashpv(classname, TRUE);
4744 (void)sv_bless(rv, stash);
4750 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4753 sv_setsv(rv, &PL_sv_undef);
4757 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4762 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4764 sv_setiv(newSVrv(rv,classname), iv);
4769 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4771 sv_setnv(newSVrv(rv,classname), nv);
4776 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4778 sv_setpvn(newSVrv(rv,classname), pv, n);
4783 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4788 Perl_croak(aTHX_ "Can't bless non-reference value");
4790 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4791 if (SvREADONLY(tmpRef))
4792 Perl_croak(aTHX_ PL_no_modify);
4793 if (SvOBJECT(tmpRef)) {
4794 if (SvTYPE(tmpRef) != SVt_PVIO)
4796 SvREFCNT_dec(SvSTASH(tmpRef));
4799 SvOBJECT_on(tmpRef);
4800 if (SvTYPE(tmpRef) != SVt_PVIO)
4802 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4803 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4814 S_sv_unglob(pTHX_ SV *sv)
4816 assert(SvTYPE(sv) == SVt_PVGV);
4821 SvREFCNT_dec(GvSTASH(sv));
4822 GvSTASH(sv) = Nullhv;
4824 sv_unmagic(sv, '*');
4825 Safefree(GvNAME(sv));
4827 SvFLAGS(sv) &= ~SVTYPEMASK;
4828 SvFLAGS(sv) |= SVt_PVMG;
4832 Perl_sv_unref(pTHX_ SV *sv)
4836 if (SvWEAKREF(sv)) {
4844 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4847 sv_2mortal(rv); /* Schedule for freeing later */
4851 Perl_sv_taint(pTHX_ SV *sv)
4853 sv_magic((sv), Nullsv, 't', Nullch, 0);
4857 Perl_sv_untaint(pTHX_ SV *sv)
4859 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4860 MAGIC *mg = mg_find(sv, 't');
4867 Perl_sv_tainted(pTHX_ SV *sv)
4869 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4870 MAGIC *mg = mg_find(sv, 't');
4871 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4878 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4880 char buf[TYPE_CHARS(UV)];
4882 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4884 sv_setpvn(sv, ptr, ebuf - ptr);
4889 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4891 char buf[TYPE_CHARS(UV)];
4893 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4895 sv_setpvn(sv, ptr, ebuf - ptr);
4899 #if defined(PERL_IMPLICIT_CONTEXT)
4901 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4905 va_start(args, pat);
4906 sv_vsetpvf(sv, pat, &args);
4912 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4916 va_start(args, pat);
4917 sv_vsetpvf_mg(sv, pat, &args);
4923 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4926 va_start(args, pat);
4927 sv_vsetpvf(sv, pat, &args);
4932 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4934 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4938 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4941 va_start(args, pat);
4942 sv_vsetpvf_mg(sv, pat, &args);
4947 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4949 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4953 #if defined(PERL_IMPLICIT_CONTEXT)
4955 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4959 va_start(args, pat);
4960 sv_vcatpvf(sv, pat, &args);
4965 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4969 va_start(args, pat);
4970 sv_vcatpvf_mg(sv, pat, &args);
4976 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4979 va_start(args, pat);
4980 sv_vcatpvf(sv, pat, &args);
4985 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4987 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4991 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4994 va_start(args, pat);
4995 sv_vcatpvf_mg(sv, pat, &args);
5000 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5002 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5007 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5009 sv_setpvn(sv, "", 0);
5010 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5014 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5022 static char nullstr[] = "(null)";
5024 /* no matter what, this is a string now */
5025 (void)SvPV_force(sv, origlen);
5027 /* special-case "", "%s", and "%_" */
5030 if (patlen == 2 && pat[0] == '%') {
5034 char *s = va_arg(*args, char*);
5035 sv_catpv(sv, s ? s : nullstr);
5037 else if (svix < svmax)
5038 sv_catsv(sv, *svargs);
5042 sv_catsv(sv, va_arg(*args, SV*));
5045 /* See comment on '_' below */
5050 patend = (char*)pat + patlen;
5051 for (p = (char*)pat; p < patend; p = q) {
5059 bool has_precis = FALSE;
5064 STRLEN esignlen = 0;
5066 char *eptr = Nullch;
5068 /* Times 4: a decimal digit takes more than 3 binary digits.
5069 * NV_DIG: mantissa takes than many decimal digits.
5070 * Plus 32: Playing safe. */
5071 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5072 /* large enough for "%#.#f" --chip */
5073 /* what about long double NVs? --jhi */
5084 for (q = p; q < patend && *q != '%'; ++q) ;
5086 sv_catpvn(sv, p, q - p);
5124 case '1': case '2': case '3':
5125 case '4': case '5': case '6':
5126 case '7': case '8': case '9':
5129 width = width * 10 + (*q++ - '0');
5134 i = va_arg(*args, int);
5136 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5138 width = (i < 0) ? -i : i;
5149 i = va_arg(*args, int);
5151 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5152 precis = (i < 0) ? 0 : i;
5158 precis = precis * 10 + (*q++ - '0');
5175 if (*(q + 1) == 'l') { /* lld */
5203 uv = va_arg(*args, int);
5205 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5207 eptr = (char*)utf8buf;
5208 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5212 c = va_arg(*args, int);
5214 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5221 eptr = va_arg(*args, char*);
5223 #ifdef MACOS_TRADITIONAL
5224 /* On MacOS, %#s format is used for Pascal strings */
5229 elen = strlen(eptr);
5232 elen = sizeof nullstr - 1;
5235 else if (svix < svmax) {
5236 eptr = SvPVx(svargs[svix++], elen);
5238 if (has_precis && precis < elen) {
5240 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5243 if (width) { /* fudge width (can't fudge elen) */
5244 width += elen - sv_len_utf8(svargs[svix - 1]);
5252 * The "%_" hack might have to be changed someday,
5253 * if ISO or ANSI decide to use '_' for something.
5254 * So we keep it hidden from users' code.
5258 eptr = SvPVx(va_arg(*args, SV*), elen);
5261 if (has_precis && elen > precis)
5269 uv = PTR2UV(va_arg(*args, void*));
5271 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5286 case 'h': iv = (short)va_arg(*args, int); break;
5287 default: iv = va_arg(*args, int); break;
5288 case 'l': iv = va_arg(*args, long); break;
5289 case 'V': iv = va_arg(*args, IV); break;
5291 case 'q': iv = va_arg(*args, Quad_t); break;
5296 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5298 case 'h': iv = (short)iv; break;
5299 default: iv = (int)iv; break;
5300 case 'l': iv = (long)iv; break;
5303 case 'q': iv = (Quad_t)iv; break;
5310 esignbuf[esignlen++] = plus;
5314 esignbuf[esignlen++] = '-';
5352 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5353 default: uv = va_arg(*args, unsigned); break;
5354 case 'l': uv = va_arg(*args, unsigned long); break;
5355 case 'V': uv = va_arg(*args, UV); break;
5357 case 'q': uv = va_arg(*args, Quad_t); break;
5362 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5364 case 'h': uv = (unsigned short)uv; break;
5365 default: uv = (unsigned)uv; break;
5366 case 'l': uv = (unsigned long)uv; break;
5369 case 'q': uv = (Quad_t)uv; break;
5375 eptr = ebuf + sizeof ebuf;
5381 p = (char*)((c == 'X')
5382 ? "0123456789ABCDEF" : "0123456789abcdef");
5388 esignbuf[esignlen++] = '0';
5389 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5395 *--eptr = '0' + dig;
5397 if (alt && *eptr != '0')
5403 *--eptr = '0' + dig;
5406 esignbuf[esignlen++] = '0';
5407 esignbuf[esignlen++] = 'b';
5410 default: /* it had better be ten or less */
5411 #if defined(PERL_Y2KWARN)
5412 if (ckWARN(WARN_MISC)) {
5414 char *s = SvPV(sv,n);
5415 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5416 && (n == 2 || !isDIGIT(s[n-3])))
5418 Perl_warner(aTHX_ WARN_MISC,
5419 "Possible Y2K bug: %%%c %s",
5420 c, "format string following '19'");
5426 *--eptr = '0' + dig;
5427 } while (uv /= base);
5430 elen = (ebuf + sizeof ebuf) - eptr;
5433 zeros = precis - elen;
5434 else if (precis == 0 && elen == 1 && *eptr == '0')
5439 /* FLOATING POINT */
5442 c = 'f'; /* maybe %F isn't supported here */
5448 /* This is evil, but floating point is even more evil */
5451 nv = va_arg(*args, NV);
5453 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5456 if (c != 'e' && c != 'E') {
5458 (void)frexp(nv, &i);
5459 if (i == PERL_INT_MIN)
5460 Perl_die(aTHX_ "panic: frexp");
5462 need = BIT_DIGITS(i);
5464 need += has_precis ? precis : 6; /* known default */
5468 need += 20; /* fudge factor */
5469 if (PL_efloatsize < need) {
5470 Safefree(PL_efloatbuf);
5471 PL_efloatsize = need + 20; /* more fudge */
5472 New(906, PL_efloatbuf, PL_efloatsize, char);
5473 PL_efloatbuf[0] = '\0';
5476 eptr = ebuf + sizeof ebuf;
5479 #ifdef USE_LONG_DOUBLE
5481 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5482 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5487 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5492 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5505 RESTORE_NUMERIC_STANDARD();
5506 (void)sprintf(PL_efloatbuf, eptr, nv);
5507 RESTORE_NUMERIC_LOCAL();
5510 eptr = PL_efloatbuf;
5511 elen = strlen(PL_efloatbuf);
5517 i = SvCUR(sv) - origlen;
5520 case 'h': *(va_arg(*args, short*)) = i; break;
5521 default: *(va_arg(*args, int*)) = i; break;
5522 case 'l': *(va_arg(*args, long*)) = i; break;
5523 case 'V': *(va_arg(*args, IV*)) = i; break;
5525 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5529 else if (svix < svmax)
5530 sv_setuv(svargs[svix++], (UV)i);
5531 continue; /* not "break" */
5537 if (!args && ckWARN(WARN_PRINTF) &&
5538 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5539 SV *msg = sv_newmortal();
5540 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5541 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5544 Perl_sv_catpvf(aTHX_ msg,
5545 "\"%%%c\"", c & 0xFF);
5547 Perl_sv_catpvf(aTHX_ msg,
5548 "\"%%\\%03"UVof"\"",
5551 sv_catpv(msg, "end of string");
5552 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5555 /* output mangled stuff ... */
5561 /* ... right here, because formatting flags should not apply */
5562 SvGROW(sv, SvCUR(sv) + elen + 1);
5564 memcpy(p, eptr, elen);
5567 SvCUR(sv) = p - SvPVX(sv);
5568 continue; /* not "break" */
5571 have = esignlen + zeros + elen;
5572 need = (have > width ? have : width);
5575 SvGROW(sv, SvCUR(sv) + need + 1);
5577 if (esignlen && fill == '0') {
5578 for (i = 0; i < esignlen; i++)
5582 memset(p, fill, gap);
5585 if (esignlen && fill != '0') {
5586 for (i = 0; i < esignlen; i++)
5590 for (i = zeros; i; i--)
5594 memcpy(p, eptr, elen);
5598 memset(p, ' ', gap);
5602 SvCUR(sv) = p - SvPVX(sv);
5606 #if defined(USE_ITHREADS)
5608 #if defined(USE_THREADS)
5609 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
5612 #ifndef OpREFCNT_inc
5613 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
5616 #ifndef GpREFCNT_inc
5617 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5621 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5622 #define av_dup(s) (AV*)sv_dup((SV*)s)
5623 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5624 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5625 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5626 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5627 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5628 #define io_dup(s) (IO*)sv_dup((SV*)s)
5629 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5630 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5631 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5632 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5633 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5636 Perl_re_dup(pTHX_ REGEXP *r)
5638 /* XXX fix when pmop->op_pmregexp becomes shared */
5639 return ReREFCNT_inc(r);
5643 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5646 return (PerlIO*)NULL;
5647 return fp; /* XXX */
5648 /* return PerlIO_fdopen(PerlIO_fileno(fp),
5649 type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5653 Perl_dirp_dup(pTHX_ DIR *dp)
5662 Perl_gp_dup(pTHX_ GP *gp)
5667 /* look for it in the table first */
5668 ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp);
5672 /* create anew and remember what it is */
5673 Newz(0, ret, 1, GP);
5674 sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret);
5677 ret->gp_refcnt = 0; /* must be before any other dups! */
5678 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5679 ret->gp_io = io_dup_inc(gp->gp_io);
5680 ret->gp_form = cv_dup_inc(gp->gp_form);
5681 ret->gp_av = av_dup_inc(gp->gp_av);
5682 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5683 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
5684 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5685 ret->gp_cvgen = gp->gp_cvgen;
5686 ret->gp_flags = gp->gp_flags;
5687 ret->gp_line = gp->gp_line;
5688 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5693 Perl_mg_dup(pTHX_ MAGIC *mg)
5695 MAGIC *mgret = (MAGIC*)NULL;
5698 return (MAGIC*)NULL;
5699 /* XXX need to handle aliases here? */
5701 for (; mg; mg = mg->mg_moremagic) {
5703 Newz(0, nmg, 1, MAGIC);
5707 mgprev->mg_moremagic = nmg;
5708 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5709 nmg->mg_private = mg->mg_private;
5710 nmg->mg_type = mg->mg_type;
5711 nmg->mg_flags = mg->mg_flags;
5712 if (mg->mg_type == 'r') {
5713 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5716 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5717 ? sv_dup_inc(mg->mg_obj)
5718 : sv_dup(mg->mg_obj);
5720 nmg->mg_len = mg->mg_len;
5721 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5722 if (mg->mg_ptr && mg->mg_type != 'g') {
5723 if (mg->mg_len >= 0) {
5724 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5725 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5726 AMT *amtp = (AMT*)mg->mg_ptr;
5727 AMT *namtp = (AMT*)nmg->mg_ptr;
5729 for (i = 1; i < NofAMmeth; i++) {
5730 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5734 else if (mg->mg_len == HEf_SVKEY)
5735 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5743 Perl_sv_table_new(pTHX)
5746 Newz(0, tbl, 1, SVTBL);
5749 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*);
5754 Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv)
5759 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5760 for (; tblent; tblent = tblent->next) {
5761 if (tblent->oldval == sv)
5762 return tblent->newval;
5768 Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new)
5770 SVTBLENT *tblent, **otblent;
5774 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5775 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5776 if (tblent->oldval == old) {
5777 tblent->newval = new;
5782 Newz(0, tblent, 1, SVTBLENT);
5783 tblent->oldval = old;
5784 tblent->newval = new;
5785 tblent->next = *otblent;
5788 if (i && tbl->tbl_items > tbl->tbl_max)
5789 sv_table_split(tbl);
5793 Perl_sv_table_split(pTHX_ SVTBL *tbl)
5795 SVTBLENT **ary = tbl->tbl_ary;
5796 UV oldsize = tbl->tbl_max + 1;
5797 UV newsize = oldsize * 2;
5800 Renew(ary, newsize, SVTBLENT*);
5801 Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*);
5802 tbl->tbl_max = --newsize;
5804 for (i=0; i < oldsize; i++, ary++) {
5805 SVTBLENT **curentp, **entp, *ent;
5808 curentp = ary + oldsize;
5809 for (entp = ary, ent = *ary; ent; ent = *entp) {
5810 if ((newsize & (UV)ent->oldval) != i) {
5812 ent->next = *curentp;
5823 DllExport char *PL_watch_pvx;
5827 Perl_sv_dup(pTHX_ SV *sstr)
5834 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5836 /* look for it in the table first */
5837 dstr = sv_table_fetch(PL_sv_table, sstr);
5841 /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */
5843 /* create anew and remember what it is */
5845 sv_table_store(PL_sv_table, sstr, dstr);
5848 SvFLAGS(dstr) = SvFLAGS(sstr);
5849 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5850 SvREFCNT(dstr) = 0; /* must be before any other dups! */
5853 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5854 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5855 PL_watch_pvx, SvPVX(sstr));
5858 switch (SvTYPE(sstr)) {
5863 SvANY(dstr) = new_XIV();
5864 SvIVX(dstr) = SvIVX(sstr);
5867 SvANY(dstr) = new_XNV();
5868 SvNVX(dstr) = SvNVX(sstr);
5871 SvANY(dstr) = new_XRV();
5872 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5875 SvANY(dstr) = new_XPV();
5876 SvCUR(dstr) = SvCUR(sstr);
5877 SvLEN(dstr) = SvLEN(sstr);
5879 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5880 else if (SvPVX(sstr) && SvLEN(sstr))
5881 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5883 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5886 SvANY(dstr) = new_XPVIV();
5887 SvCUR(dstr) = SvCUR(sstr);
5888 SvLEN(dstr) = SvLEN(sstr);
5889 SvIVX(dstr) = SvIVX(sstr);
5891 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5892 else if (SvPVX(sstr) && SvLEN(sstr))
5893 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5895 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5898 SvANY(dstr) = new_XPVNV();
5899 SvCUR(dstr) = SvCUR(sstr);
5900 SvLEN(dstr) = SvLEN(sstr);
5901 SvIVX(dstr) = SvIVX(sstr);
5902 SvNVX(dstr) = SvNVX(sstr);
5904 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5905 else if (SvPVX(sstr) && SvLEN(sstr))
5906 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5908 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5911 SvANY(dstr) = new_XPVMG();
5912 SvCUR(dstr) = SvCUR(sstr);
5913 SvLEN(dstr) = SvLEN(sstr);
5914 SvIVX(dstr) = SvIVX(sstr);
5915 SvNVX(dstr) = SvNVX(sstr);
5916 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5917 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5919 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5920 else if (SvPVX(sstr) && SvLEN(sstr))
5921 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5923 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5926 SvANY(dstr) = new_XPVBM();
5927 SvCUR(dstr) = SvCUR(sstr);
5928 SvLEN(dstr) = SvLEN(sstr);
5929 SvIVX(dstr) = SvIVX(sstr);
5930 SvNVX(dstr) = SvNVX(sstr);
5931 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5932 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5934 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5935 else if (SvPVX(sstr) && SvLEN(sstr))
5936 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5938 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5939 BmRARE(dstr) = BmRARE(sstr);
5940 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5941 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5944 SvANY(dstr) = new_XPVLV();
5945 SvCUR(dstr) = SvCUR(sstr);
5946 SvLEN(dstr) = SvLEN(sstr);
5947 SvIVX(dstr) = SvIVX(sstr);
5948 SvNVX(dstr) = SvNVX(sstr);
5949 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5950 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5952 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5953 else if (SvPVX(sstr) && SvLEN(sstr))
5954 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5956 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5957 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5958 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5959 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5960 LvTYPE(dstr) = LvTYPE(sstr);
5963 SvANY(dstr) = new_XPVGV();
5964 SvCUR(dstr) = SvCUR(sstr);
5965 SvLEN(dstr) = SvLEN(sstr);
5966 SvIVX(dstr) = SvIVX(sstr);
5967 SvNVX(dstr) = SvNVX(sstr);
5968 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5969 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5971 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5972 else if (SvPVX(sstr) && SvLEN(sstr))
5973 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5975 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5976 GvNAMELEN(dstr) = GvNAMELEN(sstr);
5977 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5978 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
5979 GvFLAGS(dstr) = GvFLAGS(sstr);
5980 GvGP(dstr) = gp_dup(GvGP(sstr));
5981 (void)GpREFCNT_inc(GvGP(dstr));
5984 SvANY(dstr) = new_XPVIO();
5985 SvCUR(dstr) = SvCUR(sstr);
5986 SvLEN(dstr) = SvLEN(sstr);
5987 SvIVX(dstr) = SvIVX(sstr);
5988 SvNVX(dstr) = SvNVX(sstr);
5989 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5990 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5992 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5993 else if (SvPVX(sstr) && SvLEN(sstr))
5994 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5996 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5997 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
5998 if (IoOFP(sstr) == IoIFP(sstr))
5999 IoOFP(dstr) = IoIFP(dstr);
6001 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6002 /* PL_rsfp_filters entries have fake IoDIRP() */
6003 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6004 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6006 IoDIRP(dstr) = IoDIRP(sstr);
6007 IoLINES(dstr) = IoLINES(sstr);
6008 IoPAGE(dstr) = IoPAGE(sstr);
6009 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6010 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6011 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6012 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6013 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6014 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6015 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6016 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6017 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6018 IoTYPE(dstr) = IoTYPE(sstr);
6019 IoFLAGS(dstr) = IoFLAGS(sstr);
6022 SvANY(dstr) = new_XPVAV();
6023 SvCUR(dstr) = SvCUR(sstr);
6024 SvLEN(dstr) = SvLEN(sstr);
6025 SvIVX(dstr) = SvIVX(sstr);
6026 SvNVX(dstr) = SvNVX(sstr);
6027 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6028 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6029 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6030 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6031 if (AvARRAY((AV*)sstr)) {
6032 SV **dst_ary, **src_ary;
6033 SSize_t items = AvFILLp((AV*)sstr) + 1;
6035 src_ary = AvARRAY((AV*)sstr);
6036 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6037 SvPVX(dstr) = (char*)dst_ary;
6038 AvALLOC((AV*)dstr) = dst_ary;
6039 if (AvREAL((AV*)sstr)) {
6041 *dst_ary++ = sv_dup_inc(*src_ary++);
6045 *dst_ary++ = sv_dup(*src_ary++);
6047 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6048 while (items-- > 0) {
6049 *dst_ary++ = &PL_sv_undef;
6053 SvPVX(dstr) = Nullch;
6054 AvALLOC((AV*)dstr) = (SV**)NULL;
6058 SvANY(dstr) = new_XPVHV();
6059 SvCUR(dstr) = SvCUR(sstr);
6060 SvLEN(dstr) = SvLEN(sstr);
6061 SvIVX(dstr) = SvIVX(sstr);
6062 SvNVX(dstr) = SvNVX(sstr);
6063 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6064 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6065 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6066 if (HvARRAY((HV*)sstr)) {
6069 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6070 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6071 Newz(0, dxhv->xhv_array,
6072 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6073 while (i <= sxhv->xhv_max) {
6074 HE *dentry, *oentry;
6075 entry = ((HE**)sxhv->xhv_array)[i];
6076 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6077 ((HE**)dxhv->xhv_array)[i] = dentry;
6079 entry = HeNEXT(entry);
6081 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6082 HeNEXT(oentry) = dentry;
6086 if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6087 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6088 while (entry && entry != sxhv->xhv_eiter)
6089 entry = HeNEXT(entry);
6090 dxhv->xhv_eiter = entry;
6093 dxhv->xhv_eiter = (HE*)NULL;
6096 SvPVX(dstr) = Nullch;
6097 HvEITER((HV*)dstr) = (HE*)NULL;
6099 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6100 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6103 SvANY(dstr) = new_XPVFM();
6104 FmLINES(dstr) = FmLINES(sstr);
6108 SvANY(dstr) = new_XPVCV();
6110 SvCUR(dstr) = SvCUR(sstr);
6111 SvLEN(dstr) = SvLEN(sstr);
6112 SvIVX(dstr) = SvIVX(sstr);
6113 SvNVX(dstr) = SvNVX(sstr);
6114 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6115 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6116 if (SvPVX(sstr) && SvLEN(sstr))
6117 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6119 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6120 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6121 CvSTART(dstr) = CvSTART(sstr);
6122 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6123 CvXSUB(dstr) = CvXSUB(sstr);
6124 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6125 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6126 CvDEPTH(dstr) = CvDEPTH(sstr);
6127 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6128 /* XXX padlists are real, but pretend to be not */
6129 AvREAL_on(CvPADLIST(sstr));
6130 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6131 AvREAL_off(CvPADLIST(sstr));
6132 AvREAL_off(CvPADLIST(dstr));
6135 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6136 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6137 CvFLAGS(dstr) = CvFLAGS(sstr);
6140 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6144 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6151 perl_clone_using(PerlInterpreter *proto_perl, IV flags,
6152 struct IPerlMem* ipM, struct IPerlEnv* ipE,
6153 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6154 struct IPerlDir* ipD, struct IPerlSock* ipS,
6155 struct IPerlProc* ipP)
6160 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6161 PERL_SET_INTERP(my_perl);
6164 memset(my_perl, 0x0, sizeof(PerlInterpreter));
6171 Copy(proto_perl, my_perl, 1, PerlInterpreter);
6175 /* XXX many of the string copies here can be optimized if they're
6176 * constants; they need to be allocated as common memory and just
6177 * their pointers copied. */
6189 PL_xiv_arenaroot = NULL;
6194 PL_xpviv_root = NULL;
6195 PL_xpvnv_root = NULL;
6196 PL_xpvcv_root = NULL;
6197 PL_xpvav_root = NULL;
6198 PL_xpvhv_root = NULL;
6199 PL_xpvmg_root = NULL;
6200 PL_xpvlv_root = NULL;
6201 PL_xpvbm_root = NULL;
6203 PL_nice_chunk = NULL;
6204 PL_nice_chunk_size = 0;
6207 PL_sv_root = Nullsv;
6208 PL_sv_arenaroot = Nullsv;
6210 PL_debug = proto_perl->Idebug;
6212 /* create SV map for pointer relocation */
6213 PL_sv_table = sv_table_new();
6215 /* initialize these special pointers as early as possible */
6216 SvANY(&PL_sv_undef) = NULL;
6217 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6218 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6219 sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef);
6221 SvANY(&PL_sv_no) = new_XPVNV();
6222 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6223 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6224 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6225 SvCUR(&PL_sv_no) = 0;
6226 SvLEN(&PL_sv_no) = 1;
6227 SvNVX(&PL_sv_no) = 0;
6228 sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no);
6230 SvANY(&PL_sv_yes) = new_XPVNV();
6231 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6232 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6233 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6234 SvCUR(&PL_sv_yes) = 1;
6235 SvLEN(&PL_sv_yes) = 2;
6236 SvNVX(&PL_sv_yes) = 1;
6237 sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes);
6239 /* create shared string table */
6240 PL_strtab = newHV();
6241 HvSHAREKEYS_off(PL_strtab);
6242 hv_ksplit(PL_strtab, 512);
6243 sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab);
6245 PL_compiling = proto_perl->Icompiling;
6246 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6247 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6248 if (!specialWARN(PL_compiling.cop_warnings))
6249 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6250 if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6251 PL_curcop = &PL_compiling;
6253 PL_curcop = proto_perl->Tcurcop;
6255 /* pseudo environmental stuff */
6256 PL_origargc = proto_perl->Iorigargc;
6258 New(0, PL_origargv, i+1, char*);
6259 PL_origargv[i] = '\0';
6261 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6263 PL_envgv = gv_dup(proto_perl->Ienvgv);
6264 PL_incgv = gv_dup(proto_perl->Iincgv);
6265 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6266 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6267 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6268 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6271 PL_minus_c = proto_perl->Iminus_c;
6272 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6273 PL_localpatches = proto_perl->Ilocalpatches;
6274 PL_splitstr = proto_perl->Isplitstr;
6275 PL_preprocess = proto_perl->Ipreprocess;
6276 PL_minus_n = proto_perl->Iminus_n;
6277 PL_minus_p = proto_perl->Iminus_p;
6278 PL_minus_l = proto_perl->Iminus_l;
6279 PL_minus_a = proto_perl->Iminus_a;
6280 PL_minus_F = proto_perl->Iminus_F;
6281 PL_doswitches = proto_perl->Idoswitches;
6282 PL_dowarn = proto_perl->Idowarn;
6283 PL_doextract = proto_perl->Idoextract;
6284 PL_sawampersand = proto_perl->Isawampersand;
6285 PL_unsafe = proto_perl->Iunsafe;
6286 PL_inplace = SAVEPV(proto_perl->Iinplace);
6287 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6288 PL_perldb = proto_perl->Iperldb;
6289 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6291 /* magical thingies */
6292 /* XXX time(&PL_basetime) instead? */
6293 PL_basetime = proto_perl->Ibasetime;
6294 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6296 PL_maxsysfd = proto_perl->Imaxsysfd;
6297 PL_multiline = proto_perl->Imultiline;
6298 PL_statusvalue = proto_perl->Istatusvalue;
6300 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6303 /* shortcuts to various I/O objects */
6304 PL_stdingv = gv_dup(proto_perl->Istdingv);
6305 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6306 PL_defgv = gv_dup(proto_perl->Idefgv);
6307 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6308 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6309 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6311 /* shortcuts to regexp stuff */
6312 PL_replgv = gv_dup(proto_perl->Ireplgv);
6314 /* shortcuts to misc objects */
6315 PL_errgv = gv_dup(proto_perl->Ierrgv);
6317 /* shortcuts to debugging objects */
6318 PL_DBgv = gv_dup(proto_perl->IDBgv);
6319 PL_DBline = gv_dup(proto_perl->IDBline);
6320 PL_DBsub = gv_dup(proto_perl->IDBsub);
6321 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6322 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6323 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6324 PL_lineary = av_dup(proto_perl->Ilineary);
6325 PL_dbargs = av_dup(proto_perl->Idbargs);
6328 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6329 PL_curstash = hv_dup(proto_perl->Tcurstash);
6330 PL_debstash = hv_dup(proto_perl->Idebstash);
6331 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6332 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6334 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6335 PL_endav = av_dup_inc(proto_perl->Iendav);
6336 PL_stopav = av_dup_inc(proto_perl->Istopav);
6337 PL_initav = av_dup_inc(proto_perl->Iinitav);
6339 PL_sub_generation = proto_perl->Isub_generation;
6341 /* funky return mechanisms */
6342 PL_forkprocess = proto_perl->Iforkprocess;
6344 /* subprocess state */
6345 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6347 /* internal state */
6348 PL_tainting = proto_perl->Itainting;
6349 PL_maxo = proto_perl->Imaxo;
6350 if (proto_perl->Iop_mask)
6351 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6353 PL_op_mask = Nullch;
6355 /* current interpreter roots */
6356 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6357 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6358 PL_main_start = proto_perl->Imain_start;
6359 PL_eval_root = proto_perl->Ieval_root;
6360 PL_eval_start = proto_perl->Ieval_start;
6362 /* runtime control stuff */
6363 PL_curcopdb = proto_perl->Icurcopdb;
6364 PL_copline = proto_perl->Icopline;
6366 PL_filemode = proto_perl->Ifilemode;
6367 PL_lastfd = proto_perl->Ilastfd;
6368 PL_oldname = proto_perl->Ioldname; /* XXX */
6371 PL_gensym = proto_perl->Igensym;
6372 PL_preambled = proto_perl->Ipreambled;
6373 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6374 PL_laststatval = proto_perl->Ilaststatval;
6375 PL_laststype = proto_perl->Ilaststype;
6376 PL_mess_sv = Nullsv;
6378 PL_orslen = proto_perl->Iorslen;
6379 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6380 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6382 /* interpreter atexit processing */
6383 PL_exitlistlen = proto_perl->Iexitlistlen;
6384 if (PL_exitlistlen) {
6385 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6386 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6389 PL_exitlist = (PerlExitListEntry*)NULL;
6390 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6392 PL_profiledata = NULL; /* XXX */
6393 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6394 /* XXX PL_rsfp_filters entries have fake IoDIRP() */
6395 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6397 PL_compcv = cv_dup(proto_perl->Icompcv);
6398 PL_comppad = av_dup(proto_perl->Icomppad);
6399 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6400 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6401 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6402 PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
6404 #ifdef HAVE_INTERP_INTERN
6405 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6408 /* more statics moved here */
6409 PL_generation = proto_perl->Igeneration;
6410 PL_DBcv = cv_dup(proto_perl->IDBcv);
6411 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6413 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6414 PL_in_clean_all = proto_perl->Iin_clean_all;
6416 PL_uid = proto_perl->Iuid;
6417 PL_euid = proto_perl->Ieuid;
6418 PL_gid = proto_perl->Igid;
6419 PL_egid = proto_perl->Iegid;
6420 PL_nomemok = proto_perl->Inomemok;
6421 PL_an = proto_perl->Ian;
6422 PL_cop_seqmax = proto_perl->Icop_seqmax;
6423 PL_op_seqmax = proto_perl->Iop_seqmax;
6424 PL_evalseq = proto_perl->Ievalseq;
6425 PL_origenviron = proto_perl->Iorigenviron; /* XXX */
6426 PL_origalen = proto_perl->Iorigalen;
6427 PL_pidstatus = newHV();
6428 PL_osname = SAVEPV(proto_perl->Iosname);
6429 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6430 PL_sighandlerp = proto_perl->Isighandlerp;
6433 PL_runops = proto_perl->Irunops;
6435 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */
6438 PL_cshlen = proto_perl->Icshlen;
6439 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6442 PL_lex_state = proto_perl->Ilex_state;
6443 PL_lex_defer = proto_perl->Ilex_defer;
6444 PL_lex_expect = proto_perl->Ilex_expect;
6445 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6446 PL_lex_fakebrack = proto_perl->Ilex_fakebrack;
6447 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6448 PL_lex_starts = proto_perl->Ilex_starts;
6449 PL_lex_stuff = Nullsv; /* XXX */
6450 PL_lex_repl = Nullsv; /* XXX */
6451 PL_lex_op = proto_perl->Ilex_op;
6452 PL_lex_inpat = proto_perl->Ilex_inpat;
6453 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6454 PL_lex_brackets = proto_perl->Ilex_brackets;
6455 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6456 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6457 PL_lex_casemods = proto_perl->Ilex_casemods;
6458 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6459 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6461 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6462 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6463 PL_nexttoke = proto_perl->Inexttoke;
6465 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6466 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6467 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6468 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6469 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6470 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6471 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6472 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6473 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6474 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6475 PL_pending_ident = proto_perl->Ipending_ident;
6476 PL_sublex_info = proto_perl->Isublex_info; /* XXX */
6478 PL_expect = proto_perl->Iexpect;
6480 PL_multi_start = proto_perl->Imulti_start;
6481 PL_multi_end = proto_perl->Imulti_end;
6482 PL_multi_open = proto_perl->Imulti_open;
6483 PL_multi_close = proto_perl->Imulti_close;
6485 PL_error_count = proto_perl->Ierror_count;
6486 PL_subline = proto_perl->Isubline;
6487 PL_subname = sv_dup_inc(proto_perl->Isubname);
6489 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6490 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6491 PL_padix = proto_perl->Ipadix;
6492 PL_padix_floor = proto_perl->Ipadix_floor;
6493 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6495 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6496 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6497 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6498 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6499 PL_last_lop_op = proto_perl->Ilast_lop_op;
6500 PL_in_my = proto_perl->Iin_my;
6501 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6503 PL_cryptseen = proto_perl->Icryptseen;
6506 PL_hints = proto_perl->Ihints;
6508 PL_amagic_generation = proto_perl->Iamagic_generation;
6510 #ifdef USE_LOCALE_COLLATE
6511 PL_collation_ix = proto_perl->Icollation_ix;
6512 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6513 PL_collation_standard = proto_perl->Icollation_standard;
6514 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6515 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6516 #endif /* USE_LOCALE_COLLATE */
6518 #ifdef USE_LOCALE_NUMERIC
6519 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6520 PL_numeric_standard = proto_perl->Inumeric_standard;
6521 PL_numeric_local = proto_perl->Inumeric_local;
6522 PL_numeric_radix = proto_perl->Inumeric_radix;
6523 #endif /* !USE_LOCALE_NUMERIC */
6525 /* utf8 character classes */
6526 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6527 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6528 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6529 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6530 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6531 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6532 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6533 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6534 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6535 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6536 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6537 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6538 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6539 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6540 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6541 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6542 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6545 PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */
6546 PL_last_swash_klen = 0;
6547 PL_last_swash_key[0]= '\0';
6548 PL_last_swash_tmps = Nullch;
6549 PL_last_swash_slen = 0;
6551 /* perly.c globals */
6552 PL_yydebug = proto_perl->Iyydebug;
6553 PL_yynerrs = proto_perl->Iyynerrs;
6554 PL_yyerrflag = proto_perl->Iyyerrflag;
6555 PL_yychar = proto_perl->Iyychar;
6556 PL_yyval = proto_perl->Iyyval;
6557 PL_yylval = proto_perl->Iyylval;
6559 PL_glob_index = proto_perl->Iglob_index;
6560 PL_srand_called = proto_perl->Isrand_called;
6561 PL_uudmap['M'] = 0; /* reinit on demand */
6562 PL_bitcount = Nullch; /* reinit on demand */
6565 /* thrdvar.h stuff */
6567 /* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo);
6569 PL_mainstack = av_dup(proto_perl->Tmainstack);
6570 PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */
6573 PL_op = proto_perl->Top;
6574 PL_statbuf = proto_perl->Tstatbuf;
6575 PL_statcache = proto_perl->Tstatcache;
6576 PL_statgv = gv_dup(proto_perl->Tstatgv);
6577 PL_statname = sv_dup_inc(proto_perl->Tstatname);
6579 PL_timesbuf = proto_perl->Ttimesbuf;
6582 PL_tainted = proto_perl->Ttainted;
6583 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
6584 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
6585 PL_rs = sv_dup_inc(proto_perl->Trs);
6586 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
6587 PL_ofslen = proto_perl->Tofslen;
6588 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6589 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
6590 PL_chopset = proto_perl->Tchopset; /* XXX */
6591 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
6592 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
6593 PL_formtarget = sv_dup(proto_perl->Tformtarget);
6595 PL_restartop = proto_perl->Trestartop;
6596 PL_in_eval = proto_perl->Tin_eval;
6597 PL_delaymagic = proto_perl->Tdelaymagic;
6598 PL_dirty = proto_perl->Tdirty;
6599 PL_localizing = proto_perl->Tlocalizing;
6601 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
6602 PL_top_env = &PL_start_env;
6603 PL_protect = proto_perl->Tprotect;
6604 PL_errors = sv_dup_inc(proto_perl->Terrors);
6605 PL_av_fetch_sv = Nullsv;
6606 PL_hv_fetch_sv = Nullsv;
6607 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
6608 PL_modcount = proto_perl->Tmodcount;
6609 PL_lastgotoprobe = Nullop;
6610 PL_dumpindent = proto_perl->Tdumpindent;
6611 PL_sortstash = hv_dup(proto_perl->Tsortstash);
6612 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
6613 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
6614 PL_sortcxix = proto_perl->Tsortcxix;
6615 PL_efloatbuf = Nullch;
6618 PL_screamfirst = NULL;
6619 PL_screamnext = NULL;
6621 PL_lastscream = Nullsv;
6623 /* RE engine - function pointers */
6624 PL_regcompp = proto_perl->Tregcompp;
6625 PL_regexecp = proto_perl->Tregexecp;
6626 PL_regint_start = proto_perl->Tregint_start;
6627 PL_regint_string = proto_perl->Tregint_string;
6628 PL_regfree = proto_perl->Tregfree;
6631 PL_reginterp_cnt = 0;
6632 PL_reg_start_tmp = 0;
6633 PL_reg_start_tmpl = 0;
6634 PL_reg_poscache = Nullch;
6636 PL_watchaddr = NULL;
6637 PL_watchok = Nullch;
6643 perl_clone(pTHXx_ IV flags)
6645 return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6646 PL_Dir, PL_Sock, PL_Proc);
6649 #endif /* USE_ITHREADS */
6656 do_report_used(pTHXo_ SV *sv)
6658 if (SvTYPE(sv) != SVTYPEMASK) {
6659 PerlIO_printf(Perl_debug_log, "****\n");
6665 do_clean_objs(pTHXo_ SV *sv)
6669 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6670 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6676 /* XXX Might want to check arrays, etc. */
6679 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6681 do_clean_named_objs(pTHXo_ SV *sv)
6683 if (SvTYPE(sv) == SVt_PVGV) {
6684 if ( SvOBJECT(GvSV(sv)) ||
6685 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6686 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6687 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6688 GvCV(sv) && SvOBJECT(GvCV(sv)) )
6690 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6698 do_clean_all(pTHXo_ SV *sv)
6700 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6701 SvFLAGS(sv) |= SVf_BREAK;