X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=30b118b9efeb9e2df51244b0931acc9900e8cc30;hb=658aef798ab992aed2b708fed0d12323ab3b1fcb;hp=e9f47ddff4a1b196e4043a83d805c1844d7165db;hpb=30c8d9e411f7375ddf81a32aa625d6c0e0c39091;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index e9f47dd..30b118b 100644 --- a/sv.c +++ b/sv.c @@ -35,13 +35,13 @@ * lib/utf8.t lib/Unicode/Collate/t/index.t * --jhi */ -#define ASSERT_UTF8_CACHE(cache) \ +# define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ assert((cache)[2] <= (cache)[3]); \ assert((cache)[3] <= (cache)[1]);} \ } STMT_END #else -#define ASSERT_UTF8_CACHE(cache) NOOP +# define ASSERT_UTF8_CACHE(cache) NOOP #endif #ifdef PERL_OLD_COPY_ON_WRITE @@ -1717,8 +1717,29 @@ Perl_looks_like_number(pTHX_ SV *sv) return grok_number(sbegin, len, NULL); } +STATIC bool +S_glob_2number(pTHX_ GV * const gv) +{ + const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; + SV *const buffer = sv_newmortal(); + + /* FAKE globs can get coerced, so need to turn this off temporarily if it + is on. */ + SvFAKE_off(gv); + gv_efullname3(buffer, gv, "*"); + SvFLAGS(gv) |= wasfake; + + /* We know that all GVs stringify to something that is not-a-number, + so no need to test that. */ + if (ckWARN(WARN_NUMERIC)) + not_a_number(buffer); + /* We just want something true to return, so that S_sv_2iuv_common + can tail call us and return true. */ + return TRUE; +} + STATIC char * -S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) +S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) { const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; SV *const buffer = sv_newmortal(); @@ -1729,21 +1750,9 @@ S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - if (want_number) { - /* We know that all GVs stringify to something that is not-a-number, - so no need to test that. */ - if (ckWARN(WARN_NUMERIC)) - not_a_number(buffer); - /* We just want something true to return, so that S_sv_2iuv_common - can tail call us and return true. */ - return (char *) 1; - } else { - assert(SvPOK(buffer)); - if (len) { - *len = SvCUR(buffer); - } - return SvPVX(buffer); - } + assert(SvPOK(buffer)); + *len = SvCUR(buffer); + return SvPVX(buffer); } /* Actually, ISO C leaves conversion of UV to IV undefined, but @@ -2054,7 +2063,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */ + NOOP; /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { @@ -2069,7 +2078,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */ + NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ } } SvIsUV_on(sv); @@ -2113,9 +2122,8 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } } else { - if (isGV_with_GP(sv)) { - return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); - } + if (isGV_with_GP(sv)) + return glob_2number((GV *)sv); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2465,7 +2473,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else { if (isGV_with_GP(sv)) { - glob_2inpuv((GV *)sv, NULL, TRUE); + glob_2number((GV *)sv); return 0.0; } @@ -2801,9 +2809,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (isGV_with_GP(sv)) { - return glob_2inpuv((GV *)sv, lp, FALSE); - } + if (isGV_with_GP(sv)) + return glob_2pv((GV *)sv, lp); if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -3287,7 +3294,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { it was a const and its value changed. */ if (CvCONST(cv) && CvCONST((CV*)sref) && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { - /*EMPTY*/ + NOOP; /* They are 2 constant subroutines generated from the same constant. This probably means that they are really the "same" proxy subroutine @@ -3309,8 +3316,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } } if (!intro) - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX_const(sref) : NULL); + cv_ckproto_len(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX_const(sref) : NULL, + SvPOK(sref) ? SvCUR(sref) : 0); } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); @@ -3898,7 +3906,7 @@ that pointer (e.g. ptr + 1) be used. If C & SV_SMAGIC is true, will call SvSETMAGIC. If C & SV_HAS_TRAILING_NUL is true, then C must be NUL, and the realloc -I be skipped. (i.e. the buffer is actually at least 1 byte longer than +will be skipped. (i.e. the buffer is actually at least 1 byte longer than C, and already meets the requirements for storing in C) =cut @@ -3925,20 +3933,21 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) allocate = (flags & SV_HAS_TRAILING_NUL) ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + if (flags & SV_HAS_TRAILING_NUL) { + /* It's long enough - do nothing. + Specfically Perl_newCONSTSUB is relying on this. */ + } else { #ifdef DEBUGGING - { /* Force a move to shake out bugs in callers. */ char *new_ptr = safemalloc(allocate); Copy(ptr, new_ptr, len, char); PoisonFree(ptr,len,char); Safefree(ptr); ptr = new_ptr; - } #else - if (!(flags & SV_HAS_TRAILING_NUL)) { ptr = saferealloc (ptr, allocate); - } #endif + } SvPV_set(sv, ptr); SvCUR_set(sv, len); SvLEN_set(sv, allocate); @@ -5357,13 +5366,11 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) /* Walk forwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, +S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, STRLEN uoffset) { const U8 *s = start; - PERL_UNUSED_CONTEXT; - while (s < send && uoffset--) s += UTF8SKIP(s); if (s > send) { @@ -5378,7 +5385,7 @@ S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, whether to walk forwards or backwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, +S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, STRLEN uoffset, STRLEN uend) { STRLEN backw = uend - uoffset; @@ -5386,7 +5393,7 @@ S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, /* The assumption is that going forwards is twice the speed of going forward (that's where the 2 * backw comes from). (The real figure of course depends on the UTF-8 data.) */ - return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset); + return sv_pos_u2b_forwards(start, send, uoffset); } while (backw--) { @@ -5437,12 +5444,12 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if ((*mgp)->mg_len != -1) { /* And we know the end too. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); } } @@ -5455,13 +5462,13 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, } boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[1], uoffset - uoffset0, cache[0] - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[3], uoffset - uoffset0, cache[2] - uoffset0); @@ -5473,7 +5480,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, /* In fact, offset0 is either 0, or less than offset, so don't need to worry about the other possibility. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); found = TRUE; @@ -5482,7 +5489,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if (!found || PL_utf8cache < 0) { const STRLEN real_boffset - = boffset0 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + = boffset0 + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); if (found && PL_utf8cache < 0) { @@ -5537,16 +5544,16 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - STRLEN boffset = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, + const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); *offsetp = (I32) boffset; if (lenp) { /* Convert the relative offset to absolute. */ - STRLEN uoffset2 = uoffset + (STRLEN) *lenp; - STRLEN boffset2 - = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, uoffset2, + const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN boffset2 + = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; @@ -6519,7 +6526,7 @@ screamer2: * * - jik 9/25/96 */ - if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) goto screamer2; } @@ -9977,7 +9984,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { - /*EMPTY*/; /* Do sharing here, and fall through */ + NOOP; /* Do sharing here, and fall through */ } case SVt_PVIO: case SVt_PVFM: @@ -10088,7 +10095,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) if (IoDIRP(dstr)) { IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); } else { - /*EMPTY*/; + NOOP; /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ } } @@ -10687,10 +10694,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_reg_oldsaved); new_state->re_state_reg_poscache = pv_dup(old_state->re_state_reg_poscache); -#ifdef DEBUGGING new_state->re_state_reg_starttry = pv_dup(old_state->re_state_reg_starttry); -#endif break; } case SAVEt_COMPILE_WARNINGS: @@ -10916,7 +10921,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); + SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); SvCUR_set(&PL_sv_no, 0); SvLEN_set(&PL_sv_no, 1); SvIV_set(&PL_sv_no, 0); @@ -10927,7 +10932,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); + SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); SvCUR_set(&PL_sv_yes, 1); SvLEN_set(&PL_sv_yes, 2); SvIV_set(&PL_sv_yes, 1); @@ -11887,7 +11892,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) subscript_type = FUV_SUBSCRIPT_HASH; } else { - index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + index = find_array_subscript((AV*)sv, uninit_sv); if (index >= 0) subscript_type = FUV_SUBSCRIPT_ARRAY; } @@ -12101,13 +12106,14 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) * or are optimized away, then it's unambiguous */ o2 = NULL; for (kid=o; kid; kid = kid->op_sibling) { - if (kid && - ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (kid->op_type == OP_PUSHMARK) + if (kid) { + const OPCODE type = kid->op_type; + if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (type == OP_PUSHMARK) ) - ) continue; + } if (o2) { /* more than one found */ o2 = NULL; break;