diff options
Diffstat (limited to 'contrib/perl5/sv.c')
| -rw-r--r-- | contrib/perl5/sv.c | 1130 |
1 files changed, 746 insertions, 384 deletions
diff --git a/contrib/perl5/sv.c b/contrib/perl5/sv.c index 3eebc9ad4513..7b8263b60118 100644 --- a/contrib/perl5/sv.c +++ b/contrib/perl5/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -147,20 +147,24 @@ S_more_sv(pTHX) return sv; } -STATIC void +STATIC I32 S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; register SV* svend; + I32 visited = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != SVTYPEMASK) + if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { (FCALL)(aTHXo_ sv); + ++visited; + } } } + return visited; } void @@ -181,12 +185,14 @@ Perl_sv_clean_objs(pTHX) PL_in_clean_objs = FALSE; } -void +I32 Perl_sv_clean_all(pTHX) { + I32 cleaned; PL_in_clean_all = TRUE; - visit(do_clean_all); + cleaned = visit(do_clean_all); PL_in_clean_all = FALSE; + return cleaned; } void @@ -194,6 +200,7 @@ Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; + XPV *arena, *arenanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -207,6 +214,84 @@ Perl_sv_free_arenas(pTHX) Safefree((void *)sva); } + for (arena = PL_xiv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xiv_arenaroot = 0; + + for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xnv_arenaroot = 0; + + for (arena = PL_xrv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xrv_arenaroot = 0; + + for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpv_arenaroot = 0; + + for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpviv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvnv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvcv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvav_arenaroot = 0; + + for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvhv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvmg_arenaroot = 0; + + for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvlv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvbm_arenaroot = 0; + + for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_he_arenaroot = 0; + if (PL_nice_chunk) Safefree(PL_nice_chunk); PL_nice_chunk = Nullch; @@ -300,7 +385,12 @@ S_more_xnv(pTHX) { register NV* xnv; register NV* xnvend; - New(711, xnv, 1008/sizeof(NV), NV); + XPV *ptr; + New(711, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xnv_arenaroot; + PL_xnv_arenaroot = ptr; + + xnv = (NV*) ptr; xnvend = &xnv[1008 / sizeof(NV) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ PL_xnv_root = xnv; @@ -338,9 +428,15 @@ S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; - New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); - xrv = PL_xrv_root; + XPV *ptr; + New(712, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xrv_arenaroot; + PL_xrv_arenaroot = ptr; + + xrv = (XRV*) ptr; xrvend = &xrv[1008 / sizeof(XRV) - 1]; + xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1; + PL_xrv_root = xrv; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); xrv++; @@ -375,9 +471,12 @@ S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; - New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); - xpv = PL_xpv_root; + New(713, xpv, 1008/sizeof(XPV), XPV); + xpv->xpv_pv = (char*)PL_xpv_arenaroot; + PL_xpv_arenaroot = xpv; + xpvend = &xpv[1008 / sizeof(XPV) - 1]; + PL_xpv_root = ++xpv; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); xpv++; @@ -407,15 +506,17 @@ S_del_xpviv(pTHX_ XPVIV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpviv(pTHX) { register XPVIV* xpviv; register XPVIV* xpvivend; - New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV); - xpviv = PL_xpviv_root; + New(714, xpviv, 1008/sizeof(XPVIV), XPVIV); + xpviv->xpv_pv = (char*)PL_xpviv_arenaroot; + PL_xpviv_arenaroot = xpviv; + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + PL_xpviv_root = ++xpviv; while (xpviv < xpvivend) { xpviv->xpv_pv = (char*)(xpviv + 1); xpviv++; @@ -423,7 +524,6 @@ S_more_xpviv(pTHX) xpviv->xpv_pv = 0; } - STATIC XPVNV* S_new_xpvnv(pTHX) { @@ -446,15 +546,17 @@ S_del_xpvnv(pTHX_ XPVNV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvnv(pTHX) { register XPVNV* xpvnv; register XPVNV* xpvnvend; - New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV); - xpvnv = PL_xpvnv_root; + New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV); + xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot; + PL_xpvnv_arenaroot = xpvnv; + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + PL_xpvnv_root = ++xpvnv; while (xpvnv < xpvnvend) { xpvnv->xpv_pv = (char*)(xpvnv + 1); xpvnv++; @@ -462,8 +564,6 @@ S_more_xpvnv(pTHX) xpvnv->xpv_pv = 0; } - - STATIC XPVCV* S_new_xpvcv(pTHX) { @@ -486,15 +586,17 @@ S_del_xpvcv(pTHX_ XPVCV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvcv(pTHX) { register XPVCV* xpvcv; register XPVCV* xpvcvend; - New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV); - xpvcv = PL_xpvcv_root; + New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV); + xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot; + PL_xpvcv_arenaroot = xpvcv; + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + PL_xpvcv_root = ++xpvcv; while (xpvcv < xpvcvend) { xpvcv->xpv_pv = (char*)(xpvcv + 1); xpvcv++; @@ -502,8 +604,6 @@ S_more_xpvcv(pTHX) xpvcv->xpv_pv = 0; } - - STATIC XPVAV* S_new_xpvav(pTHX) { @@ -526,15 +626,17 @@ S_del_xpvav(pTHX_ XPVAV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvav(pTHX) { register XPVAV* xpvav; register XPVAV* xpvavend; - New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV); - xpvav = PL_xpvav_root; + New(717, xpvav, 1008/sizeof(XPVAV), XPVAV); + xpvav->xav_array = (char*)PL_xpvav_arenaroot; + PL_xpvav_arenaroot = xpvav; + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + PL_xpvav_root = ++xpvav; while (xpvav < xpvavend) { xpvav->xav_array = (char*)(xpvav + 1); xpvav++; @@ -542,8 +644,6 @@ S_more_xpvav(pTHX) xpvav->xav_array = 0; } - - STATIC XPVHV* S_new_xpvhv(pTHX) { @@ -566,15 +666,17 @@ S_del_xpvhv(pTHX_ XPVHV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvhv(pTHX) { register XPVHV* xpvhv; register XPVHV* xpvhvend; - New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV); - xpvhv = PL_xpvhv_root; + New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV); + xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot; + PL_xpvhv_arenaroot = xpvhv; + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + PL_xpvhv_root = ++xpvhv; while (xpvhv < xpvhvend) { xpvhv->xhv_array = (char*)(xpvhv + 1); xpvhv++; @@ -582,7 +684,6 @@ S_more_xpvhv(pTHX) xpvhv->xhv_array = 0; } - STATIC XPVMG* S_new_xpvmg(pTHX) { @@ -605,15 +706,17 @@ S_del_xpvmg(pTHX_ XPVMG *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvmg(pTHX) { register XPVMG* xpvmg; register XPVMG* xpvmgend; - New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG); - xpvmg = PL_xpvmg_root; + New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG); + xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot; + PL_xpvmg_arenaroot = xpvmg; + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + PL_xpvmg_root = ++xpvmg; while (xpvmg < xpvmgend) { xpvmg->xpv_pv = (char*)(xpvmg + 1); xpvmg++; @@ -621,8 +724,6 @@ S_more_xpvmg(pTHX) xpvmg->xpv_pv = 0; } - - STATIC XPVLV* S_new_xpvlv(pTHX) { @@ -645,15 +746,17 @@ S_del_xpvlv(pTHX_ XPVLV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvlv(pTHX) { register XPVLV* xpvlv; register XPVLV* xpvlvend; - New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV); - xpvlv = PL_xpvlv_root; + New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV); + xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot; + PL_xpvlv_arenaroot = xpvlv; + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + PL_xpvlv_root = ++xpvlv; while (xpvlv < xpvlvend) { xpvlv->xpv_pv = (char*)(xpvlv + 1); xpvlv++; @@ -661,7 +764,6 @@ S_more_xpvlv(pTHX) xpvlv->xpv_pv = 0; } - STATIC XPVBM* S_new_xpvbm(pTHX) { @@ -684,15 +786,17 @@ S_del_xpvbm(pTHX_ XPVBM *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvbm(pTHX) { register XPVBM* xpvbm; register XPVBM* xpvbmend; - New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM); - xpvbm = PL_xpvbm_root; + New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM); + xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot; + PL_xpvbm_arenaroot = xpvbm; + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + PL_xpvbm_root = ++xpvbm; while (xpvbm < xpvbmend) { xpvbm->xpv_pv = (char*)(xpvbm + 1); xpvbm++; @@ -1183,11 +1287,8 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); - } + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + PL_op_desc[PL_op->op_type]); } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1271,11 +1372,8 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); - } + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1300,7 +1398,6 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) STATIC void S_not_a_number(pTHX_ SV *sv) { - dTHR; char tmpbuf[64]; char *d = tmpbuf; char *s; @@ -1359,6 +1456,7 @@ S_not_a_number(pTHX_ SV *sv) #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ #define IS_NUMBER_NEG 0x08 /* not good to cache UV */ +#define IS_NUMBER_INFINITY 0x10 /* this is big */ /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ @@ -1379,7 +1477,6 @@ Perl_sv_2iv(pTHX_ register SV *sv) return asIV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1389,12 +1486,12 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1470,27 +1567,17 @@ Perl_sv_2iv(pTHX_ register SV *sv) goto ret_iv_max; } } - else if (numtype) { - /* The NV may be reconstructed from IV - safe to cache IV, - which may be calculated by atol(). */ - if (SvTYPE(sv) == SVt_PV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - SvIVX(sv) = Atol(SvPVX(sv)); - } - else { /* Not a number. Cache 0. */ - dTHR; - + else { /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = 0; (void)SvIOK_on(sv); - if (ckWARN(WARN_NUMERIC)) + SvIVX(sv) = Atol(SvPVX(sv)); + if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); } } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_IV) @@ -1518,7 +1605,6 @@ Perl_sv_2uv(pTHX_ register SV *sv) return asUV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1528,12 +1614,12 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1633,21 +1719,18 @@ Perl_sv_2uv(pTHX_ register SV *sv) #endif } else { /* Not a number. Cache 0. */ - dTHR; - if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvUVX(sv) = 0; /* We assume that 0s have the - same bitmap in IV and UV. */ (void)SvIOK_on(sv); (void)SvIsUV_on(sv); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1672,7 +1755,6 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); return Atof(SvPVX(sv)); @@ -1685,7 +1767,6 @@ Perl_sv_2nv(pTHX_ register SV *sv) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1695,12 +1776,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0.0; @@ -1713,7 +1794,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) sv_upgrade(sv, SVt_NV); #if defined(USE_LONG_DOUBLE) DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); @@ -1721,7 +1802,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) }); #else DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); @@ -1736,13 +1817,11 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { - dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SvNVX(sv) = Atof(SvPVX(sv)); } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_NV) @@ -1753,14 +1832,14 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNOK_on(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); #else DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); @@ -1778,7 +1857,6 @@ S_asIV(pTHX_ SV *sv) if (numtype & IS_NUMBER_TO_INT_BY_ATOL) return Atol(SvPVX(sv)); if (!numtype) { - dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1796,7 +1874,6 @@ S_asUV(pTHX_ SV *sv) return Strtoul(SvPVX(sv), Null(char**), 10); #endif if (!numtype) { - dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1813,6 +1890,7 @@ S_asUV(pTHX_ SV *sv) * IS_NUMBER_TO_INT_BY_ATOL 123 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * IS_NUMBER_INFINITY * with a possible addition of IS_NUMBER_NEG. */ @@ -1833,7 +1911,11 @@ Perl_looks_like_number(pTHX_ SV *sv) register char *sbegin; register char *nbegin; I32 numtype = 0; + I32 sawinf = 0; STRLEN len; +#ifdef USE_LOCALE_NUMERIC + bool specialradix = FALSE; +#endif if (SvPOK(sv)) { sbegin = SvPVX(sv); @@ -1862,7 +1944,7 @@ Perl_looks_like_number(pTHX_ SV *sv) * (int)atof(). */ - /* next must be digit or the radix separator */ + /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { do { s++; @@ -1874,22 +1956,32 @@ Perl_looks_like_number(pTHX_ SV *sv) numtype |= IS_NUMBER_TO_INT_BY_ATOL; if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) +#ifdef USE_LOCALE_NUMERIC + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix_sv); + else +#endif + s++; numtype |= IS_NUMBER_NOT_IV; while (isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) +#ifdef USE_LOCALE_NUMERIC + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix_sv); + else +#endif + s++; numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; /* no digits before the radix means we need digits after it */ if (isDIGIT(*s)) { @@ -1900,23 +1992,38 @@ Perl_looks_like_number(pTHX_ SV *sv) else return 0; } + else if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'F' && *s != 'f') return 0; + s++; if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'I' && *s != 'i') return 0; + s++; if (*s != 'T' && *s != 't') return 0; + s++; if (*s != 'Y' && *s != 'y') return 0; + } + sawinf = 1; + } else return 0; - /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { - numtype &= ~IS_NUMBER_NEG; - numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; - s++; - if (*s == '+' || *s == '-') + if (sawinf) + numtype = IS_NUMBER_INFINITY; + else { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; + if (*s == '+' || *s == '-') + s++; + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } } while (isSPACE(*s)) s++; @@ -1994,7 +2101,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -2005,7 +2111,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && + (SvRV(tmpstr) != SvRV(sv))) return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) @@ -2020,7 +2127,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) == (SVs_OBJECT|SVs_RMG)) && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, 'r'))) { - dTHR; regexp *re = (regexp *)mg->mg_obj; if (!mg->mg_ptr) { @@ -2088,7 +2194,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return s; } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); *lp = 0; @@ -2097,12 +2202,13 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } if (SvNOKp(sv)) { /* See note in sv_2uv() */ /* XXXX 64-bit? IV may have better precision... */ - /* I tried changing this for to be 64-bit-aware and + /* I tried changing this to be 64-bit-aware and * the t/op/numconvert.t became very, very, angry. * --jhi Sep 1999 */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - SvGROW(sv, 28); + /* The +20 is pure guesswork. Configure test needed. --jhi */ + SvGROW(sv, NV_DIG + 20); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo @@ -2150,12 +2256,9 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) SvPOK_on(sv); } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - { report_uninit(); - } *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -2233,7 +2336,7 @@ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_upgrade(sv); - return sv_2pv(sv,lp); + return SvPV(sv,*lp); } /* This function is only called on magical items */ @@ -2246,9 +2349,9 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (!SvOK(sv)) return 0; if (SvROK(sv)) { - dTHR; SV* tmpsv; - if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) + if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && + (SvRV(tmpsv) != SvRV(sv))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -2274,96 +2377,102 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } +/* +=for apidoc sv_utf8_upgrade + +Convert the PV of an SV to its UTF8-encoded form. + +=cut +*/ + void Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - int hicount; - char *c; + char *s, *t, *e; + int hibit = 0; if (!sv || !SvPOK(sv) || SvUTF8(sv)) return; - /* This function could be much more efficient if we had a FLAG - * to signal if there are any hibit chars in the string + /* This function could be much more efficient if we had a FLAG in SVs + * to signal if there are any hibit chars in the PV. + * Given that there isn't make loop fast as possible */ - hicount = 0; - for (c = SvPVX(sv); c < SvEND(sv); c++) { - if (*c & 0x80) - hicount++; + s = SvPVX(sv); + e = SvEND(sv); + t = s; + while (t < e) { + if ((hibit = UTF8_IS_CONTINUED(*t++))) + break; } - if (hicount) { - char *src, *dst; - SvGROW(sv, SvCUR(sv) + hicount + 1); - - src = SvEND(sv) - 1; - SvCUR_set(sv, SvCUR(sv) + hicount); - dst = SvEND(sv) - 1; + if (hibit) { + STRLEN len; - while (src < dst) { - if (*src & 0x80) { - dst--; - uv_to_utf8((U8*)dst, (U8)*src--); - dst--; - } - else { - *dst-- = *src--; - } + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + s = SvPVX(sv); } - + len = SvCUR(sv) + 1; /* Plus the \0 */ + SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); + SvCUR(sv) = len - 1; + if (SvLEN(sv) != 0) + Safefree(s); /* No longer using what was there before. */ + SvLEN(sv) = len; /* No longer know the real size. */ SvUTF8_on(sv); } } +/* +=for apidoc sv_utf8_downgrade + +Attempt to convert the PV of an SV from UTF8-encoded to byte encoding. +This may not be possible if the PV contains non-byte encoding characters; +if this is the case, either returns false or, if C<fail_ok> is not +true, croaks. + +=cut +*/ + bool Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { if (SvPOK(sv) && SvUTF8(sv)) { - char *c = SvPVX(sv); - char *first_hi = 0; - /* need to figure out if this is possible at all first */ - while (c < SvEND(sv)) { - if (*c & 0x80) { - I32 len; - UV uv = utf8_to_uv((U8*)c, &len); - if (uv >= 256) { - if (fail_ok) - return FALSE; - else { - /* XXX might want to make a callback here instead */ - Perl_croak(aTHX_ "Big byte"); - } + if (SvCUR(sv)) { + char *s; + STRLEN len; + + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); + s = SvPV(sv, len); + if (!utf8_to_bytes((U8*)s, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + PL_op_desc[PL_op->op_type]); + else + Perl_croak(aTHX_ "Wide character"); } - if (!first_hi) - first_hi = c; - c += len; - } - else { - c++; - } - } - - if (first_hi) { - char *src = first_hi; - char *dst = first_hi; - while (src < SvEND(sv)) { - if (*src & 0x80) { - I32 len; - U8 u = (U8)utf8_to_uv((U8*)src, &len); - *dst++ = u; - src += len; - } - else { - *dst++ = *src++; - } - } - SvCUR_set(sv, dst - SvPVX(sv)); - } - SvUTF8_off(sv); + } + SvCUR(sv) = len; + } + SvUTF8_off(sv); } + return TRUE; } +/* +=for apidoc sv_utf8_encode + +Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8> +flag so that it looks like bytes again. Nothing calls this. + +=cut +*/ + void Perl_sv_utf8_encode(pTHX_ register SV *sv) { @@ -2376,6 +2485,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOK(sv)) { char *c; + char *e; bool has_utf = FALSE; if (!sv_utf8_downgrade(sv, TRUE)) return FALSE; @@ -2384,24 +2494,15 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) * we want to make sure everything inside is valid utf8 first. */ c = SvPVX(sv); - while (c < SvEND(sv)) { - if (*c & 0x80) { - I32 len; - (void)utf8_to_uv((U8*)c, &len); - if (len == 1) { - /* bad utf8 */ - return FALSE; - } - c += len; - has_utf = TRUE; - } - else { - c++; - } + if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) + return FALSE; + e = SvEND(sv); + while (c < e) { + if (UTF8_IS_CONTINUED(*c++)) { + SvUTF8_on(sv); + break; + } } - - if (has_utf) - SvUTF8_on(sv); } return TRUE; } @@ -2426,7 +2527,6 @@ C<sv_setsv_mg>. void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { - dTHR; register U32 sflags; register int dtype; register int stype; @@ -2469,7 +2569,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); if (SvIsUV(sstr)) SvIsUV_on(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2489,7 +2590,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) } SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2543,7 +2645,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); - sv_magic(dstr, dstr, '*', name, len); + sv_magic(dstr, dstr, '*', Nullch, 0); GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; @@ -2558,7 +2660,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { @@ -2704,7 +2807,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvREFCNT_dec(dref); if (intro) SAVEFREESV(sref); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } if (SvPVX(dstr)) { @@ -2724,7 +2828,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } if (SvAMAGIC(sstr)) { @@ -2756,13 +2860,9 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); - if (SvUTF8(sstr)) - SvUTF8_on(dstr); - else - SvUTF8_off(dstr); SvTEMP_off(dstr); - (void)SvOK_off(sstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); @@ -2777,7 +2877,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } - if (DO_UTF8(sstr)) + if (sflags & SVf_UTF8) SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { @@ -2787,25 +2887,25 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - if (SvIOK(sstr)) { + if (sflags & SVf_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } else { @@ -2816,7 +2916,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else (void)SvOK_off(dstr); } - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); } /* @@ -2847,13 +2948,17 @@ void Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { register char *dptr; - assert(len >= 0); /* STRLEN is probably unsigned, so this may - elicit a warning, but it won't hurt. */ + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; } + else { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + assert(iv >= 0); + } (void)SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); @@ -2978,7 +3083,6 @@ void Perl_sv_force_normal(pTHX_ register SV *sv) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -3076,25 +3180,42 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL /* =for apidoc sv_catsv -Concatenates the string from SV C<ssv> onto the end of the string in SV -C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>. +Concatenates the string from SV C<ssv> onto the end of the string in +SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but +not 'set' magic. See C<sv_catsv_mg>. -=cut -*/ +=cut */ void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { - char *s; - STRLEN len; + char *spv; + STRLEN slen; if (!sstr) return; - if ((s = SvPV(sstr, len))) { - if (SvUTF8(sstr)) - sv_utf8_upgrade(dstr); - sv_catpvn(dstr,s,len); - if (SvUTF8(sstr)) - SvUTF8_on(dstr); + if ((spv = SvPV(sstr, slen))) { + bool dutf8 = DO_UTF8(dstr); + bool sutf8 = DO_UTF8(sstr); + + if (dutf8 == sutf8) + sv_catpvn(dstr,spv,slen); + else { + if (dutf8) { + SV* cstr = newSVsv(sstr); + char *cpv; + STRLEN clen; + + sv_utf8_upgrade(cstr); + cpv = SvPV(cstr,clen); + sv_catpvn(dstr,cpv,clen); + sv_2mortal(cstr); + } + else { + sv_utf8_upgrade(dstr); + sv_catpvn(dstr,spv,slen); + SvUTF8_on(dstr); + } + } } } @@ -3186,7 +3307,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam MAGIC* mg; if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling && !strchr("gBf", how)) Perl_croak(aTHX_ PL_no_modify); } @@ -3202,12 +3322,21 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#' || how == 'r') + + /* Some magic sontains a reference loop, where the sv and object refer to + each other. To prevent a avoid a reference loop that would prevent such + objects being freed, we look for such loops and if we find one we avoid + incrementing the object refcount. */ + if (!obj || obj == sv || how == '#' || how == 'r' || + (SvTYPE(obj) == SVt_PVGV && + (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || + GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || + GvFORM(obj) == (CV*)sv))) + { mg->mg_obj = obj; + } else { - dTHR; mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } @@ -3337,6 +3466,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } +/* +=for apidoc sv_unmagic + +Removes magic from an SV. + +=cut +*/ + int Perl_sv_unmagic(pTHX_ SV *sv, int type) { @@ -3371,6 +3508,14 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) return 0; } +/* +=for apidoc sv_rvweaken + +Weaken a reference. + +=cut +*/ + SV * Perl_sv_rvweaken(pTHX_ SV *sv) { @@ -3380,7 +3525,6 @@ Perl_sv_rvweaken(pTHX_ SV *sv) if (!SvROK(sv)) Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - dTHR; if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Reference is already weak"); return sv; @@ -3392,8 +3536,8 @@ Perl_sv_rvweaken(pTHX_ SV *sv) return sv; } -STATIC void -S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +void +Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; MAGIC *mg; @@ -3407,8 +3551,8 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) av_push(av,sv); } -STATIC void -S_sv_del_backref(pTHX_ SV *sv) +void +Perl_sv_del_backref(pTHX_ SV *sv) { AV *av; SV **svp; @@ -3451,6 +3595,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); SvPV_force(bigstr, curlen); + (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); @@ -3521,12 +3666,17 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvSETMAGIC(bigstr); } -/* make sv point to what nstr did */ +/* +=for apidoc sv_replace + +Make the first argument a copy of the second, then delete the original. + +=cut +*/ void Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { - dTHR; U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) @@ -3550,6 +3700,15 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) del_SV(nsv); } +/* +=for apidoc sv_clear + +Clear an SV, making it empty. Does not free the memory used by the SV +itself. + +=cut +*/ + void Perl_sv_clear(pTHX_ register SV *sv) { @@ -3558,9 +3717,8 @@ Perl_sv_clear(pTHX_ register SV *sv) assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { - dTHR; if (PL_defstash) { /* Still have a symbol table? */ - djSP; + dSP; GV* destructor; SV tmpref; @@ -3743,10 +3901,17 @@ Perl_sv_newref(pTHX_ SV *sv) return sv; } +/* +=for apidoc sv_free + +Free the memory used by an SV. + +=cut +*/ + void Perl_sv_free(pTHX_ SV *sv) { - dTHR; int refcount_is_zero; if (!sv) @@ -3811,29 +3976,32 @@ Perl_sv_len(pTHX_ register SV *sv) return len; } +/* +=for apidoc sv_len_utf8 + +Returns the number of characters in the string in an SV, counting wide +UTF8 bytes as a single character. + +=cut +*/ + STRLEN Perl_sv_len_utf8(pTHX_ register SV *sv) { - U8 *s; - U8 *send; - STRLEN len; - if (!sv) return 0; #ifdef NOTYET if (SvGMAGICAL(sv)) - len = mg_length(sv); + return mg_length(sv); else #endif - s = (U8*)SvPV(sv, len); - send = s + len; - len = 0; - while (s < send) { - s += UTF8SKIP(s); - len++; + { + STRLEN len; + U8 *s = (U8*)SvPV(sv, len); + + return Perl_utf8_length(aTHX_ s, s + len); } - return len; } void @@ -3879,18 +4047,18 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) s = (U8*)SvPV(sv, len); if (len < *offsetp) - Perl_croak(aTHX_ "panic: bad byte offset"); + Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); send = s + *offsetp; len = 0; while (s < send) { - s += UTF8SKIP(s); - ++len; - } - if (s != send) { - dTHR; - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - --len; + STRLEN n; + + if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) { + s += n; + len++; + } + else + break; } *offsetp = len; return; @@ -3906,29 +4074,57 @@ identical. */ I32 -Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) +Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) { char *pv1; STRLEN cur1; char *pv2; STRLEN cur2; + I32 eq = 0; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (!str1) { + if (!sv1) { pv1 = ""; cur1 = 0; } else - pv1 = SvPV(str1, cur1); + pv1 = SvPV(sv1, cur1); - if (!str2) - return !cur1; + if (!sv2){ + pv2 = ""; + cur2 = 0; + } else - pv2 = SvPV(str2, cur2); + pv2 = SvPV(sv2, cur2); - if (cur1 != cur2) - return 0; + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + bool is_utf8 = TRUE; + + if (SvUTF8(sv1)) { + char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); + + if ((pv1tmp = (pv != pv1))) + pv1 = pv; + } + else { + char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); - return memEQ(pv1, pv2, cur1); + if ((pv2tmp = (pv != pv2))) + pv2 = pv; + } + } + + if (cur1 == cur2) + eq = memEQ(pv1, pv2, cur1); + + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); + + return eq; } /* @@ -3942,60 +4138,72 @@ C<sv2>. */ I32 -Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) +Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; char *pv1, *pv2; - I32 retval; + I32 cmp; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (str1) { - pv1 = SvPV(str1, cur1); - } - else { + if (!sv1) { + pv1 = ""; cur1 = 0; } + else + pv1 = SvPV(sv1, cur1); + + if (!sv2){ + pv2 = ""; + cur2 = 0; + } + else + pv2 = SvPV(sv2, cur2); - if (str2) { - if (SvPOK(str2)) { - if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) { - /* must upgrade other to UTF8 first */ - if (SvUTF8(str1)) { - sv_utf8_upgrade(str2); - } - else { - sv_utf8_upgrade(str1); - /* refresh pointer and length */ - pv1 = SvPVX(str1); - cur1 = SvCUR(str1); - } - } - pv2 = SvPVX(str2); - cur2 = SvCUR(str2); - } + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (SvUTF8(sv1)) { + pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); + pv2tmp = TRUE; + } else { - pv2 = sv_2pv(str2, &cur2); + pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); + pv1tmp = TRUE; } } - else { - cur2 = 0; + + if (!cur1) { + cmp = cur2 ? -1 : 0; + } else if (!cur2) { + cmp = 1; + } else { + I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + if (retval) { + cmp = retval < 0 ? -1 : 1; + } else if (cur1 == cur2) { + cmp = 0; + } else { + cmp = cur1 < cur2 ? -1 : 1; + } } - if (!cur1) - return cur2 ? -1 : 0; + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); - if (!cur2) - return 1; + return cmp; +} - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); +/* +=for apidoc sv_cmp_locale - if (retval) - return retval < 0 ? -1 : 1; +Compares the strings in two SVs in a locale-aware manner. See +L</sv_cmp_locale> - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; -} +=cut +*/ I32 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) @@ -4098,10 +4306,18 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) #endif /* USE_LOCALE_COLLATE */ +/* +=for apidoc sv_gets + +Get a line from the filehandle and store it into the SV, optionally +appending to the currently-stored string. + +=cut +*/ + char * Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { - dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -4137,14 +4353,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #endif SvCUR_set(sv, bytesread); buffer[bytesread] = '\0'; + SvUTF8_off(sv); return(SvCUR(sv) ? SvPVX(sv) : Nullch); } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } - else + else { + /* Get $/ i.e. PL_rs into same encoding as stream wants */ + if (SvUTF8(PL_rs)) { + if (!sv_utf8_downgrade(PL_rs, TRUE)) { + Perl_croak(aTHX_ "Wide character in $/"); + } + } rsptr = SvPV(PL_rs, rslen); + } + rslast = rslen ? rsptr[rslen - 1] : '\0'; if (RsPARA(PL_rs)) { /* have to do this both before and after */ @@ -4363,6 +4588,8 @@ screamer2: } } + SvUTF8_off(sv); + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -4387,7 +4614,6 @@ Perl_sv_inc(pTHX_ register SV *sv) mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -4495,7 +4721,6 @@ Perl_sv_dec(pTHX_ register SV *sv) mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -4561,7 +4786,6 @@ as mortal. SV * Perl_sv_mortalcopy(pTHX_ SV *oldstr) { - dTHR; register SV *sv; new_SV(sv); @@ -4583,7 +4807,6 @@ Creates a new SV which is mortal. The reference count of the SV is set to 1. SV * Perl_sv_newmortal(pTHX) { - dTHR; register SV *sv; new_SV(sv); @@ -4607,7 +4830,6 @@ ends. SV * Perl_sv_2mortal(pTHX_ register SV *sv) { - dTHR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) @@ -4773,7 +4995,6 @@ SV is B<not> incremented. SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { - dTHR; register SV *sv; new_SV(sv); @@ -4804,7 +5025,6 @@ Creates a new SV which is an exact duplicate of the original SV. SV * Perl_newSVsv(pTHX_ register SV *old) { - dTHR; register SV *sv; if (!old) @@ -4887,7 +5107,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) } if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); -#ifndef VMS /* VMS has no environ array */ +#ifdef USE_ENVIRON_ARRAY if (gv == PL_envgv) environ[0] = Nullch; #endif @@ -4959,7 +5179,6 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { - dTHR; SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); @@ -5004,10 +5223,17 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) } } +/* +=for apidoc sv_true + +Returns true if the SV has a true value by Perl's rules. + +=cut +*/ + I32 Perl_sv_true(pTHX_ register SV *sv) { - dTHR; if (!sv) return 0; if (SvPOK(sv)) { @@ -5082,6 +5308,14 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } +/* +=for apidoc sv_pvn_force + +Get a sensible string out of the SV somehow. + +=cut +*/ + char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { @@ -5095,7 +5329,6 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) } else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { - dTHR; Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), PL_op_name[PL_op->op_type]); } @@ -5154,6 +5387,15 @@ Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) return sv_pvn(sv,lp); } +/* +=for apidoc sv_pvutf8n_force + +Get a sensible UTF8-encoded string out of the SV somehow. See +L</sv_pvn_force>. + +=cut +*/ + char * Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) { @@ -5161,6 +5403,14 @@ Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) return sv_pvn_force(sv,lp); } +/* +=for apidoc sv_reftype + +Returns a string describing what the SV is a reference to. + +=cut +*/ + char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { @@ -5258,7 +5508,6 @@ reference count is 1. SV* Perl_newSVrv(pTHX_ SV *rv, const char *classname) { - dTHR; SV *sv; new_SV(sv); @@ -5266,8 +5515,23 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SV_CHECK_THINKFIRST(rv); SvAMAGIC_off(rv); + if (SvTYPE(rv) >= SVt_PVMG) { + U32 refcnt = SvREFCNT(rv); + SvREFCNT(rv) = 0; + sv_clear(rv); + SvFLAGS(rv) = 0; + SvREFCNT(rv) = refcnt; + } + if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_RV); + else if (SvTYPE(rv) > SVt_RV) { + (void)SvOOK_off(rv); + if (SvPVX(rv) && SvLEN(rv)) + Safefree(SvPVX(rv)); + SvCUR_set(rv, 0); + SvLEN_set(rv, 0); + } (void)SvOK_off(rv); SvRV(rv) = sv; @@ -5383,7 +5647,6 @@ of the SV is unaffected. SV* Perl_sv_bless(pTHX_ SV *sv, HV *stash) { - dTHR; SV *tmpRef; if (!SvROK(sv)) Perl_croak(aTHX_ "Can't bless non-reference value"); @@ -5706,7 +5969,6 @@ locales). void Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { - dTHR; char *p; char *q; char *patend; @@ -5763,7 +6025,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool is_utf = FALSE; char esignbuf[4]; - U8 utf8buf[UTF8_MAXLEN]; + U8 utf8buf[UTF8_MAXLEN+1]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -5839,17 +6101,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'v': vectorize = TRUE; q++; - if (args) - vecsv = va_arg(*args, SV*); - else if (svix < svmax) - vecsv = svargs[svix++]; - else { - vecstr = (U8*)""; - veclen = 0; - continue; - } - vecstr = (U8*)SvPVx(vecsv,veclen); - utf = DO_UTF8(vecsv); continue; default: @@ -5900,19 +6151,39 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV has_precis = TRUE; } + if (vectorize) { + if (args) { + vecsv = va_arg(*args, SV*); + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else if (svix < svmax) { + vecsv = svargs[svix++]; + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else { + vecstr = (U8*)""; + veclen = 0; + } + } + /* SIZE */ switch (*q) { -#ifdef HAS_QUAD +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) case 'L': /* Ld */ + /* FALL THROUGH */ +#endif +#ifdef HAS_QUAD case 'q': /* qd */ intsize = 'q'; q++; break; #endif case 'l': -#ifdef HAS_QUAD - if (*(q + 1) == 'l') { /* lld */ +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; @@ -6009,6 +6280,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': + if (alt) + goto unknown; if (args) uv = PTR2UV(va_arg(*args, void*)); else @@ -6026,13 +6299,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'd': case 'i': if (vectorize) { - I32 ulen; + STRLEN ulen; if (!veclen) { vectorize = FALSE; break; } if (utf) - iv = (IV)utf8_to_uv(vecstr, &ulen); + iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); else { iv = *vecstr; ulen = 1; @@ -6055,7 +6328,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; - default: iv = (int)iv; break; + default: break; case 'l': iv = (long)iv; break; case 'V': break; #ifdef HAS_QUAD @@ -6107,14 +6380,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uns_integer: if (vectorize) { - I32 ulen; + STRLEN ulen; vector: if (!veclen) { vectorize = FALSE; break; } if (utf) - uv = utf8_to_uv(vecstr, &ulen); + uv = utf8_to_uv(vecstr, veclen, &ulen, 0); else { uv = *vecstr; ulen = 1; @@ -6137,7 +6410,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; - default: uv = (unsigned)uv; break; + default: break; case 'l': uv = (unsigned long)uv; break; case 'V': break; #ifdef HAS_QUAD @@ -6252,11 +6525,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; -#ifdef USE_LONG_DOUBLE +#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl) { - static char const my_prifldbl[] = PERL_PRIfldbl; - char const *p = my_prifldbl + sizeof my_prifldbl - 3; - while (p >= my_prifldbl) { *--eptr = *p--; } + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const prifldbl[] = PERL_PRIfldbl; + char const *p = prifldbl + sizeof(prifldbl) - 3; + while (p >= prifldbl) { *--eptr = *p--; } } #endif if (has_precis) { @@ -6278,11 +6554,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '#'; *--eptr = '%'; - { - RESTORE_NUMERIC_STANDARD(); - (void)sprintf(PL_efloatbuf, eptr, nv); - RESTORE_NUMERIC_LOCAL(); - } + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ + (void)sprintf(PL_efloatbuf, eptr, nv); eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); @@ -6305,7 +6580,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else if (svix < svmax) - sv_setuv(svargs[svix++], (UV)i); + sv_setuv_mg(svargs[svix++], (UV)i); continue; /* not "break" */ /* UNKNOWN */ @@ -6489,8 +6764,8 @@ Perl_gp_dup(pTHX_ GP *gp) MAGIC * Perl_mg_dup(pTHX_ MAGIC *mg) { - MAGIC *mgret = (MAGIC*)NULL; - MAGIC *mgprev; + MAGIC *mgprev = (MAGIC*)NULL; + MAGIC *mgret; if (!mg) return (MAGIC*)NULL; /* look for it in the table first */ @@ -6501,10 +6776,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); - if (!mgret) - mgret = nmg; - else + if (mgprev) mgprev->mg_moremagic = nmg; + else + mgret = nmg; nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; @@ -6623,6 +6898,51 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) } } +void +Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) +{ + register PTR_TBL_ENT_t **array; + register PTR_TBL_ENT_t *entry; + register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*); + UV riter = 0; + UV max; + + if (!tbl || !tbl->tbl_items) { + return; + } + + array = tbl->tbl_ary; + entry = array[0]; + max = tbl->tbl_max; + + for (;;) { + if (entry) { + oentry = entry; + entry = entry->next; + Safefree(oentry); + } + if (!entry) { + if (++riter > max) { + break; + } + entry = array[riter]; + } + } + + tbl->tbl_items = 0; +} + +void +Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) +{ + if (!tbl) { + return; + } + ptr_table_clear(tbl); + Safefree(tbl->tbl_ary); + Safefree(tbl); +} + #ifdef DEBUGGING char *PL_watch_pvx; #endif @@ -6906,7 +7226,7 @@ dup_pvcv: CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); - CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvGV(dstr) = gv_dup(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { /* XXX padlists are real, but pretend to be not */ @@ -6917,7 +7237,10 @@ dup_pvcv: } else CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + if (!CvANON(sstr) || CvCLONED(sstr)) + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + else + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; default: @@ -6971,7 +7294,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray) : Nullav); - ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; @@ -7126,6 +7449,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv); break; + case SAVEt_GENERIC_PVREF: /* generic char* */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); @@ -7219,6 +7548,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) TOPIV(nss,ix) = iv; break; case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv); break; @@ -7311,6 +7641,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) av = (AV*)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup(av); break; + case SAVEt_PADSV: + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); } @@ -7404,17 +7742,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* arena roots */ PL_xiv_arenaroot = NULL; PL_xiv_root = NULL; + PL_xnv_arenaroot = NULL; PL_xnv_root = NULL; + PL_xrv_arenaroot = NULL; PL_xrv_root = NULL; + PL_xpv_arenaroot = NULL; PL_xpv_root = NULL; + PL_xpviv_arenaroot = NULL; PL_xpviv_root = NULL; + PL_xpvnv_arenaroot = NULL; PL_xpvnv_root = NULL; + PL_xpvcv_arenaroot = NULL; PL_xpvcv_root = NULL; + PL_xpvav_arenaroot = NULL; PL_xpvav_root = NULL; + PL_xpvhv_arenaroot = NULL; PL_xpvhv_root = NULL; + PL_xpvmg_arenaroot = NULL; PL_xpvmg_root = NULL; + PL_xpvlv_arenaroot = NULL; PL_xpvlv_root = NULL; + PL_xpvbm_arenaroot = NULL; PL_xpvbm_root = NULL; + PL_he_arenaroot = NULL; PL_he_root = NULL; PL_nice_chunk = NULL; PL_nice_chunk_size = 0; @@ -7528,7 +7878,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_defgv = gv_dup(proto_perl->Idefgv); PL_argvgv = gv_dup(proto_perl->Iargvgv); PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); - PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack); /* shortcuts to regexp stuff */ PL_replgv = gv_dup(proto_perl->Ireplgv); @@ -7740,7 +8090,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); PL_numeric_standard = proto_perl->Inumeric_standard; PL_numeric_local = proto_perl->Inumeric_local; - PL_numeric_radix = proto_perl->Inumeric_radix; + PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv); #endif /* !USE_LOCALE_NUMERIC */ /* utf8 character classes */ @@ -7798,7 +8148,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* thrdvar.h stuff */ - if (flags & 1) { + if (flags & CLONEf_COPY_STACKS) { /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ PL_tmps_ix = proto_perl->Ttmps_ix; PL_tmps_max = proto_perl->Ttmps_max; @@ -7856,6 +8206,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } else { init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ } PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ @@ -7984,6 +8335,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + #ifdef PERL_OBJECT return (PerlInterpreter*)pPerl; #else @@ -8015,9 +8371,15 @@ do_clean_objs(pTHXo_ SV *sv) if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + } else { + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } } /* XXX Might want to check arrays, etc. */ |