X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=de411a597bbe1ff3733342d762cd0c12ec9eaa20;hb=cdb061a3fd27d5d1ef0b49f7eca3a56c45076e24;hp=799cf526feb98ef21f0cbe16c3d8d643e941ac7d;hpb=2e7ed132d3ea6a9040a623e3541f25dd0709096b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 799cf52..de411a5 100644 --- a/sv.c +++ b/sv.c @@ -523,7 +523,7 @@ Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; - XPV *arena, *arenanext; + void *arena, *arenanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -534,95 +534,81 @@ Perl_sv_free_arenas(pTHX) svanext = (SV*) SvANY(svanext); if (!SvFAKE(sva)) - Safefree((void *)sva); + Safefree(sva); } - for (arena = PL_xiv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; - Safefree(arena); - } - PL_xiv_arenaroot = 0; - PL_xiv_root = 0; - for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + arenanext = *(void **)arena; Safefree(arena); } PL_xnv_arenaroot = 0; PL_xnv_root = 0; - for (arena = PL_xrv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; - Safefree(arena); - } - PL_xrv_arenaroot = 0; - PL_xrv_root = 0; - for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + arenanext = *(void **)arena; Safefree(arena); } PL_xpv_arenaroot = 0; PL_xpv_root = 0; - for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpviv_arenaroot = 0; PL_xpviv_root = 0; - for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvnv_arenaroot = 0; PL_xpvnv_root = 0; - for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvcv_arenaroot = 0; PL_xpvcv_root = 0; - for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvav_arenaroot = 0; PL_xpvav_root = 0; - for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvhv_arenaroot = 0; PL_xpvhv_root = 0; - for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvmg_arenaroot = 0; PL_xpvmg_root = 0; - for (arena = (XPV*)PL_xpvgv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvgv_arenaroot = 0; PL_xpvgv_root = 0; - for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvlv_arenaroot = 0; PL_xpvlv_root = 0; - for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) { - arenanext = (XPV*)arena->xpv_pv; + for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) { + arenanext = *(void **)arena; Safefree(arena); } PL_xpvbm_arenaroot = 0; @@ -754,7 +740,7 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, sv_setpv(name, gvtype); if (!hv) p = "???"; - else if (!(p=HvNAME(hv))) + else if (!(p=HvNAME_get(hv))) p = "__ANON__"; if (strNE(p, "main")) { sv_catpv(name,p); @@ -772,19 +758,22 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, else { U32 u; CV *cv = find_runcv(&u); + STRLEN len; + const char *str; if (!cv || !CvPADLIST(cv)) return Nullsv;; av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); sv = *av_fetch(av, targ, FALSE); /* SvLEN in a pad name is not to be trusted */ - sv_setpv(name, SvPV_nolen(sv)); + str = SvPV(sv,len); + sv_setpvn(name, str, len); } if (subscript_type == FUV_SUBSCRIPT_HASH) { *SvPVX(name) = '$'; sv = NEWSV(0,0); Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32)); + pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); SvREFCNT_dec(sv); } else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { @@ -1042,7 +1031,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) : DEFSV)) { sv = sv_newmortal(); - sv_setpv(sv, "$_"); + sv_setpvn(sv, "$_", 2); return sv; } } @@ -1139,53 +1128,6 @@ Perl_report_uninit(pTHX_ SV* uninit_sv) "", "", ""); } - -/* allocate another arena's worth of struct xrv */ - -STATIC void -S_more_xrv(pTHX) -{ - XRV* xrv; - XRV* xrvend; - XPV *ptr; - New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)PL_xrv_arenaroot; - PL_xrv_arenaroot = ptr; - - xrv = (XRV*) ptr; - xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1]; - xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1; - PL_xrv_root = xrv; - while (xrv < xrvend) { - xrv->xrv_rv = (SV*)(xrv + 1); - xrv++; - } - xrv->xrv_rv = 0; -} - -/* allocate another arena's worth of IV bodies */ - -STATIC void -S_more_xiv(pTHX) -{ - IV* xiv; - IV* xivend; - XPV* ptr; - New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ - PL_xiv_arenaroot = ptr; /* to keep Purify happy */ - - xiv = (IV*) ptr; - xivend = &xiv[PERL_ARENA_SIZE / sizeof(IV) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ - PL_xiv_root = xiv; - while (xiv < xivend) { - *(IV**)xiv = (IV *)(xiv + 1); - xiv++; - } - *(IV**)xiv = 0; -} - /* allocate another arena's worth of NV bodies */ STATIC void @@ -1193,9 +1135,9 @@ S_more_xnv(pTHX) { NV* xnv; NV* xnvend; - XPV *ptr; - New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)PL_xnv_arenaroot; + void *ptr; + New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV); + *((void **) ptr) = (void *)PL_xnv_arenaroot; PL_xnv_arenaroot = ptr; xnv = (NV*) ptr; @@ -1214,19 +1156,19 @@ S_more_xnv(pTHX) STATIC void S_more_xpv(pTHX) { - XPV* xpv; - XPV* xpvend; - New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV); - xpv->xpv_pv = (char*)PL_xpv_arenaroot; + xpv_allocated* xpv; + xpv_allocated* xpvend; + New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated); + *((xpv_allocated**)xpv) = PL_xpv_arenaroot; PL_xpv_arenaroot = xpv; - xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1]; + xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1]; PL_xpv_root = ++xpv; while (xpv < xpvend) { - xpv->xpv_pv = (char*)(xpv + 1); + *((xpv_allocated**)xpv) = xpv + 1; xpv++; } - xpv->xpv_pv = 0; + *((xpv_allocated**)xpv) = 0; } /* allocate another arena's worth of struct xpviv */ @@ -1234,19 +1176,19 @@ S_more_xpv(pTHX) STATIC void S_more_xpviv(pTHX) { - XPVIV* xpviv; - XPVIV* xpvivend; - New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV); - xpviv->xpv_pv = (char*)PL_xpviv_arenaroot; + xpviv_allocated* xpviv; + xpviv_allocated* xpvivend; + New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated); + *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot; PL_xpviv_arenaroot = xpviv; - xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1]; + xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1]; PL_xpviv_root = ++xpviv; while (xpviv < xpvivend) { - xpviv->xpv_pv = (char*)(xpviv + 1); + *((xpviv_allocated**)xpviv) = xpviv + 1; xpviv++; } - xpviv->xpv_pv = 0; + *((xpviv_allocated**)xpviv) = 0; } /* allocate another arena's worth of struct xpvnv */ @@ -1257,16 +1199,16 @@ S_more_xpvnv(pTHX) XPVNV* xpvnv; XPVNV* xpvnvend; New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV); - xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot; + *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot; PL_xpvnv_arenaroot = xpvnv; xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1]; PL_xpvnv_root = ++xpvnv; while (xpvnv < xpvnvend) { - xpvnv->xpv_pv = (char*)(xpvnv + 1); + *((XPVNV**)xpvnv) = xpvnv + 1; xpvnv++; } - xpvnv->xpv_pv = 0; + *((XPVNV**)xpvnv) = 0; } /* allocate another arena's worth of struct xpvcv */ @@ -1277,16 +1219,16 @@ S_more_xpvcv(pTHX) XPVCV* xpvcv; XPVCV* xpvcvend; New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV); - xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot; + *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot; PL_xpvcv_arenaroot = xpvcv; xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1]; PL_xpvcv_root = ++xpvcv; while (xpvcv < xpvcvend) { - xpvcv->xpv_pv = (char*)(xpvcv + 1); + *((XPVCV**)xpvcv) = xpvcv + 1; xpvcv++; } - xpvcv->xpv_pv = 0; + *((XPVCV**)xpvcv) = 0; } /* allocate another arena's worth of struct xpvav */ @@ -1294,19 +1236,20 @@ S_more_xpvcv(pTHX) STATIC void S_more_xpvav(pTHX) { - XPVAV* xpvav; - XPVAV* xpvavend; - New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV); - xpvav->xav_array = (char*)PL_xpvav_arenaroot; + xpvav_allocated* xpvav; + xpvav_allocated* xpvavend; + New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated), + xpvav_allocated); + *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot; PL_xpvav_arenaroot = xpvav; - xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1]; + xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1]; PL_xpvav_root = ++xpvav; while (xpvav < xpvavend) { - xpvav->xav_array = (char*)(xpvav + 1); + *((xpvav_allocated**)xpvav) = xpvav + 1; xpvav++; } - xpvav->xav_array = 0; + *((xpvav_allocated**)xpvav) = 0; } /* allocate another arena's worth of struct xpvhv */ @@ -1314,19 +1257,20 @@ S_more_xpvav(pTHX) STATIC void S_more_xpvhv(pTHX) { - XPVHV* xpvhv; - XPVHV* xpvhvend; - New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV); - xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot; + xpvhv_allocated* xpvhv; + xpvhv_allocated* xpvhvend; + New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated), + xpvhv_allocated); + *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot; PL_xpvhv_arenaroot = xpvhv; - xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1]; + xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1]; PL_xpvhv_root = ++xpvhv; while (xpvhv < xpvhvend) { - xpvhv->xhv_array = (char*)(xpvhv + 1); + *((xpvhv_allocated**)xpvhv) = xpvhv + 1; xpvhv++; } - xpvhv->xhv_array = 0; + *((xpvhv_allocated**)xpvhv) = 0; } /* allocate another arena's worth of struct xpvmg */ @@ -1337,16 +1281,16 @@ S_more_xpvmg(pTHX) XPVMG* xpvmg; XPVMG* xpvmgend; New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG); - xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot; + *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot; PL_xpvmg_arenaroot = xpvmg; xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1]; PL_xpvmg_root = ++xpvmg; while (xpvmg < xpvmgend) { - xpvmg->xpv_pv = (char*)(xpvmg + 1); + *((XPVMG**)xpvmg) = xpvmg + 1; xpvmg++; } - xpvmg->xpv_pv = 0; + *((XPVMG**)xpvmg) = 0; } /* allocate another arena's worth of struct xpvgv */ @@ -1357,16 +1301,16 @@ S_more_xpvgv(pTHX) XPVGV* xpvgv; XPVGV* xpvgvend; New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV); - xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot; + *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot; PL_xpvgv_arenaroot = xpvgv; xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1]; PL_xpvgv_root = ++xpvgv; while (xpvgv < xpvgvend) { - xpvgv->xpv_pv = (char*)(xpvgv + 1); + *((XPVGV**)xpvgv) = xpvgv + 1; xpvgv++; } - xpvgv->xpv_pv = 0; + *((XPVGV**)xpvgv) = 0; } /* allocate another arena's worth of struct xpvlv */ @@ -1377,16 +1321,16 @@ S_more_xpvlv(pTHX) XPVLV* xpvlv; XPVLV* xpvlvend; New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV); - xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot; + *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot; PL_xpvlv_arenaroot = xpvlv; xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1]; PL_xpvlv_root = ++xpvlv; while (xpvlv < xpvlvend) { - xpvlv->xpv_pv = (char*)(xpvlv + 1); + *((XPVLV**)xpvlv) = xpvlv + 1; xpvlv++; } - xpvlv->xpv_pv = 0; + *((XPVLV**)xpvlv) = 0; } /* allocate another arena's worth of struct xpvbm */ @@ -1397,72 +1341,16 @@ S_more_xpvbm(pTHX) XPVBM* xpvbm; XPVBM* xpvbmend; New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM); - xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot; + *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot; PL_xpvbm_arenaroot = xpvbm; xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1]; PL_xpvbm_root = ++xpvbm; while (xpvbm < xpvbmend) { - xpvbm->xpv_pv = (char*)(xpvbm + 1); + *((XPVBM**)xpvbm) = xpvbm + 1; xpvbm++; } - xpvbm->xpv_pv = 0; -} - -/* grab a new struct xrv from the free list, allocating more if necessary */ - -STATIC XRV* -S_new_xrv(pTHX) -{ - XRV* xrv; - LOCK_SV_MUTEX; - if (!PL_xrv_root) - S_more_xrv(aTHX); - xrv = PL_xrv_root; - PL_xrv_root = (XRV*)xrv->xrv_rv; - UNLOCK_SV_MUTEX; - return xrv; -} - -/* return a struct xrv to the free list */ - -STATIC void -S_del_xrv(pTHX_ XRV *p) -{ - LOCK_SV_MUTEX; - p->xrv_rv = (SV*)PL_xrv_root; - PL_xrv_root = p; - UNLOCK_SV_MUTEX; -} - -/* grab a new IV body from the free list, allocating more if necessary */ - -STATIC XPVIV* -S_new_xiv(pTHX) -{ - IV* xiv; - LOCK_SV_MUTEX; - if (!PL_xiv_root) - S_more_xiv(aTHX); - xiv = PL_xiv_root; - /* - * See comment in more_xiv() -- RAM. - */ - PL_xiv_root = *(IV**)xiv; - UNLOCK_SV_MUTEX; - return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); -} - -/* return an IV body to the free list */ - -STATIC void -S_del_xiv(pTHX_ XPVIV *p) -{ - IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); - LOCK_SV_MUTEX; - *(IV**)xiv = PL_xiv_root; - PL_xiv_root = xiv; - UNLOCK_SV_MUTEX; + *((XPVBM**)xpvbm) = 0; } /* grab a new NV body from the free list, allocating more if necessary */ @@ -1497,14 +1385,20 @@ S_del_xnv(pTHX_ XPVNV *p) STATIC XPV* S_new_xpv(pTHX) { - XPV* xpv; + xpv_allocated* xpv; LOCK_SV_MUTEX; if (!PL_xpv_root) S_more_xpv(aTHX); xpv = PL_xpv_root; - PL_xpv_root = (XPV*)xpv->xpv_pv; + PL_xpv_root = *(xpv_allocated**)xpv; UNLOCK_SV_MUTEX; - return xpv; + /* If xpv_allocated is the same structure as XPV then the two OFFSETs + sum to zero, and the pointer is unchanged. If the allocated structure + is smaller (no initial IV actually allocated) then the net effect is + to subtract the size of the IV from the pointer, to return a new pointer + as if an initial IV were actually allocated. */ + return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur) + + STRUCT_OFFSET(xpv_allocated, xpv_cur)); } /* return a struct xpv to the free list */ @@ -1512,9 +1406,12 @@ S_new_xpv(pTHX) STATIC void S_del_xpv(pTHX_ XPV *p) { + xpv_allocated* xpv + = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur)); LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpv_root; - PL_xpv_root = p; + *(xpv_allocated**)xpv = PL_xpv_root; + PL_xpv_root = xpv; UNLOCK_SV_MUTEX; } @@ -1523,14 +1420,20 @@ S_del_xpv(pTHX_ XPV *p) STATIC XPVIV* S_new_xpviv(pTHX) { - XPVIV* xpviv; + xpviv_allocated* xpviv; LOCK_SV_MUTEX; if (!PL_xpviv_root) S_more_xpviv(aTHX); xpviv = PL_xpviv_root; - PL_xpviv_root = (XPVIV*)xpviv->xpv_pv; + PL_xpviv_root = *(xpviv_allocated**)xpviv; UNLOCK_SV_MUTEX; - return xpviv; + /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs + sum to zero, and the pointer is unchanged. If the allocated structure + is smaller (no initial IV actually allocated) then the net effect is + to subtract the size of the IV from the pointer, to return a new pointer + as if an initial IV were actually allocated. */ + return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur) + + STRUCT_OFFSET(xpviv_allocated, xpv_cur)); } /* return a struct xpviv to the free list */ @@ -1538,9 +1441,12 @@ S_new_xpviv(pTHX) STATIC void S_del_xpviv(pTHX_ XPVIV *p) { + xpviv_allocated* xpviv + = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur)); LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpviv_root; - PL_xpviv_root = p; + *(xpviv_allocated**)xpviv = PL_xpviv_root; + PL_xpviv_root = xpviv; UNLOCK_SV_MUTEX; } @@ -1554,7 +1460,7 @@ S_new_xpvnv(pTHX) if (!PL_xpvnv_root) S_more_xpvnv(aTHX); xpvnv = PL_xpvnv_root; - PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv; + PL_xpvnv_root = *(XPVNV**)xpvnv; UNLOCK_SV_MUTEX; return xpvnv; } @@ -1565,7 +1471,7 @@ STATIC void S_del_xpvnv(pTHX_ XPVNV *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvnv_root; + *(XPVNV**)p = PL_xpvnv_root; PL_xpvnv_root = p; UNLOCK_SV_MUTEX; } @@ -1580,7 +1486,7 @@ S_new_xpvcv(pTHX) if (!PL_xpvcv_root) S_more_xpvcv(aTHX); xpvcv = PL_xpvcv_root; - PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv; + PL_xpvcv_root = *(XPVCV**)xpvcv; UNLOCK_SV_MUTEX; return xpvcv; } @@ -1591,7 +1497,7 @@ STATIC void S_del_xpvcv(pTHX_ XPVCV *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvcv_root; + *(XPVCV**)p = PL_xpvcv_root; PL_xpvcv_root = p; UNLOCK_SV_MUTEX; } @@ -1601,14 +1507,15 @@ S_del_xpvcv(pTHX_ XPVCV *p) STATIC XPVAV* S_new_xpvav(pTHX) { - XPVAV* xpvav; + xpvav_allocated* xpvav; LOCK_SV_MUTEX; if (!PL_xpvav_root) S_more_xpvav(aTHX); xpvav = PL_xpvav_root; - PL_xpvav_root = (XPVAV*)xpvav->xav_array; + PL_xpvav_root = *(xpvav_allocated**)xpvav; UNLOCK_SV_MUTEX; - return xpvav; + return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill) + + STRUCT_OFFSET(xpvav_allocated, xav_fill)); } /* return a struct xpvav to the free list */ @@ -1616,9 +1523,12 @@ S_new_xpvav(pTHX) STATIC void S_del_xpvav(pTHX_ XPVAV *p) { + xpvav_allocated* xpvav + = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill) + - STRUCT_OFFSET(xpvav_allocated, xav_fill)); LOCK_SV_MUTEX; - p->xav_array = (char*)PL_xpvav_root; - PL_xpvav_root = p; + *(xpvav_allocated**)xpvav = PL_xpvav_root; + PL_xpvav_root = xpvav; UNLOCK_SV_MUTEX; } @@ -1627,14 +1537,15 @@ S_del_xpvav(pTHX_ XPVAV *p) STATIC XPVHV* S_new_xpvhv(pTHX) { - XPVHV* xpvhv; + xpvhv_allocated* xpvhv; LOCK_SV_MUTEX; if (!PL_xpvhv_root) S_more_xpvhv(aTHX); xpvhv = PL_xpvhv_root; - PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array; + PL_xpvhv_root = *(xpvhv_allocated**)xpvhv; UNLOCK_SV_MUTEX; - return xpvhv; + return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill) + + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)); } /* return a struct xpvhv to the free list */ @@ -1642,9 +1553,12 @@ S_new_xpvhv(pTHX) STATIC void S_del_xpvhv(pTHX_ XPVHV *p) { + xpvhv_allocated* xpvhv + = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill) + - STRUCT_OFFSET(xpvhv_allocated, xhv_fill)); LOCK_SV_MUTEX; - p->xhv_array = (char*)PL_xpvhv_root; - PL_xpvhv_root = p; + *(xpvhv_allocated**)xpvhv = PL_xpvhv_root; + PL_xpvhv_root = xpvhv; UNLOCK_SV_MUTEX; } @@ -1658,7 +1572,7 @@ S_new_xpvmg(pTHX) if (!PL_xpvmg_root) S_more_xpvmg(aTHX); xpvmg = PL_xpvmg_root; - PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv; + PL_xpvmg_root = *(XPVMG**)xpvmg; UNLOCK_SV_MUTEX; return xpvmg; } @@ -1669,7 +1583,7 @@ STATIC void S_del_xpvmg(pTHX_ XPVMG *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvmg_root; + *(XPVMG**)p = PL_xpvmg_root; PL_xpvmg_root = p; UNLOCK_SV_MUTEX; } @@ -1684,7 +1598,7 @@ S_new_xpvgv(pTHX) if (!PL_xpvgv_root) S_more_xpvgv(aTHX); xpvgv = PL_xpvgv_root; - PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv; + PL_xpvgv_root = *(XPVGV**)xpvgv; UNLOCK_SV_MUTEX; return xpvgv; } @@ -1695,7 +1609,7 @@ STATIC void S_del_xpvgv(pTHX_ XPVGV *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvgv_root; + *(XPVGV**)p = PL_xpvgv_root; PL_xpvgv_root = p; UNLOCK_SV_MUTEX; } @@ -1710,7 +1624,7 @@ S_new_xpvlv(pTHX) if (!PL_xpvlv_root) S_more_xpvlv(aTHX); xpvlv = PL_xpvlv_root; - PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv; + PL_xpvlv_root = *(XPVLV**)xpvlv; UNLOCK_SV_MUTEX; return xpvlv; } @@ -1721,7 +1635,7 @@ STATIC void S_del_xpvlv(pTHX_ XPVLV *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvlv_root; + *(XPVLV**)p = PL_xpvlv_root; PL_xpvlv_root = p; UNLOCK_SV_MUTEX; } @@ -1736,7 +1650,7 @@ S_new_xpvbm(pTHX) if (!PL_xpvbm_root) S_more_xpvbm(aTHX); xpvbm = PL_xpvbm_root; - PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv; + PL_xpvbm_root = *(XPVBM**)xpvbm; UNLOCK_SV_MUTEX; return xpvbm; } @@ -1747,7 +1661,7 @@ STATIC void S_del_xpvbm(pTHX_ XPVBM *p) { LOCK_SV_MUTEX; - p->xpv_pv = (char*)PL_xpvbm_root; + *(XPVBM**)p = PL_xpvbm_root; PL_xpvbm_root = p; UNLOCK_SV_MUTEX; } @@ -1757,15 +1671,9 @@ S_del_xpvbm(pTHX_ XPVBM *p) #ifdef PURIFY -#define new_XIV() my_safemalloc(sizeof(XPVIV)) -#define del_XIV(p) my_safefree(p) - #define new_XNV() my_safemalloc(sizeof(XPVNV)) #define del_XNV(p) my_safefree(p) -#define new_XRV() my_safemalloc(sizeof(XRV)) -#define del_XRV(p) my_safefree(p) - #define new_XPV() my_safemalloc(sizeof(XPV)) #define del_XPV(p) my_safefree(p) @@ -1798,15 +1706,9 @@ S_del_xpvbm(pTHX_ XPVBM *p) #else /* !PURIFY */ -#define new_XIV() (void*)new_xiv() -#define del_XIV(p) del_xiv((XPVIV*) p) - #define new_XNV() (void*)new_xnv() #define del_XNV(p) del_xnv((XPVNV*) p) -#define new_XRV() (void*)new_xrv() -#define del_XRV(p) del_xrv((XRV*) p) - #define new_XPV() (void*)new_xpv() #define del_XPV(p) del_xpv((XPV *)p) @@ -1887,7 +1789,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) break; case SVt_IV: iv = SvIVX(sv); - del_XIV(SvANY(sv)); if (mt == SVt_NV) mt = SVt_PVNV; else if (mt < SVt_PVIV) @@ -1901,10 +1802,9 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) break; case SVt_RV: pv = (char*)SvRV(sv); - del_XRV(SvANY(sv)); break; case SVt_PV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); del_XPV(SvANY(sv)); @@ -1914,14 +1814,14 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) mt = SVt_PVNV; break; case SVt_PVIV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); del_XPVIV(SvANY(sv)); break; case SVt_PVNV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); @@ -1937,7 +1837,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); @@ -1957,7 +1857,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) case SVt_NULL: Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: - SvANY(sv) = new_XIV(); + SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); SvIV_set(sv, iv); break; case SVt_NV: @@ -1965,19 +1865,14 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) SvNV_set(sv, nv); break; case SVt_RV: - SvANY(sv) = new_XRV(); + SvANY(sv) = &sv->sv_u.svu_rv; SvRV_set(sv, (SV*)pv); break; case SVt_PVHV: SvANY(sv) = new_XPVHV(); - HvRITER(sv) = 0; - HvEITER(sv) = 0; - HvPMROOT(sv) = 0; - HvNAME(sv) = 0; HvFILL(sv) = 0; HvMAX(sv) = 0; HvTOTALKEYS(sv) = 0; - HvPLACEHOLDERS(sv) = 0; /* Fall through... */ if (0) { @@ -1986,10 +1881,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) AvMAX(sv) = -1; AvFILLp(sv) = -1; AvALLOC(sv) = 0; - AvARYLEN(sv)= 0; - AvFLAGS(sv) = AVf_REAL; - SvIV_set(sv, 0); - SvNV_set(sv, 0.0); + AvREAL_only(sv); } /* to here. */ /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */ @@ -2093,8 +1985,10 @@ int Perl_sv_backoff(pTHX_ register SV *sv) { assert(SvOOK(sv)); + assert(SvTYPE(sv) != SVt_PVHV); + assert(SvTYPE(sv) != SVt_PVAV); if (SvIVX(sv)) { - char *s = SvPVX(sv); + const char *s = SvPVX_const(sv); SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); SvIV_set(sv, 0); @@ -2143,9 +2037,10 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) #endif } else - s = SvPVX(sv); + s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ + newlen = PERL_STRLEN_ROUNDUP(newlen); if (SvLEN(sv) && s) { #ifdef MYMALLOC const STRLEN l = malloced_size((void*)SvPVX(sv)); @@ -2154,12 +2049,12 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) return s; } else #endif - Renew(s,newlen,char); + s = saferealloc(s, newlen); } else { - New(703, s, newlen, char); - if (SvPVX(sv) && SvCUR(sv)) { - Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); + s = safemalloc(newlen); + if (SvPVX_const(sv) && SvCUR(sv)) { + Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); } } SvPV_set(sv, s); @@ -2353,8 +2248,9 @@ S_not_a_number(pTHX_ SV *sv) /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - char *s, *end; - for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { + const char *s, *end; + for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit; + s++) { int ch = *s & 0xFF; if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; @@ -2423,11 +2319,11 @@ Perl_looks_like_number(pTHX_ SV *sv) STRLEN len; if (SvPOK(sv)) { - sbegin = SvPVX(sv); + sbegin = SvPVX_const(sv); len = SvCUR(sv); } else if (SvPOKp(sv)) - sbegin = SvPV(sv, len); + sbegin = SvPV_const(sv, len); else return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); return grok_number(sbegin, len, NULL); @@ -2520,7 +2416,7 @@ Perl_looks_like_number(pTHX_ SV *sv) STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2710,7 +2606,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) } else if (SvPOKp(sv) && SvLEN(sv)) { UV value; - const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); /* We want to avoid a possible problem when we cache an IV which may be later translated to an NV, and the resulting NV is not the same as the direct translation of the initial string @@ -2777,7 +2673,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an (integer that doesn't overflow the UV). */ - SvNV_set(sv, Atof(SvPVX(sv))); + SvNV_set(sv, Atof(SvPVX_const(sv))); if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -3013,7 +2909,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) } else if (SvPOKp(sv) && SvLEN(sv)) { UV value; - const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); /* We want to avoid a possible problem when we cache a UV which may be later translated to an NV, and the resulting NV is not @@ -3076,7 +2972,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an integer, or it overflowed the UV. */ - SvNV_set(sv, Atof(SvPVX(sv))); + SvNV_set(sv, Atof(SvPVX_const(sv))); if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -3185,9 +3081,9 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && - !grok_number(SvPVX(sv), SvCUR(sv), NULL)) + !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) not_a_number(sv); - return Atof(SvPVX(sv)); + return Atof(SvPVX_const(sv)); } if (SvIOKp(sv)) { if (SvIsUV(sv)) @@ -3200,7 +3096,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(sv); } - return 0; + return (NV)0; } } if (SvTHINKFIRST(sv)) { @@ -3263,7 +3159,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else if (SvPOKp(sv) && SvLEN(sv)) { UV value; - const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype) not_a_number(sv); #ifdef NV_PRESERVES_UV @@ -3272,10 +3168,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) /* It's definitely an integer */ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else - SvNV_set(sv, Atof(SvPVX(sv))); + SvNV_set(sv, Atof(SvPVX_const(sv))); SvNOK_on(sv); #else - SvNV_set(sv, Atof(SvPVX(sv))); + SvNV_set(sv, Atof(SvPVX_const(sv))); /* Only set the public NV OK flag if this NV preserves the value in the PV at least as well as an IV/UV would. Not sure how to do this 100% reliably. */ @@ -3314,7 +3210,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) flags. NWC, 2000/11/25 */ /* Both already have p flags, so do nothing */ } else { - NV nv = SvNVX(sv); + const NV nv = SvNVX(sv); if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { SvNOK_on(sv); @@ -3330,7 +3226,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (numtype & IS_NUMBER_NOT_INT) { /* UV and NV both imprecise. */ } else { - UV nv_as_uv = U_V(nv); + const UV nv_as_uv = U_V(nv); if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); @@ -3380,7 +3276,7 @@ STATIC IV S_asIV(pTHX_ SV *sv) { UV value; - int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { @@ -3397,7 +3293,7 @@ S_asIV(pTHX_ SV *sv) if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - return I_V(Atof(SvPVX(sv))); + return I_V(Atof(SvPVX_const(sv))); } /* asUV(): extract an unsigned integer from the string value of an SV @@ -3407,7 +3303,7 @@ STATIC UV S_asUV(pTHX_ SV *sv) { UV value; - int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { @@ -3419,7 +3315,7 @@ S_asUV(pTHX_ SV *sv) if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - return U_V(Atof(SvPVX(sv))); + return U_V(Atof(SvPVX_const(sv))); } /* @@ -3433,8 +3329,7 @@ use the macro wrapper C instead. char * Perl_sv_2pv_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pv(sv, &n_a); + return sv_2pv(sv, 0); } /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or @@ -3501,14 +3396,20 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) char *tmpbuf = tbuf; if (!sv) { - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } if (SvGMAGICAL(sv)) { if (flags & SV_GMAGIC) mg_get(sv); if (SvPOKp(sv)) { - *lp = SvCUR(sv); + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); return SvPVX(sv); } if (SvIOKp(sv)) { @@ -3529,7 +3430,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(sv); } - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } } @@ -3539,7 +3441,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) register const char *typestr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - char *pv = SvPV(tmpstr, *lp); + char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); if (SvUTF8(tmpstr)) SvUTF8_on(sv); else @@ -3634,7 +3536,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvUTF8_on(origsv); else SvUTF8_off(origsv); - *lp = mg->mg_len; + if (lp) + *lp = mg->mg_len; return mg->mg_ptr; } /* Fall through */ @@ -3661,7 +3564,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) { - const char *name = HvNAME(SvSTASH(sv)); + const char *name = HvNAME_get(SvSTASH(sv)); Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", name ? name : "__ANON__" , typestr, PTR2UV(sv)); } @@ -3669,13 +3572,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv)); goto tokensaveref; } - *lp = strlen(typestr); + if (lp) + *lp = strlen(typestr); return (char *)typestr; } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } } @@ -3694,7 +3599,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) else ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */ - Move(ptr,SvPVX(sv),ebuf - ptr,char); + Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; @@ -3710,7 +3615,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ SvGROW(sv, NV_DIG + 20); - s = SvPVX(sv); + s = SvPVX_mutable(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) @@ -3735,17 +3640,26 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(sv); + if (lp) *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); return (char *)""; } - *lp = s - SvPVX(sv); - SvCUR_set(sv, *lp); + { + STRLEN len = s - SvPVX_const(sv); + if (lp) + *lp = len; + SvCUR_set(sv, len); + } SvPOK_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", - PTR2UV(sv),SvPVX(sv))); + PTR2UV(sv),SvPVX_const(sv))); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); return SvPVX(sv); tokensave: @@ -3756,7 +3670,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (!tsv) tsv = newSVpv(tmpbuf, 0); sv_2mortal(tsv); - *lp = SvCUR(tsv); + if (lp) + *lp = SvCUR(tsv); return SvPVX(tsv); } else { @@ -3766,7 +3681,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (tsv) { sv_2mortal(tsv); - t = SvPVX(tsv); + t = SvPVX_const(tsv); len = SvCUR(tsv); } else { @@ -3779,8 +3694,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) len = 1; } #endif - (void)SvUPGRADE(sv, SVt_PV); - *lp = len; + SvUPGRADE(sv, SVt_PV); + if (lp) + *lp = len; s = SvGROW(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); @@ -3806,8 +3722,8 @@ void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { STRLEN len; - char *s; - s = SvPV(ssv,len); + const char *s; + s = SvPV_const(ssv,len); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -3829,8 +3745,7 @@ Usually accessed via the C macro. char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pvbyte(sv, &n_a); + return sv_2pvbyte(sv, 0); } /* @@ -3866,8 +3781,7 @@ Usually accessed via the C macro. char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pvutf8(sv, &n_a); + return sv_2pvutf8(sv, 0); } /* @@ -3915,9 +3829,9 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvPOKp(sv)) { register XPV* Xpvtmp; if ((Xpvtmp = (XPV*)SvANY(sv)) && - (*Xpvtmp->xpv_pv > '0' || + (*sv->sv_u.svu_pv > '0' || Xpvtmp->xpv_cur > 1 || - (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0'))) + (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) return 1; else return 0; @@ -4365,9 +4279,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } } if (stype == SVt_PVLV) - (void)SvUPGRADE(dstr, SVt_PVNV); + SvUPGRADE(dstr, SVt_PVNV); else - (void)SvUPGRADE(dstr, (U32)stype); + SvUPGRADE(dstr, (U32)stype); } sflags = SvFLAGS(sstr); @@ -4453,7 +4367,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) CvCONST(cv) ? "Constant subroutine %s::%s redefined" : "Subroutine %s::%s redefined", - HvNAME(GvSTASH((GV*)dstr)), + HvNAME_get(GvSTASH((GV*)dstr)), GvENAME((GV*)dstr)); } } @@ -4505,7 +4419,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvTAINT(dstr); return; } - if (SvPVX(dstr)) { + if (SvPVX_const(dstr)) { SvPV_free(dstr); SvLEN_set(dstr, 0); SvCUR_set(dstr, 0); @@ -4539,8 +4453,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* * Check to see if we can just swipe the string. If so, it's a * possible small lose on short strings, but a big win on long ones. - * It might even be a win on short strings if SvPVX(dstr) - * has to be allocated and SvPVX(sstr) has to be freed. + * It might even be a win on short strings if SvPVX_const(dstr) + * has to be allocated and SvPVX_const(sstr) has to be freed. */ /* Whichever path we take through the next code, we want this true, @@ -4548,10 +4462,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvPOK_only(dstr); if ( -#ifdef PERL_COPY_ON_WRITE - (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) - && + /* We're not already COW */ + ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) +#ifndef PERL_COPY_ON_WRITE + /* or we are, but dstr isn't a suitable target. */ + || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS #endif + ) + && !(isSwipe = (sflags & SVs_TEMP) && /* slated for free anyway? */ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ @@ -4571,13 +4489,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Have to copy the string. */ STRLEN len = SvCUR(sstr); SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ - Move(SvPVX(sstr),SvPVX(dstr),len,char); + Move(SvPVX_const(sstr),SvPVX(dstr),len,char); SvCUR_set(dstr, len); *SvEND(dstr) = '\0'; } else { /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always be true in here. */ -#ifdef PERL_COPY_ON_WRITE /* Either it's a shared hash key, or it's suitable for copy-on-write or we can swipe the string. */ if (DEBUG_C_TEST) { @@ -4585,6 +4502,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_dump(sstr); sv_dump(dstr); } +#ifdef PERL_COPY_ON_WRITE if (!isSwipe) { /* I believe I should acquire a global SV mutex if it's a COW sv (not a shared hash key) to stop @@ -4603,34 +4521,38 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } #endif /* Initial code is common. */ - if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ + if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { SvFLAGS(dstr) &= ~SVf_OOK; - Safefree(SvPVX(dstr) - SvIVX(dstr)); + Safefree(SvPVX_const(dstr) - SvIVX(dstr)); } else if (SvLEN(dstr)) - Safefree(SvPVX(dstr)); + Safefree(SvPVX_const(dstr)); } -#ifdef PERL_COPY_ON_WRITE if (!isSwipe) { /* making another shared SV. */ STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); - assert (SvTYPE(dstr) >= SVt_PVIV); +#ifdef PERL_COPY_ON_WRITE if (len) { + assert (SvTYPE(dstr) >= SVt_PVIV); /* SvIsCOW_normal */ /* splice us in between source and next-after-source. */ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); SV_COW_NEXT_SV_SET(sstr, dstr); SvPV_set(dstr, SvPVX(sstr)); - } else { + } else +#endif + { /* SvIsCOW_shared_hash */ - UV hash = SvUVX(sstr); + UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); + + assert (SvTYPE(dstr) >= SVt_PVIV); SvPV_set(dstr, - sharepvn(SvPVX(sstr), + sharepvn(SvPVX_const(sstr), (sflags & SVf_UTF8?-cur:cur), hash)); SvUV_set(dstr, hash); } @@ -4641,7 +4563,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* Relesase a global SV mutex. */ } else -#endif { /* Passes the swipe test. */ SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); @@ -4753,12 +4674,12 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (dstr) { if (SvTHINKFIRST(dstr)) sv_force_normal_flags(dstr, SV_COW_DROP_PV); - else if (SvPVX(dstr)) - Safefree(SvPVX(dstr)); + else if (SvPVX_const(dstr)) + Safefree(SvPVX_const(dstr)); } else new_SV(dstr); - (void)SvUPGRADE (dstr, SVt_PVIV); + SvUPGRADE(dstr, SVt_PVIV); assert (SvPOK(sstr)); assert (SvPOKp(sstr)); @@ -4771,17 +4692,17 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (SvLEN(sstr) == 0) { /* source is a COW shared hash key. */ - UV hash = SvUVX(sstr); + UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); SvUV_set(dstr, hash); - new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash); + new_pv = sharepvn(SvPVX_const(sstr), (SvUTF8(sstr)?-cur:cur), hash); goto common_exit; } SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); } else { assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); - (void)SvUPGRADE (sstr, SVt_PVIV); + SvUPGRADE(sstr, SVt_PVIV); SvREADONLY_on(sstr); SvFAKE_on(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, @@ -4831,7 +4752,7 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN if (iv < 0) Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); } - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); dptr = SvPVX(sv); @@ -4877,7 +4798,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) return; } len = strlen(ptr); - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); @@ -4918,18 +4839,21 @@ See C. void Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { + STRLEN allocate; SV_CHECK_THINKFIRST_COW_DROP(sv); - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); return; } - if (SvPVX(sv)) + if (SvPVX_const(sv)) SvPV_free(sv); - Renew(ptr, len+1, char); + + allocate = PERL_STRLEN_ROUNDUP(len + 1); + ptr = saferealloc (ptr, allocate); SvPV_set(sv, ptr); SvCUR_set(sv, len); - SvLEN_set(sv, len+1); + SvLEN_set(sv, allocate); *SvEND(sv) = '\0'; (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); @@ -4957,7 +4881,7 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len (which it can do by means other than releasing copy-on-write Svs) or by changing the other copy-on-write SVs in the loop. */ STATIC void -S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len, +S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len, U32 hash, SV *after) { if (len) { /* this SV was SvIsCOW_normal(sv) */ @@ -4979,7 +4903,7 @@ S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len, /* don't loop forever if the structure is bust, and we have a pointer into a closed loop. */ assert (current != after); - assert (SvPVX(current) == pvx); + assert (SvPVX_const(current) == pvx); } /* Make the SV before us point to the SV after us. */ SV_COW_NEXT_SV_SET(current, after); @@ -5021,11 +4945,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) if (SvREADONLY(sv)) { /* At this point I believe I should acquire a global SV mutex. */ if (SvFAKE(sv)) { - char *pvx = SvPVX(sv); - STRLEN len = SvLEN(sv); - STRLEN cur = SvCUR(sv); - U32 hash = SvUVX(sv); - SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ + const char *pvx = SvPVX_const(sv); + const STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); + const U32 hash = SvSHARED_HASH(sv); + SV *const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", @@ -5058,16 +4982,16 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) #else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { - char *pvx = SvPVX(sv); - int is_utf8 = SvUTF8(sv); - STRLEN len = SvCUR(sv); - U32 hash = SvUVX(sv); + const char *pvx = SvPVX_const(sv); + const int is_utf8 = SvUTF8(sv); + const STRLEN len = SvCUR(sv); + const U32 hash = SvSHARED_HASH(sv); SvFAKE_off(sv); SvREADONLY_off(sv); - SvPV_set(sv, (char*)0); - SvLEN_set(sv, 0); + SvPV_set(sv, Nullch); + SvLEN_set(sv, 0); SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); + Move(pvx,SvPVX_const(sv),len,char); *SvEND(sv) = '\0'; unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash); } @@ -5104,7 +5028,7 @@ Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. Uses the "OOK hack". -Beware: after this function returns, C and SvPVX(sv) may no longer +Beware: after this function returns, C and SvPVX_const(sv) may no longer refer to the same chunk of data. =cut @@ -5116,17 +5040,17 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) register STRLEN delta; if (!ptr || !SvPOKp(sv)) return; - delta = ptr - SvPVX(sv); + delta = ptr - SvPVX_const(sv); SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ - const char *pvx = SvPVX(sv); + const char *pvx = SvPVX_const(sv); STRLEN len = SvCUR(sv); SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); + Move(pvx,SvPVX_const(sv),len,char); *SvEND(sv) = '\0'; } SvIV_set(sv, 0); @@ -5180,7 +5104,7 @@ Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register SvGROW(dsv, dlen + slen + 1); if (sstr == dstr) - sstr = SvPVX(dsv); + sstr = SvPVX_const(dsv); Move(sstr, SvPVX(dsv) + dlen, slen, char); SvCUR_set(dsv, SvCUR(dsv) + slen); *SvEND(dsv) = '\0'; @@ -5232,11 +5156,11 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { - char *spv; + const char *spv; STRLEN slen; if (!ssv) return; - if ((spv = SvPV(ssv, slen))) { + if ((spv = SvPV_const(ssv, slen))) { /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, gcc version 2.95.2 20000220 (Debian GNU/Linux) for Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously @@ -5244,7 +5168,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) dsv->sv_flags doesn't have that bit set. Andy Dougherty 12 Oct 2001 */ - I32 sutf8 = DO_UTF8(ssv); + const I32 sutf8 = DO_UTF8(ssv); I32 dutf8; if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) @@ -5303,7 +5227,7 @@ Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) len = strlen(ptr); SvGROW(sv, tlen + len + 1); if (ptr == junk) - ptr = SvPVX(sv); + ptr = SvPVX_const(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR_set(sv, SvCUR(sv) + len); (void)SvPOK_only_UTF8(sv); /* validate pointer */ @@ -5373,7 +5297,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, MAGIC* mg; if (SvTYPE(sv) < SVt_PVMG) { - (void)SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -5391,6 +5315,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || + how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || @@ -5562,6 +5487,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_vec: vtable = &PL_vtbl_vec; break; + case PERL_MAGIC_arylen_p: + case PERL_MAGIC_rhash: + case PERL_MAGIC_symtab: case PERL_MAGIC_vstring: vtable = 0; break; @@ -5763,7 +5691,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); - Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + Zero(SvPVX_const(bigstr)+curlen, offset+len-curlen, char); SvCUR_set(bigstr, offset+len); } @@ -5871,6 +5799,15 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) #else StructCopy(nsv,sv,SV); #endif + /* Currently could join these into one piece of pointer arithmetic, but + it would be unclear. */ + if(SvTYPE(sv) == SVt_IV) + SvANY(sv) + = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); + else if (SvTYPE(sv) == SVt_RV) { + SvANY(sv) = &sv->sv_u.svu_rv; + } + #ifdef PERL_COPY_ON_WRITE if (SvIsCOW_normal(nsv)) { @@ -5881,7 +5818,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) while ((next = SV_COW_NEXT_SV(current)) != nsv) { assert(next); current = next; - assert(SvPVX(current) == SvPVX(nsv)); + assert(SvPVX_const(current) == SvPVX_const(nsv)); } /* Make the SV before us point to the SV after us. */ if (DEBUG_C_TEST) { @@ -5925,11 +5862,8 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ dSP; - CV* destructor; - - - do { + CV* destructor; stash = SvSTASH(sv); destructor = StashHANDLER(stash,DESTROY); if (destructor) { @@ -5961,7 +5895,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvREFCNT(sv)) { if (PL_in_clean_objs) Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", - HvNAME(stash)); + HvNAME_get(stash)); /* DESTROY gave object new lease on life */ return; } @@ -6046,7 +5980,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(SvRV(sv)); } #ifdef PERL_COPY_ON_WRITE - else if (SvPVX(sv)) { + else if (SvPVX_const(sv)) { if (SvIsCOW(sv)) { /* I believe I need to grab the global SV mutex here and then recheck the COW status. */ @@ -6054,19 +5988,19 @@ Perl_sv_clear(pTHX_ register SV *sv) PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); } - sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv), + sv_release_COW(sv, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), SvUVX(sv), SV_COW_NEXT_SV(sv)); /* And drop it here. */ SvFAKE_off(sv); } else if (SvLEN(sv)) { - Safefree(SvPVX(sv)); + Safefree(SvPVX_const(sv)); } } #else - else if (SvPVX(sv) && SvLEN(sv)) - Safefree(SvPVX(sv)); - else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX(sv), + else if (SvPVX_const(sv) && SvLEN(sv)) + Safefree(SvPVX_const(sv)); + else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + unsharepvn(SvPVX_const(sv), SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv), SvUVX(sv)); SvFAKE_off(sv); @@ -6085,13 +6019,11 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_NULL: break; case SVt_IV: - del_XIV(SvANY(sv)); break; case SVt_NV: del_XNV(SvANY(sv)); break; case SVt_RV: - del_XRV(SvANY(sv)); break; case SVt_PV: del_XPV(SvANY(sv)); @@ -6240,7 +6172,7 @@ Perl_sv_len(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) len = mg_length(sv); else - (void)SvPV(sv, len); + (void)SvPV_const(sv, len); return len; } @@ -6271,7 +6203,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) else { STRLEN len, ulen; - const U8 *s = (U8*)SvPV(sv, len); + const U8 *s = (U8*)SvPV_const(sv, len); MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0; if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) { @@ -6305,7 +6237,8 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) * */ STATIC bool -S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start) +S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, + I32 offsetp, const U8 *s, const U8 *start) { bool found = FALSE; @@ -6338,7 +6271,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offset * */ STATIC bool -S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send) +S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send) { bool found = FALSE; @@ -6470,21 +6403,21 @@ type coercion. void Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { - U8 *start; - U8 *s; + const U8 *start; STRLEN len; - STRLEN *cache = 0; - STRLEN boffset = 0; if (!sv) return; - start = s = (U8*)SvPV(sv, len); + start = (U8*)SvPV_const(sv, len); if (len) { - I32 uoffset = *offsetp; - U8 *send = s + len; - MAGIC *mg = 0; - bool found = FALSE; + STRLEN boffset = 0; + STRLEN *cache = 0; + const U8 *s = start; + I32 uoffset = *offsetp; + const U8 *send = s + len; + MAGIC *mg = 0; + bool found = FALSE; if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send)) found = TRUE; @@ -6546,17 +6479,17 @@ Handles magic and type coercion. void Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) { - U8* s; + const U8* s; STRLEN len; if (!sv) return; - s = (U8*)SvPV(sv, len); + s = (const U8*)SvPV_const(sv, len); if ((I32)len < *offsetp) Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); else { - U8* send = s + *offsetp; + const U8* send = s + *offsetp; MAGIC* mg = NULL; STRLEN *cache = NULL; @@ -6588,7 +6521,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) STRLEN backw = cache[1] - *offsetp; if (!(forw < 2 * backw)) { - U8 *p = s + cache[1]; + const U8 *p = s + cache[1]; STRLEN ubackw = 0; cache[1] -= backw; @@ -6682,14 +6615,14 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) cur1 = 0; } else - pv1 = SvPV(sv1, cur1); + pv1 = SvPV_const(sv1, cur1); if (!sv2){ pv2 = ""; cur2 = 0; } else - pv2 = SvPV(sv2, cur2); + pv2 = SvPV_const(sv2, cur2); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. @@ -6775,14 +6708,14 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) cur1 = 0; } else - pv1 = SvPV(sv1, cur1); + pv1 = SvPV_const(sv1, cur1); if (!sv2) { pv2 = ""; cur2 = 0; } else - pv2 = SvPV(sv2, cur2); + pv2 = SvPV_const(sv2, cur2); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. @@ -6982,7 +6915,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) However, perlbench says it's slower, because the existing swipe code is faster than copy on write. Swings and roundabouts. */ - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); @@ -7137,7 +7070,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) } else shortbuffered = 0; - bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ + bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); @@ -7166,10 +7099,10 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) if (shortbuffered) { /* oh well, must extend */ cnt = shortbuffered; shortbuffered = 0; - bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ SvCUR_set(sv, bpx); SvGROW(sv, SvLEN(sv) + append + cnt + 2); - bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ continue; } @@ -7201,10 +7134,10 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; - bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ SvCUR_set(sv, bpx); SvGROW(sv, bpx + cnt + 2); - bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ @@ -7213,7 +7146,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) } thats_all_folks: - if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) || + if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || memNE((char*)bp - rslen, rsptr, rslen)) goto screamer; /* go back to the fray */ thats_really_all_folks: @@ -7227,10 +7160,10 @@ thats_really_all_folks: PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; - SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ + SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: done, len=%ld, string=|%.*s|\n", - (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); } else { @@ -7272,7 +7205,7 @@ screamer2: if (i != EOF && /* joy */ (!rslen || SvCUR(sv) < rslen || - memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; /* @@ -7378,7 +7311,7 @@ Perl_sv_inc(pTHX_ register SV *sv) return; } - if (!(flags & SVp_POK) || !*SvPVX(sv)) { + if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { if ((flags & SVTYPEMASK) < SVt_PVIV) sv_upgrade(sv, SVt_IV); (void)SvIOK_only(sv); @@ -7393,7 +7326,7 @@ Perl_sv_inc(pTHX_ register SV *sv) /* Got to punt this as an integer if needs be, but we don't issue warnings. Probably ought to make the sv_iv_please() that does the conversion if possible, and silently. */ - int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); if (numtype && !(numtype & IS_NUMBER_INFINITY)) { /* Need to try really hard to see if it's an integer. 9.22337203685478e+18 is an integer. @@ -7417,18 +7350,18 @@ Perl_sv_inc(pTHX_ register SV *sv) Fall through. */ #if defined(USE_LONG_DOUBLE) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX(sv), SvIVX(sv), SvNVX(sv))); + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", - SvPVX(sv), SvIVX(sv), SvNVX(sv))); + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); #endif } #endif /* PERL_PRESERVE_IVUV */ - sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); + sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); return; } d--; - while (d >= SvPVX(sv)) { + while (d >= SvPVX_const(sv)) { if (isDIGIT(*d)) { if (++*d <= '9') return; @@ -7458,7 +7391,7 @@ Perl_sv_inc(pTHX_ register SV *sv) /* oh,oh, the number grew */ SvGROW(sv, SvCUR(sv) + 2); SvCUR_set(sv, SvCUR(sv) + 1); - for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--) + for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) *d = d[-1]; if (isDIGIT(d[1])) *d = '1'; @@ -7541,7 +7474,7 @@ Perl_sv_dec(pTHX_ register SV *sv) } #ifdef PERL_PRESERVE_IVUV { - int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); if (numtype && !(numtype & IS_NUMBER_INFINITY)) { /* Need to try really hard to see if it's an integer. 9.22337203685478e+18 is an integer. @@ -7565,15 +7498,15 @@ Perl_sv_dec(pTHX_ register SV *sv) Fall through. */ #if defined(USE_LONG_DOUBLE) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX(sv), SvIVX(sv), SvNVX(sv))); + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", - SvPVX(sv), SvIVX(sv), SvNVX(sv))); + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); #endif } } #endif /* PERL_PRESERVE_IVUV */ - sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ + sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ } /* @@ -7670,9 +7603,7 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) register SV *sv; new_SV(sv); - if (!len) - len = strlen(s); - sv_setpvn(sv,s,len); + sv_setpvn(sv,s,len ? len : strlen(s)); return sv; } @@ -7697,15 +7628,70 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } + +/* +=for apidoc newSVhek + +Creates a new SV from the hash key structure. It will generate scalars that +point to the shared string table where possible. Returns a new (undefined) +SV if the hek is NULL. + +=cut +*/ + +SV * +Perl_newSVhek(pTHX_ const HEK *hek) +{ + if (!hek) { + SV *sv; + + new_SV(sv); + return sv; + } + + if (HEK_LEN(hek) == HEf_SVKEY) { + return newSVsv(*(SV**)HEK_KEY(hek)); + } else { + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + /* Trouble :-) + Andreas would like keys he put in as utf8 to come back as utf8 + */ + STRLEN utf8_len = HEK_LEN(hek); + U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + SV *sv = newSVpvn ((char*)as_utf8, utf8_len); + + SvUTF8_on (sv); + Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ + return sv; + } else if (flags & HVhek_REHASH) { + /* We don't have a pointer to the hv, so we have to replicate the + flag into every HEK. This hv is using custom a hasing + algorithm. Hence we can't return a shared string scalar, as + that would contain the (wrong) hash value, and might get passed + into an hv routine with a regular hash */ + + SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on (sv); + return sv; + } + /* This will be overwhelminly the most common case. */ + return newSVpvn_share(HEK_KEY(hek), + (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), + HEK_HASH(hek)); + } +} + /* =for apidoc newSVpvn_share -Creates a new SV with its SvPVX pointing to a shared string in the string +Creates a new SV with its SvPVX_const pointing to a shared string in the string table. If the string does not already exist in the table, it is created first. Turns on READONLY and FAKE. The string's hash is stored in the UV slot of the SV; if the C parameter is non-zero, that value is used; otherwise the hash is computed. The idea here is that as the string table -is used for shared hash keys these strings will have SvPVX == HeKEY and +is used for shared hash keys these strings will have SvPVX_const == HeKEY and hash lookup will avoid string compare. =cut @@ -7922,20 +7908,19 @@ void Perl_sv_reset(pTHX_ register const char *s, HV *stash) { dVAR; - register HE *entry; - register GV *gv; - register SV *sv; - register I32 i; - register PMOP *pm; - register I32 max; char todo[PERL_UCHAR_MAX+1]; if (!stash) return; if (!*s) { /* reset ?? searches */ - for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmdynflags &= ~PMdf_USED; + MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab); + if (mg) { + PMOP *pm = (PMOP *) mg->mg_obj; + while (pm) { + pm->op_pmdynflags &= ~PMdf_USED; + pm = pm->op_pmnext; + } } return; } @@ -7947,7 +7932,8 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) Zero(todo, 256, char); while (*s) { - i = (unsigned char)*s; + I32 max; + I32 i = (unsigned char)*s; if (s[1] == '-') { s += 2; } @@ -7956,10 +7942,14 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) todo[i] = 1; } for (i = 0; i <= (I32) HvMAX(stash); i++) { + HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + register GV *gv; + register SV *sv; + if (!todo[(U8)*HeKEY(entry)]) continue; gv = (GV*)HeVAL(entry); @@ -7972,14 +7962,14 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); - if (SvPVX(sv) != Nullch) + if (SvPVX_const(sv) != Nullch) *SvPVX(sv) = '\0'; SvTAINT(sv); } if (GvAV(gv)) { av_clear(GvAV(gv)); } - if (GvHV(gv) && !HvNAME(GvHV(gv))) { + if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef PERL_MICRO #ifdef USE_ENVIRON_ARRAY @@ -8143,7 +8133,7 @@ Perl_sv_true(pTHX_ register SV *sv) const register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && (tXpv->xpv_cur > 1 || - (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) + (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) return 1; else return 0; @@ -8307,20 +8297,29 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) } else { char *s; + + if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { + if (PL_op) + Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", + sv_reftype(sv,0), OP_NAME(PL_op)); + else + Perl_croak(aTHX_ "Can't coerce readonly %s to string", + sv_reftype(sv,0)); + } if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); } else s = sv_2pv_flags(sv, lp, flags); - if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ + if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ const STRLEN len = *lp; if (SvROK(sv)) sv_unref(sv); - (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */ + SvUPGRADE(sv, SVt_PV); /* Never FALSE */ SvGROW(sv, len + 1); - Move(s,SvPVX(sv),len,char); + Move(s,SvPVX_const(sv),len,char); SvCUR_set(sv, len); *SvEND(sv) = '\0'; } @@ -8328,10 +8327,10 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", - PTR2UV(sv),SvPVX(sv))); + PTR2UV(sv),SvPVX_const(sv))); } } - return SvPVX(sv); + return SvPVX_mutable(sv); } /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); @@ -8450,7 +8449,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) /* The fact that I don't need to downcast to char * everywhere, only in ?: inside return suggests a const propagation bug in g++. */ if (ob && SvOBJECT(sv)) { - char *name = HvNAME(SvSTASH(sv)); + char *name = HvNAME_get(SvSTASH(sv)); return name ? name : (char *) "__ANON__"; } else { @@ -8525,6 +8524,7 @@ an inheritance relationship. int Perl_sv_isa(pTHX_ SV *sv, const char *name) { + const char *hvname; if (!sv) return 0; if (SvGMAGICAL(sv)) @@ -8534,10 +8534,11 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) sv = (SV*)SvRV(sv); if (!SvOBJECT(sv)) return 0; - if (!HvNAME(SvSTASH(sv))) + hvname = HvNAME_get(SvSTASH(sv)); + if (!hvname) return 0; - return strEQ(HvNAME(SvSTASH(sv)), name); + return strEQ(hvname, name); } /* @@ -8726,7 +8727,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) SvOBJECT_on(tmpRef); if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; - (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash)); if (Gv_AMG(stash)) @@ -9159,11 +9160,11 @@ F0convert(NV nv, char *endbuf, STRLEN *len) { const int neg = nv < 0; UV uv; - char *p = endbuf; if (neg) nv = -nv; if (nv < UV_MAX) { + char *p = endbuf; nv += 0.5; uv = (UV)nv; if (uv & 1 && uv == nv) @@ -9207,8 +9208,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV I32 svix = 0; static const char nullstr[] = "(null)"; SV *argsv = Nullsv; - bool has_utf8; /* has the result utf8? */ - bool pat_utf8; /* the pattern is in utf8? */ + bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ + const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ SV *nsv = Nullsv; /* Times 4: a decimal digit takes more than 3 binary digits. * NV_DIG: mantissa takes than many decimal digits. @@ -9217,17 +9218,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ - has_utf8 = pat_utf8 = DO_UTF8(sv); - /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); - /* special-case "", "%s", and "%_" */ + /* special-case "", "%s", and "%-p" (SVf) */ if (patlen == 0) return; - if (patlen == 2 && pat[0] == '%') { - switch (pat[1]) { - case 's': + if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { if (args) { const char *s = va_arg(*args, char*); sv_catpv(sv, s ? s : nullstr); @@ -9238,7 +9235,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SvUTF8_on(sv); } return; - case '_': + } + if (patlen == 3 && pat[0] == '%' && + pat[1] == '-' && pat[2] == 'p') { if (args) { argsv = va_arg(*args, SV*); sv_catsv(sv, argsv); @@ -9246,9 +9245,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SvUTF8_on(sv); return; } - /* See comment on '_' below */ - break; - } } #ifndef USE_LONG_DOUBLE @@ -9322,10 +9318,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV U8 utf8buf[UTF8_MAXBYTES+1]; STRLEN esignlen = 0; - char *eptr = Nullch; + const char *eptr = Nullch; STRLEN elen = 0; SV *vecsv = Nullsv; - U8 *vecstr = Null(U8*); + const U8 *vecstr = Null(U8*); STRLEN veclen = 0; char c = 0; int i; @@ -9445,27 +9441,27 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else vecsv = (evix ? evix <= svmax : svix < svmax) ? svargs[evix ? evix-1 : svix++] : &PL_sv_undef; - dotstr = SvPVx(vecsv, dotstrlen); + dotstr = SvPV_const(vecsv, dotstrlen); if (DO_UTF8(vecsv)) is_utf8 = TRUE; } if (args) { vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPVx(vecsv,veclen); + vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; - vecstr = (U8*)SvPVx(vecsv,veclen); + vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); /* if this is a version object, we need to return the - * stringified representation (which the SvPVX has + * stringified representation (which the SvPVX_const has * already done for us), but not vectorize the args */ if ( *q == 'd' && sv_derived_from(vecsv,"version") ) { q++; /* skip past the rest of the %vd format */ - eptr = (char *) vecstr; + eptr = (const char *) vecstr; elen = strlen(eptr); vectorize=FALSE; goto string; @@ -9613,7 +9609,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - eptr = SvPVx(argsv, elen); + eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { I32 p = precis; @@ -9626,23 +9622,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV is_utf8 = TRUE; } } - goto string; - - case '_': -#ifdef CHECK_FORMAT - format_sv: -#endif - /* - * The "%_" hack might have to be changed someday, - * if ISO or ANSI decide to use '_' for something. - * So we keep it hidden from users' code. - */ - if (!args || vectorize) - goto unknown; - argsv = va_arg(*args, SV*); - eptr = SvPVx(argsv, elen); - if (DO_UTF8(argsv)) - is_utf8 = TRUE; string: vectorize = FALSE; @@ -9653,17 +9632,21 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': -#ifdef CHECK_FORMAT - if (left) { + if (left && args) { /* SVf */ left = FALSE; - if (!width) - goto format_sv; /* %-p -> %_ */ - precis = width; - has_precis = TRUE; - width = 0; - goto format_sv; /* %-Np -> %.N_ */ + if (width) { + precis = width; + has_precis = TRUE; + width = 0; + } + if (vectorize) + goto unknown; + argsv = va_arg(*args, SV*); + eptr = SvPVx_const(argsv, elen); + if (DO_UTF8(argsv)) + is_utf8 = TRUE; + goto string; } -#endif if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -9804,54 +9787,57 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } integer: - eptr = ebuf + sizeof ebuf; - switch (base) { - unsigned dig; - case 16: - if (!uv) - alt = FALSE; - p = (char*)((c == 'X') - ? "0123456789ABCDEF" : "0123456789abcdef"); - do { - dig = uv & 15; - *--eptr = p[dig]; - } while (uv >>= 4); - if (alt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'x' or 'X' */ + { + char *ptr = ebuf + sizeof ebuf; + switch (base) { + unsigned dig; + case 16: + if (!uv) + alt = FALSE; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); + do { + dig = uv & 15; + *--ptr = p[dig]; + } while (uv >>= 4); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'x' or 'X' */ + } + break; + case 8: + do { + dig = uv & 7; + *--ptr = '0' + dig; + } while (uv >>= 3); + if (alt && *ptr != '0') + *--ptr = '0'; + break; + case 2: + do { + dig = uv & 1; + *--ptr = '0' + dig; + } while (uv >>= 1); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = 'b'; + } + break; + default: /* it had better be ten or less */ + do { + dig = uv % base; + *--ptr = '0' + dig; + } while (uv /= base); + break; } - break; - case 8: - do { - dig = uv & 7; - *--eptr = '0' + dig; - } while (uv >>= 3); - if (alt && *eptr != '0') - *--eptr = '0'; - break; - case 2: - do { - dig = uv & 1; - *--eptr = '0' + dig; - } while (uv >>= 1); - if (alt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = 'b'; + elen = (ebuf + sizeof ebuf) - ptr; + eptr = ptr; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; } - break; - default: /* it had better be ten or less */ - do { - dig = uv % base; - *--eptr = '0' + dig; - } while (uv /= base); - break; - } - elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis) { - if (precis > elen) - zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') - elen = 0; } break; @@ -10009,50 +9995,52 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV break; } } - eptr = ebuf + sizeof ebuf; - *--eptr = '\0'; - *--eptr = c; - /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ + { + char *ptr = ebuf + sizeof ebuf; + *--ptr = '\0'; + *--ptr = c; + /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) - if (intsize == 'q') { - /* 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--; } - } + if (intsize == 'q') { + /* 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) { *--ptr = *p--; } + } #endif - if (has_precis) { - base = precis; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - *--eptr = '.'; - } - if (width) { - base = width; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - } - if (fill == '0') - *--eptr = fill; - if (left) - *--eptr = '-'; - if (plus) - *--eptr = plus; - if (alt) - *--eptr = '#'; - *--eptr = '%'; - - /* No taint. Otherwise we are in the strange situation - * where printf() taints but print($float) doesn't. - * --jhi */ + if (has_precis) { + base = precis; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + *--ptr = '.'; + } + if (width) { + base = width; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + } + if (fill == '0') + *--ptr = fill; + if (left) + *--ptr = '-'; + if (plus) + *--ptr = plus; + if (alt) + *--ptr = '#'; + *--ptr = '%'; + + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ #if defined(HAS_LONG_DOUBLE) - if (intsize == 'q') - (void)sprintf(PL_efloatbuf, eptr, nv); - else - (void)sprintf(PL_efloatbuf, eptr, (double)nv); + if (intsize == 'q') + (void)sprintf(PL_efloatbuf, ptr, nv); + else + (void)sprintf(PL_efloatbuf, ptr, (double)nv); #else - (void)sprintf(PL_efloatbuf, eptr, nv); + (void)sprintf(PL_efloatbuf, ptr, nv); #endif + } float_converted: eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); @@ -10112,7 +10100,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV Copy(eptr, p, elen, char); p += elen; *p = '\0'; - SvCUR_set(sv, p - SvPVX(sv)); + SvCUR_set(sv, p - SvPVX_const(sv)); svix = osvix; continue; /* not "break" */ } @@ -10178,7 +10166,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (has_utf8) SvUTF8_on(sv); *p = '\0'; - SvCUR_set(sv, p - SvPVX(sv)); + SvCUR_set(sv, p - SvPVX_const(sv)); if (vectorize) { esignlen = 0; goto vector; @@ -10446,6 +10434,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param)); } } + else if (mg->mg_type == PERL_MAGIC_symtab) { + nmg->mg_obj = mg->mg_obj; + } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) ? sv_dup_inc(mg->mg_obj, param) @@ -10685,7 +10676,7 @@ S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) if (!GvUNIQUE(gv)) { #if 0 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n", - HvNAME(GvSTASH(gv)), GvNAME(gv)); + HvNAME_get(GvSTASH(gv)), GvNAME(gv)); #endif return Nullsv; } @@ -10729,11 +10720,11 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) : sv_dup_inc(SvRV(sstr), param)); } - else if (SvPVX(sstr)) { + else if (SvPVX_const(sstr)) { /* Has something there */ if (SvLEN(sstr)) { /* Normal PV - clone whole allocated space */ - SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1)); + SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); if (SvREADONLY(sstr) && SvFAKE(sstr)) { /* Not that normal - actually sstr is copy on write. But we are a true, independant SV, so: */ @@ -10750,12 +10741,12 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) and they should not have these flags turned off */ - SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr), + SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr), SvUVX(sstr))); SvUV_set(dstr, SvUVX(sstr)); } else { - SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr))); + SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr))); SvFAKE_off(dstr); SvREADONLY_off(dstr); } @@ -10791,11 +10782,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if(param->flags & CLONEf_JOIN_IN) { /** We are joining here so we don't want do clone something that is bad **/ + const char *hvname; if(SvTYPE(sstr) == SVt_PVHV && - HvNAME(sstr)) { + (hvname = HvNAME_get(sstr))) { /** don't clone stashes if they already exist **/ - HV* old_stash = gv_stashpv(HvNAME(sstr),0); + HV* old_stash = gv_stashpv(hvname,0); return (SV*) old_stash; } } @@ -10823,9 +10815,9 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvREFCNT(dstr) = 0; /* must be before any other dups! */ #ifdef DEBUGGING - if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx) + if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - PL_watch_pvx, SvPVX(sstr)); + PL_watch_pvx, SvPVX_const(sstr)); #endif /* don't clone objects whose class has asked us not to */ @@ -10840,7 +10832,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = NULL; break; case SVt_IV: - SvANY(dstr) = new_XIV(); + SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); SvIV_set(dstr, SvIVX(sstr)); break; case SVt_NV: @@ -10848,7 +10840,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNV_set(dstr, SvNVX(sstr)); break; case SVt_RV: - SvANY(dstr) = new_XRV(); + SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PV: @@ -10923,7 +10915,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) ptr_table_store(PL_ptr_table, sstr, dstr); #if 0 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", - HvNAME(GvSTASH(share)), GvNAME(share)); + HvNAME_get(GvSTASH(share)), GvNAME(share)); #endif break; } @@ -10989,12 +10981,8 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = new_XPVAV(); SvCUR_set(dstr, SvCUR(sstr)); SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param); - AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); if (AvARRAY((AV*)sstr)) { SV **dst_ary, **src_ary; SSize_t items = AvFILLp((AV*)sstr) + 1; @@ -11026,35 +11014,51 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = new_XPVHV(); SvCUR_set(dstr, SvCUR(sstr)); SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); + HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr); SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - HvRITER((HV*)dstr) = HvRITER((HV*)sstr); - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - XPVHV *dxhv = (XPVHV*)SvANY(dstr); - XPVHV *sxhv = (XPVHV*)SvANY(sstr); - Newz(0, dxhv->xhv_array, - PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); - while (i <= sxhv->xhv_max) { - ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], - (bool)!!HvSHAREKEYS(sstr), - param); - ++i; + { + HEK *hvname = 0; + + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(sstr); + XPVHV * const dxhv = (XPVHV*)SvANY(dstr); + XPVHV * const sxhv = (XPVHV*)SvANY(sstr); + char *darray; + New(0, darray, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char); + HvARRAY(dstr) = (HE**)darray; + while (i <= sxhv->xhv_max) { + HE *source = HvARRAY(sstr)[i]; + HvARRAY(dstr)[i] + = source ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(sstr)) { + struct xpvhv_aux *saux = HvAUX(sstr); + struct xpvhv_aux *daux = HvAUX(dstr); + /* This flag isn't copied. */ + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(dstr) |= SVf_OOK; + + hvname = saux->xhv_name; + daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; + + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), + param) : 0; + } } - dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param); - } - else { - SvPV_set(dstr, Nullch); - HvEITER((HV*)dstr) = (HE*)NULL; + else { + SvPV_set(dstr, Nullch); + } + /* Record stashes for possible cloning in Perl_clone(). */ + if(hvname) + av_push(param->stashes, dstr); } - HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ - HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); - /* Record stashes for possible cloning in Perl_clone(). */ - if(HvNAME((HV*)dstr)) - av_push(param->stashes, dstr); break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); @@ -11298,16 +11302,18 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) long longval; GP *gp; IV iv; - I32 i; char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHX_ void*); OP *o; + /* Unions for circumventing strict ANSI C89 casting rules. */ + union { void *vptr; void (*dptr)(void*); } u1, u2; + union { void *vptr; void (*dxptr)(pTHX_ void*); } u3, u4; Newz(54, nss, max, ANY); while (ix > 0) { - i = POPINT(ss,ix); + I32 i = POPINT(ss,ix); TOPINT(nss,ix) = i; switch (i) { case SAVEt_ITEM: /* normal string */ @@ -11474,13 +11480,17 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dptr = POPDPTR(ss,ix); - TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl); + u1.dptr = dptr; + u2.vptr = any_dup(u1.vptr, proto_perl); + TOPDPTR(nss,ix) = u2.dptr; break; case SAVEt_DESTRUCTOR_X: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dxptr = POPDXPTR(ss,ix); - TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl); + u3.dxptr = dxptr; + u4.vptr = any_dup(u3.vptr, proto_perl);; + TOPDXPTR(nss,ix) = u4.dxptr; break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: @@ -11558,7 +11568,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) static void do_mark_cloneable_stash(pTHX_ SV *sv) { - if (HvNAME((HV*)sv)) { + const HEK *hvname = HvNAME_HEK((HV*)sv); + if (hvname) { GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { @@ -11568,7 +11579,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0))); + XPUSHs(sv_2mortal(newSVhek(hvname))); PUTBACK; call_sv((SV*)GvCV(cloner), G_SCALAR); SPAGAIN; @@ -11723,12 +11734,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->proto_perl = proto_perl; /* 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; @@ -11764,6 +11771,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_debug = proto_perl->Idebug; + PL_hash_seed = proto_perl->Ihash_seed; + PL_rehash_seed = proto_perl->Irehash_seed; + #ifdef USE_REENTRANT_API /* XXX: things like -Dm will segfault here in perlio, but doing * PERL_SET_CONTEXT(proto_perl); @@ -11774,6 +11784,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* create SV map for pointer relocation */ PL_ptr_table = ptr_table_new(); + /* and one for finding shared hash keys quickly */ + PL_shared_hek_table = ptr_table_new(); /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; @@ -11806,7 +11818,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* create (a non-shared!) shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); - hv_ksplit(PL_strtab, 512); + hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); PL_compiling = proto_perl->Icompiling; @@ -11887,6 +11899,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, { const I32 len = av_len((AV*)proto_perl->Iregex_padav); SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav); + IV i; av_push(PL_regex_padav, sv_dup_inc(regexen[0],param)); for(i = 1; i <= len; i++) { @@ -12071,13 +12084,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, */ if (SvANY(proto_perl->Ilinestr)) { PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); } else { @@ -12103,9 +12116,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ if (SvANY(proto_perl->Ilinestr)) { - i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); + i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_last_lop_op = proto_perl->Ilast_lop_op; } @@ -12204,8 +12217,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_hash_seed = proto_perl->Ihash_seed; - PL_rehash_seed = proto_perl->Irehash_seed; PL_uudmap['M'] = 0; /* reinits on demand */ PL_bitcount = Nullch; /* reinits on demand */ @@ -12404,6 +12415,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; + ptr_table_free(PL_shared_hek_table); + PL_shared_hek_table = NULL; } /* Call the ->CLONE method, if it exists, for each of the stashes @@ -12417,7 +12430,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); + XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -12488,9 +12501,9 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) uni = POPs; PUTBACK; s = SvPV(uni, len); - if (s != SvPVX(sv)) { + if (s != SvPVX_const(sv)) { SvGROW(sv, len + 1); - Move(s, SvPVX(sv), len, char); + Move(s, SvPVX_const(sv), len, char); SvCUR_set(sv, len); SvPVX(sv)[len] = 0; }