X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=19cb7b34e5cb14c88dd1b2ad87670af47be67b19;hb=ca563b4e7524b82fcbffcbe3344a4a9d20a7ab64;hp=5089825a52ebfa2bfae0601c6cbb7864802c13b1;hpb=30e5c352c9c1099120007e8b6e9318a33d99b3bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 5089825..19cb7b3 100644 --- a/sv.c +++ b/sv.c @@ -188,11 +188,7 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) } #ifdef DEBUG_LEAKING_SCALARS -# ifdef NETWARE -# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file) -# else -# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file) -# endif +# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) #else # define FREE_SV_DEBUG_FILE(sv) #endif @@ -260,11 +256,7 @@ S_new_SV(pTHX) (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; -# ifdef NETWARE sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; -# else - sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; -# endif return sv; } @@ -437,18 +429,19 @@ Perl_sv_report_used(pTHX) static void do_clean_objs(pTHX_ SV *ref) { - SV* target; - - if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); - if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - } else { - SvROK_off(ref); - SvRV_set(ref, NULL); - SvREFCNT_dec(target); + if (SvROK(ref)) { + SV * const target = SvRV(ref); + if (SvOBJECT(target)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + } else { + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec(target); + } } } @@ -682,30 +675,22 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, SV * const name = sv_newmortal(); if (gv) { + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; - /* simulate gv_fullname4(), but add literal '^' for $^FOO names - * XXX get rid of all this if gv_fullnameX() ever supports this - * directly */ - - const char *p; - HV * const hv = GvSTASH(gv); - if (!hv) - p = "???"; - else if (!(p=HvNAME_get(hv))) - p = "__ANON__"; - if (strEQ(p, "main")) - sv_setpvn(name, &gvtype, 1); - else - Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p); + /* as gv_fullname4(), but add literal '^' for $^FOO names */ + + gv_fullname4(name, gv, buffer, 0); + + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; - if (GvNAMELEN(gv)>= 1 && - ((unsigned int)*GvNAME(gv)) <= 26) - { /* handle $^FOO */ - Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1); - sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1); + /* Swap the 1 unprintable control character for the 2 byte pretty + version - ie substr($name, 1, 1) = $buffer; */ + sv_insert(name, 1, 1, buffer, 2); } - else - sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv)); } else { U32 unused; @@ -1860,7 +1845,7 @@ S_not_a_number(pTHX_ SV *sv) pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; - char *limit = tmpbuf + sizeof(tmpbuf) - 8; + const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ @@ -2076,16 +2061,6 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) } #endif /* !NV_PRESERVES_UV*/ -/* sv_2iv() is now a macro using Perl_sv_2iv_flags(); - * this function provided for binary compatibility only - */ - -IV -Perl_sv_2iv(pTHX_ register SV *sv) -{ - return sv_2iv_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_2iv_flags @@ -2121,11 +2096,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvIV(tmpstr); - return PTR2IV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV * const tmpstr=AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2385,16 +2362,6 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } -/* sv_2uv() is now a macro using Perl_sv_2uv_flags(); - * this function provided for binary compatibility only - */ - -UV -Perl_sv_2uv(pTHX_ register SV *sv) -{ - return sv_2uv_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_2uv_flags @@ -2934,20 +2901,6 @@ S_asUV(pTHX_ SV *sv) return U_V(Atof(SvPVX_const(sv))); } -/* -=for apidoc sv_2pv_nolen - -Like C, but doesn't return the length too. You should usually -use the macro wrapper C instead. -=cut -*/ - -char * -Perl_sv_2pv_nolen(pTHX_ register SV *sv) -{ - return sv_2pv(sv, 0); -} - /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. @@ -2959,7 +2912,7 @@ static char * S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) { char *ptr = buf + TYPE_CHARS(UV); - char *ebuf = ptr; + char * const ebuf = ptr; int sign; if (is_uv) @@ -2980,16 +2933,6 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* sv_2pv() is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - return sv_2pv_flags(sv, lp, SV_GMAGIC); -} - /* =for apidoc sv_2pv_flags @@ -3195,7 +3138,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) { - const char *name = HvNAME_get(SvSTASH(sv)); + const char * const name = HvNAME_get(SvSTASH(sv)); Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", name ? name : "__ANON__" , typestr, PTR2UV(sv)); } @@ -3278,7 +3221,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return (char *)""; } { - STRLEN len = s - SvPVX_const(sv); + const STRLEN len = s - SvPVX_const(sv); if (lp) *lp = len; SvCUR_set(sv, len); @@ -3361,23 +3304,6 @@ Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) } /* -=for apidoc sv_2pvbyte_nolen - -Return a pointer to the byte-encoded representation of the SV. -May cause the SV to be downgraded from UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) -{ - return sv_2pvbyte(sv, 0); -} - -/* =for apidoc sv_2pvbyte Return a pointer to the byte-encoded representation of the SV, and set *lp @@ -3397,40 +3323,24 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) } /* -=for apidoc sv_2pvutf8_nolen - -Return a pointer to the UTF-8-encoded representation of the SV. -May cause the SV to be upgraded to UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) -{ - return sv_2pvutf8(sv, 0); -} - -/* -=for apidoc sv_2pvutf8 - -Return a pointer to the UTF-8-encoded representation of the SV, and set *lp -to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ + * =for apidoc sv_2pvutf8 + * + * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp + * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. + * + * Usually accessed via the C macro. + * + * =cut + * */ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { - sv_utf8_upgrade(sv); - return SvPV(sv,*lp); + sv_utf8_upgrade(sv); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } + /* =for apidoc sv_2bool @@ -3476,17 +3386,6 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } -/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); - * this function provided for binary compatibility only - */ - - -STRLEN -Perl_sv_utf8_upgrade(pTHX_ register SV *sv) -{ - return sv_utf8_upgrade_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_utf8_upgrade @@ -3545,7 +3444,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ const U8 *s = (U8 *) SvPVX_const(sv); - const U8 *e = (U8 *) SvEND(sv); + const U8 * const e = (U8 *) SvEND(sv); const U8 *t = s; int hibit = 0; @@ -3679,16 +3578,6 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return TRUE; } -/* sv_setsv() is now a macro using Perl_sv_setsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv_flags(dstr, sstr, SV_GMAGIC); -} - /* =for apidoc sv_setsv @@ -3871,11 +3760,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } - /* ahem, death to those who redefine active sort subs */ - else if (PL_curstackinfo->si_type == PERLSI_SORT - && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", - GvNAME(dstr)); #ifdef GV_UNIQUE_CHECK if (GvUNIQUE((GV*)dstr)) { @@ -3919,7 +3803,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - SV *sref = SvREFCNT_inc(SvRV(sstr)); + SV * const sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; const int intro = GvINTRO(dstr); @@ -3973,18 +3857,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else dref = (SV*)GvCV(dstr); if (GvCV(dstr) != (CV*)sref) { - CV* cv = GvCV(dstr); + CV* const cv = GvCV(dstr); if (cv) { if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { - /* ahem, death to those who redefine - * active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && - PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ - "Can't redefine active sort subroutine %s", - GvENAME((GV*)dstr)); /* Redefining a sub - warning is mandatory if it was a const and its value changed. */ if (ckWARN(WARN_REDEFINE) @@ -4606,7 +4483,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvPV_set(sv, Nullch); SvLEN_set(sv, 0); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } @@ -4621,22 +4498,6 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) } /* -=for apidoc sv_force_normal - -Undo various types of fakery on an SV: if the PV is a shared string, make -a private copy; if we're a ref, stop refing; if we're a glob, downgrade to -an xpvmg. See also C. - -=cut -*/ - -void -Perl_sv_force_normal(pTHX_ register SV *sv) -{ - sv_force_normal_flags(sv, 0); -} - -/* =for apidoc sv_chop Efficient removal of characters from the beginning of the string buffer. @@ -4665,7 +4526,7 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) const char *pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } SvIV_set(sv, 0); @@ -4681,16 +4542,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) SvIV_set(sv, SvIVX(sv) + delta); } -/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) -{ - sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); -} - /* =for apidoc sv_catpvn @@ -4725,31 +4576,8 @@ Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register *SvEND(dsv) = '\0'; (void)SvPOK_only_UTF8(dsv); /* validate pointer */ SvTAINT(dsv); -} - -/* -=for apidoc sv_catpvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) -{ - sv_catpvn(sv,ptr,len); - SvSETMAGIC(sv); -} - -/* sv_catsv() is now a macro using Perl_sv_catsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_catsv_flags(dstr, sstr, SV_GMAGIC); + if (flags & SV_SMAGIC) + SvSETMAGIC(dsv); } /* @@ -4773,51 +4601,38 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { const char *spv; STRLEN slen; - if (!ssv) - return; - 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 - get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though - dsv->sv_flags doesn't have that bit set. + if (ssv) { + 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 + get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though + dsv->sv_flags doesn't have that bit set. Andy Dougherty 12 Oct 2001 - */ - const I32 sutf8 = DO_UTF8(ssv); - I32 dutf8; + */ + const I32 sutf8 = DO_UTF8(ssv); + I32 dutf8; - if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) - mg_get(dsv); - dutf8 = DO_UTF8(dsv); + if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) + mg_get(dsv); + dutf8 = DO_UTF8(dsv); - if (dutf8 != sutf8) { - if (dutf8) { - /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVpvn(spv, slen)); + if (dutf8 != sutf8) { + if (dutf8) { + /* Not modifying source SV, so taking a temporary copy. */ + SV* csv = sv_2mortal(newSVpvn(spv, slen)); - sv_utf8_upgrade(csv); - spv = SvPV_const(csv, slen); + sv_utf8_upgrade(csv); + spv = SvPV_const(csv, slen); + } + else + sv_utf8_upgrade_nomg(dsv); } - else - sv_utf8_upgrade_nomg(dsv); + sv_catpvn_nomg(dsv, spv, slen); } - sv_catpvn_nomg(dsv, spv, slen); } -} - -/* -=for apidoc sv_catsv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv) -{ - sv_catsv(dsv,ssv); - SvSETMAGIC(dsv); + if (flags & SV_SMAGIC) + SvSETMAGIC(dsv); } /* @@ -5409,7 +5224,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) const U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1) { - Perl_croak(aTHX_ "panic: feference miscount on nsv in sv_replace() (%" + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); } if (SvMAGICAL(sv)) { @@ -6797,7 +6612,7 @@ thats_really_all_folks: screamer2: if (rslen) { - const register STDCHAR *bpe = buf + sizeof(buf); + register const STDCHAR *bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -7590,19 +7405,15 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) av_clear(GvAV(gv)); } if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { +#if defined(VMS) + Perl_die(aTHX_ "Can't reset %%ENV on this system"); +#else /* ! VMS */ hv_clear(GvHV(gv)); -#ifndef PERL_MICRO -#ifdef USE_ENVIRON_ARRAY - if (gv == PL_envgv -# ifdef USE_ITHREADS - && PL_curinterp == aTHX -# endif - ) - { - environ[0] = Nullch; - } -#endif -#endif /* !PERL_MICRO */ +# if defined(USE_ENVIRON_ARRAY) + if (gv == PL_envgv) + my_clearenv(); +# endif /* USE_ENVIRON_ARRAY */ +#endif /* VMS */ } } } @@ -7688,7 +7499,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) default: SvGETMAGIC(sv); if (SvROK(sv)) { - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); sv = SvRV(sv); @@ -7749,8 +7560,8 @@ Perl_sv_true(pTHX_ register SV *sv) if (!sv) return 0; if (SvPOK(sv)) { - const register XPV* tXpv; - if ((tXpv = (XPV*)SvANY(sv)) && + register const XPV* const tXpv = (XPV*)SvANY(sv); + if (tXpv && (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) return 1; @@ -7770,120 +7581,6 @@ Perl_sv_true(pTHX_ register SV *sv) } /* -=for apidoc sv_iv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -IV -Perl_sv_iv(pTHX_ register SV *sv) -{ - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); - } - return sv_2iv(sv); -} - -/* -=for apidoc sv_uv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -UV -Perl_sv_uv(pTHX_ register SV *sv) -{ - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); - } - return sv_2uv(sv); -} - -/* -=for apidoc sv_nv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -NV -Perl_sv_nv(pTHX_ register SV *sv) -{ - if (SvNOK(sv)) - return SvNVX(sv); - return sv_2nv(sv); -} - -/* sv_pv() is now a macro using SvPV_nolen(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pv(pTHX_ SV *sv) -{ - if (SvPOK(sv)) - return SvPVX(sv); - - return sv_2pv(sv, 0); -} - -/* -=for apidoc sv_pv - -Use the C macro instead - -=for apidoc sv_pvn - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -char * -Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) -{ - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv(sv, lp); -} - - -char * -Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) -{ - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv_flags(sv, lp, 0); -} - -/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) -{ - return sv_pvn_force_flags(sv, lp, SV_GMAGIC); -} - -/* =for apidoc sv_pvn_force Get a sensible string out of the SV somehow. @@ -7937,7 +7634,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) sv_unref(sv); SvUPGRADE(sv, SVt_PV); /* Never FALSE */ SvGROW(sv, len + 1); - Move(s,SvPVX_const(sv),len,char); + Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); *SvEND(sv) = '\0'; } @@ -7951,44 +7648,10 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) return SvPVX_mutable(sv); } -/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvbyte(pTHX_ SV *sv) -{ - sv_utf8_downgrade(sv,0); - return sv_pv(sv); -} - -/* -=for apidoc sv_pvbyte - -Use C instead. - -=for apidoc sv_pvbyten - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) -{ - sv_utf8_downgrade(sv,0); - return sv_pvn(sv,lp); -} - /* =for apidoc sv_pvbyten_force -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +The backend for the C macro. Always use the macro instead. =cut */ @@ -8002,44 +7665,10 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) return SvPVX(sv); } -/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - sv_utf8_upgrade(sv); - return sv_pv(sv); -} - -/* -=for apidoc sv_pvutf8 - -Use the C macro instead - -=for apidoc sv_pvutf8n - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) -{ - sv_utf8_upgrade(sv); - return sv_pvn(sv,lp); -} - /* =for apidoc sv_pvutf8n_force -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +The backend for the C macro. Always use the macro instead. =cut */ @@ -8426,36 +8055,6 @@ Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) } /* -=for apidoc sv_unref - -Unsets the RV status of the SV, and decrements the reference count of -whatever was being referenced by the RV. This can almost be thought of -as a reversal of C. This is C with the C -being zero. See C. - -=cut -*/ - -void -Perl_sv_unref(pTHX_ SV *sv) -{ - sv_unref_flags(sv, 0); -} - -/* -=for apidoc sv_taint - -Taint an SV. Use C instead. -=cut -*/ - -void -Perl_sv_taint(pTHX_ SV *sv) -{ - sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0); -} - -/* =for apidoc sv_untaint Untaint an SV. Use C instead. @@ -8483,7 +8082,7 @@ bool Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg && (mg->mg_len & 1) ) return TRUE; } @@ -8520,11 +8119,7 @@ Like C, but also handles 'set' magic. void Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); + sv_setpviv(sv, iv); SvSETMAGIC(sv); } @@ -9647,8 +9242,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV aka precis is 0 */ if ( c == 'g' && precis) { Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); - if (*PL_efloatbuf) /* May return an empty string for digits==0 */ + /* May return an empty string for digits==0 */ + if (*PL_efloatbuf) { + elen = strlen(PL_efloatbuf); goto float_converted; + } } else if ( c == 'f' && !precis) { if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) break; @@ -9692,17 +9290,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * where printf() taints but print($float) doesn't. * --jhi */ #if defined(HAS_LONG_DOUBLE) - if (intsize == 'q') - (void)sprintf(PL_efloatbuf, ptr, nv); - else - (void)sprintf(PL_efloatbuf, ptr, (double)nv); + elen = ((intsize == 'q') + ? my_sprintf(PL_efloatbuf, ptr, nv) + : my_sprintf(PL_efloatbuf, ptr, (double)nv)); #else - (void)sprintf(PL_efloatbuf, ptr, nv); + elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif } float_converted: eptr = PL_efloatbuf; - elen = strlen(PL_efloatbuf); break; /* SPECIAL */ @@ -9733,7 +9329,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) && ckWARN(WARN_PRINTF)) { - SV *msg = sv_newmortal(); + SV * const msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", (PL_op->op_type == OP_PRTF) ? "" : "s"); if (c) { @@ -10174,27 +9770,27 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) /* add a new entry to a pointer-mapping table */ void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldv, void *newv) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) { PTR_TBL_ENT_t *tblent, **otblent; /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - const UV hash = PTR_TABLE_HASH(oldv); + const UV hash = PTR_TABLE_HASH(oldsv); bool empty = 1; assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) { - if (tblent->oldval == oldv) { - tblent->newval = newv; + if (tblent->oldval == oldsv) { + tblent->newval = newsv; return; } } new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root, sizeof(struct ptr_tbl_ent)); - tblent->oldval = oldv; - tblent->newval = newv; + tblent->oldval = oldsv; + tblent->newval = newsv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; @@ -10350,8 +9946,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if(SvTYPE(sstr) == SVt_PVHV && (hvname = HvNAME_get(sstr))) { /** don't clone stashes if they already exist **/ - HV* old_stash = gv_stashpv(hvname,0); - return (SV*) old_stash; + return (SV*)gv_stashpv(hvname,0); } } @@ -10625,7 +10220,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) char); HvARRAY(dstr) = (HE**)darray; while (i <= sxhv->xhv_max) { - HE *source = HvARRAY(sstr)[i]; + const HE *source = HvARRAY(sstr)[i]; HvARRAY(dstr)[i] = source ? he_dup(source, sharekeys, param) : 0; ++i; @@ -11462,6 +11057,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statusvalue = proto_perl->Istatusvalue; #ifdef VMS PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#else + PL_statusvalue_posix = proto_perl->Istatusvalue_posix; #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); @@ -11612,7 +11209,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_evalseq = proto_perl->Ievalseq; PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ PL_origalen = proto_perl->Iorigalen; +#ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); /* XXX flag for cloning? */ +#endif PL_osname = SAVEPV(proto_perl->Iosname); PL_sighandlerp = proto_perl->Isighandlerp; @@ -11910,7 +11509,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sortstash = hv_dup(proto_perl->Tsortstash, param); PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); - PL_sortcxix = proto_perl->Tsortcxix; PL_efloatbuf = Nullch; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */