X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=89fea231a6add9630d6d46a9c01db7db5ecfafc4;hb=cb47d8a5d4a3850a5c2237056982489145a27981;hp=ae8c688e2d1571bf40ed0c9bde5b0ab853051c63;hpb=16fa5c119c4bda5c0396a5f81296bd1ccc128a9c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index ae8c688..89fea23 100644 --- a/util.c +++ b/util.c @@ -1229,7 +1229,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) } void -Perl_write_to_stderr(pTHX_ const char* message, int msglen) +Perl_write_to_stderr(pTHX_ SV* msv) { dVAR; IO *io; @@ -1254,7 +1254,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - mPUSHp(message, msglen); + PUSHs(msv); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1268,6 +1268,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) dSAVED_ERRNO; #endif PerlIO * const serr = Perl_error_log; + STRLEN msglen; + const char* message = SvPVx_const(msv, msglen); PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); @@ -1280,7 +1282,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) /* Common code used by vcroak, vdie, vwarn and vwarner */ STATIC bool -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) +S_vdie_common(pTHX_ SV *message, bool warn) { dVAR; HV *stash; @@ -1308,7 +1310,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) *hook = NULL; } if (warn || message) { - msg = newSVpvn_flags(message, msglen, utf8); + msg = newSVsv(message); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1328,30 +1330,28 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) return FALSE; } -STATIC const char * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, - I32* utf8) +STATIC SV * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args) { dVAR; - const char *message; + SV *message; if (pat) { SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV_const(PL_errors, *msglen); + message = sv_mortalcopy(PL_errors); SvCUR_set(PL_errors, 0); } else - message = SvPV_const(msv,*msglen); - *utf8 = SvUTF8(msv); + message = msv; } else { message = NULL; } if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); + S_vdie_common(aTHX_ message, FALSE); } return message; } @@ -1360,18 +1360,13 @@ static OP * S_vdie(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - const int was_in_eval = PL_in_eval; - STRLEN msglen; - I32 utf8 = 0; + SV *message; - message = vdie_croak_common(pat, args, &msglen, &utf8); + message = vdie_croak_common(pat, args); - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) - JMPENV_JUMP(3); - return PL_restartop; + die_where(message); + /* NOTREACHED */ + return NULL; } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1403,22 +1398,11 @@ void Perl_vcroak(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - STRLEN msglen; - I32 utf8 = 0; - - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); + SV *msv; - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - else if (!message) - message = SvPVx_const(ERRSV, msglen); + msv = S_vdie_croak_common(aTHX_ pat, args); - write_to_stderr(message, msglen); - my_failure_exit(); + die_where(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1468,19 +1452,16 @@ void Perl_vwarn(pTHX_ const char* pat, va_list *args) { dVAR; - STRLEN msglen; SV * const msv = vmess(pat, args); - const I32 utf8 = SvUTF8(msv); - const char * const message = SvPV_const(msv, msglen); PERL_ARGS_ASSERT_VWARN; if (PL_warnhook) { - if (vdie_common(message, msglen, utf8, TRUE)) + if (vdie_common(msv, TRUE)) return; } - write_to_stderr(message, msglen); + write_to_stderr(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1529,6 +1510,32 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ void +Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER_D; + + if (Perl_ckwarn_d(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void +Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER; + + if (Perl_ckwarn(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void Perl_warner(pTHX_ U32 err, const char* pat,...) { va_list args; @@ -1545,21 +1552,12 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) PERL_ARGS_ASSERT_VWARNER; if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - STRLEN msglen; - const char * const message = SvPV_const(msv, msglen); - const I32 utf8 = SvUTF8(msv); if (PL_diehook) { - assert(message); - S_vdie_common(aTHX_ message, msglen, utf8, FALSE); + assert(msv); + S_vdie_common(aTHX_ msv, FALSE); } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - write_to_stderr(message, msglen); - my_failure_exit(); + die_where(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -1572,26 +1570,11 @@ bool Perl_ckwarn(pTHX_ U32 w) { dVAR; - return - ( - isLEXWARN_on - && PL_curcop->cop_warnings != pWARN_NONE - && ( - PL_curcop->cop_warnings == pWARN_ALL - || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - || - ( - isLEXWARN_off && PL_dowarn & G_WARN_ON - ) - ; + /* If lexical warnings have not been set, use $^W. */ + if (isLEXWARN_off) + return PL_dowarn & G_WARN_ON; + + return ckwarn_common(w); } /* implements the ckWARN?_d macro */ @@ -1600,22 +1583,42 @@ bool Perl_ckwarn_d(pTHX_ U32 w) { dVAR; - return - isLEXWARN_off - || PL_curcop->cop_warnings == pWARN_ALL - || ( - PL_curcop->cop_warnings != pWARN_NONE - && ( - isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - ; + /* If lexical warnings have not been set then default classes warn. */ + if (isLEXWARN_off) + return TRUE; + + return ckwarn_common(w); +} + +static bool +S_ckwarn_common(pTHX_ U32 w) +{ + if (PL_curcop->cop_warnings == pWARN_ALL) + return TRUE; + + if (PL_curcop->cop_warnings == pWARN_NONE) + return FALSE; + + /* Check the assumption that at least the first slot is non-zero. */ + assert(unpackWARN1(w)); + + /* Check the assumption that it is valid to stop as soon as a zero slot is + seen. */ + if (!unpackWARN2(w)) { + assert(!unpackWARN3(w)); + assert(!unpackWARN4(w)); + } else if (!unpackWARN3(w)) { + assert(!unpackWARN4(w)); + } + + /* Right, dealt with all the special cases, which are implemented as non- + pointers, so there is a pointer to a real warnings mask. */ + do { + if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) + return TRUE; + } while (w >>= WARNshift); + + return FALSE; } /* Set buffer=NULL to get a new one. */ @@ -2281,8 +2284,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) } return NULL; } - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2429,8 +2431,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); return NULL; } - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -4180,6 +4181,210 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } #define VERSION_MAX 0x7FFFFFFF + +/* +=for apidoc prescan_version + +=cut +*/ +const char * +Perl_prescan_version(pTHX_ const char *s, bool strict, + const char **errstr, + bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { + bool qv = (sqv ? *sqv : FALSE); + int width = 3; + int saw_decimal = 0; + bool alpha = FALSE; + const char *d = s; + + PERL_ARGS_ASSERT_PRESCAN_VERSION; + + if (qv && isDIGIT(*d)) + goto dotted_decimal_version; + + if (*d == 'v') { /* explicit v-string */ + d++; + if (isDIGIT(*d)) { + qv = TRUE; + } + else { /* degenerate v-string */ + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + +dotted_decimal_version: + if (strict && d[0] == '0' && isDIGIT(d[1])) { + /* no leading zeros allowed */ + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT(*d)) /* integer part */ + d++; + + if (*d == '.') + { + saw_decimal++; + d++; /* decimal point */ + } + else + { + if (strict) { + /* require v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + int i = 0; + int j = 0; + while (isDIGIT(*d)) { /* just keep reading */ + i++; + while (isDIGIT(*d)) { + d++; j++; + /* maximum 3 digits between decimal */ + if (strict && j > 3) { + BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + d++; + alpha = TRUE; + } + else if (*d == '.') { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + saw_decimal++; + d++; + } + else if (!isDIGIT(*d)) { + break; + } + j = 0; + } + + if (strict && i < 2) { + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } /* end if dotted-decimal */ + else + { /* decimal versions */ + /* special strict case for leading '.' or '0' */ + if (strict) { + if (*d == '.') { + BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); + } + if (*d == '0' && isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + } + + /* consume all of the integer part */ + while (isDIGIT(*d)) + d++; + + /* look for a fractional part */ + if (*d == '.') { + /* we found it, so consume it */ + saw_decimal++; + d++; + } + else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') { + if ( d == s ) { + /* found nothing */ + BADVERSION(s,errstr,"Invalid version format (version required)"); + } + /* found just an integer */ + goto version_prescan_finish; + } + else if ( d == s ) { + /* didn't find either integer or period */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + else if (*d == '_') { + /* underscore can't come after integer part */ + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + else if (isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); + } + else { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + } + else { + /* anything else after integer part is just invalid data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + /* scan the fractional part after the decimal point*/ + + if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) { + /* strict or lax-but-not-the-end */ + BADVERSION(s,errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT(*d)) { + d++; + if (*d == '.' && isDIGIT(d[-1])) { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + if (strict) { + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + d = (char *)s; /* start all over again */ + qv = TRUE; + goto dotted_decimal_version; + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT(d[1]) ) { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + d++; + alpha = TRUE; + } + } + } + +version_prescan_finish: + while (isSPACE(*d)) + d++; + + if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) { + /* trailing non-numeric data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + if (sqv) + *sqv = qv; + if (swidth) + *swidth = width; + if (ssaw_decimal) + *ssaw_decimal = saw_decimal; + if (salpha) + *salpha = alpha; + return d; +} + /* =for apidoc scan_version @@ -4208,9 +4413,10 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) const char *start; const char *pos; const char *last; - int saw_period = 0; - int alpha = 0; + const char *errstr = NULL; + int saw_decimal = 0; int width = 3; + bool alpha = FALSE; bool vinf = FALSE; AV * const av = newAV(); SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ @@ -4219,54 +4425,24 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + while (isSPACE(*s)) /* leading whitespace is OK */ s++; - start = last = s; - - if (*s == 'v') { - s++; /* get past 'v' */ - qv = 1; /* force quoted version processing */ - } - - pos = s; - - /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) ) - { - if ( *pos == '.' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); - saw_period++ ; - last = pos; - } - else if ( *pos == '_' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - alpha = 1; - width = pos - last - 1; /* natural width of sub-version */ - } - else if ( *pos == ',' && isDIGIT(pos[1]) ) - { - saw_period++ ; - last = pos; + last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); + if (errstr) { + /* "undef" is a special case and not an error */ + if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { + Perl_croak(aTHX_ "%s", errstr); } - - pos++; } - if ( alpha && !saw_period ) - Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); - - if ( alpha && saw_period && width == 0 ) - Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)"); - - if ( saw_period > 1 ) - qv = 1; /* force quoted version processing */ - - last = pos; + start = s; + if (*s == 'v') + s++; pos = s; if ( qv ) @@ -4293,7 +4469,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start && saw_period == 1 ) { + if ( !qv && s > start && saw_decimal == 1 ) { mult *= 100; while ( s < end ) { orev = rev; @@ -4301,9 +4477,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) mult /= 10; if ( (PERL_ABS(orev) > PERL_ABS(rev)) || (PERL_ABS(rev) > VERSION_MAX )) { - if(ckWARN(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version %d",VERSION_MAX); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); s = end - 1; rev = VERSION_MAX; vinf = 1; @@ -4320,9 +4495,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) mult *= 10; if ( (PERL_ABS(orev) > PERL_ABS(rev)) || (PERL_ABS(rev) > VERSION_MAX )) { - if(ckWARN(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version"); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); end = s - 1; rev = VERSION_MAX; vinf = 1; @@ -4385,7 +4559,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else if ( s > start ) { SV * orig = newSVpvn(start,s-start); - if ( qv && saw_period == 1 && *start != 'v' ) { + if ( qv && saw_decimal == 1 && *start != 'v' ) { /* need to insert a v to be consistent */ sv_insert(orig, 0, 0, "v", 1); } @@ -4434,6 +4608,9 @@ Perl_new_version(pTHX_ SV *ver) /* This will get reblessed later if a derived class*/ SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif if ( SvROK(ver) ) ver = SvRV(ver); @@ -4476,7 +4653,7 @@ Perl_new_version(pTHX_ SV *ver) char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); /* this is for consistency with the pure Perl class */ - if ( *version != 'v' ) + if ( isDIGIT(*version) ) sv_insert(rv, 0, 0, "v", 1); Safefree(version); } @@ -4531,7 +4708,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - qv = 1; + qv = TRUE; } #endif else /* must be a string or something like a string */ @@ -4541,12 +4718,14 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) #ifndef SvVOK # if PERL_VERSION > 5 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ - if ( len == 3 && !instr(version,".") && !instr(version,"_") ) { + if ( len >= 3 && !instr(version,".") && !instr(version,"_") + && !(*version == 'u' && strEQ(version, "undef")) + && (*version < '0' || *version > '9') ) { /* may be a v-string */ SV * const nsv = sv_newmortal(); const char *nver; const char *pos; - int saw_period = 0; + int saw_decimal = 0; sv_setpvf(nsv,"v%vd",ver); pos = nver = savepv(SvPV_nolen(nsv)); @@ -4554,12 +4733,12 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) pos++; /* skip the leading 'v' */ while ( *pos == '.' || isDIGIT(*pos) ) { if ( *pos == '.' ) - saw_period++ ; + saw_decimal++ ; pos++; } /* is definitely a v-string */ - if ( saw_period == 2 ) { + if ( saw_decimal >= 2 ) { Safefree(version); version = nver; } @@ -4570,10 +4749,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) s = scan_version(version, ver, qv); if ( *s != '\0' ) - if(ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4641,7 +4819,7 @@ Perl_vnumify(pTHX_ SV *vs) I32 i, len, digit; int width; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; PERL_ARGS_ASSERT_VNUMIFY; @@ -4663,19 +4841,17 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); @@ -4722,7 +4898,7 @@ Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; PERL_ARGS_ASSERT_VNORMAL; @@ -4740,11 +4916,10 @@ Perl_vnormal(pTHX_ SV *vs) len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,""); - return sv; + return newSVpvs(""); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); @@ -5368,7 +5543,7 @@ Perl_get_hash_seed(pTHX) * help. Sum in another random number that will * fill in the low bits. */ myseed += - (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); + (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); #endif /* RANDBITS < (UVSIZE * 8) */ if (myseed == 0) { /* Superparanoia. */ myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ @@ -5839,9 +6014,13 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) PERL_ARGS_ASSERT_MY_CXT_INIT; if (*index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif *index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -5896,9 +6075,13 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) index = Perl_my_cxt_index(aTHX_ my_cxt_key); if (index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -6028,17 +6211,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) { REGEXP * Perl_get_re_arg(pTHX_ SV *sv) { - SV *tmpsv; if (sv) { if (SvMAGICAL(sv)) mg_get(sv); - if (SvROK(sv) && - (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */ - SvTYPE(tmpsv) == SVt_REGEXP) - { - return (REGEXP*) tmpsv; - } + if (SvROK(sv)) + sv = MUTABLE_SV(SvRV(sv)); + if (SvTYPE(sv) == SVt_REGEXP) + return (REGEXP*) sv; } return NULL;