X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=70f5a260db4b05b67437d89d370524ab8d3f0eab;hb=e10204135b763e864169cd1f19037fc2f8c37385;hp=22206180e828be50652c3e803e0eccab352e0f32;hpb=73d1d97336c68e0f5b29937cb9347a00df4c645c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 2220618..70f5a26 100644 --- a/util.c +++ b/util.c @@ -369,10 +369,9 @@ Free_t Perl_mfree (Malloc_t where) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_DELIMCPY; @@ -400,10 +399,9 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons /* This routine was donated by Corey Satten. */ char * -Perl_instr(pTHX_ register const char *big, register const char *little) +Perl_instr(register const char *big, register const char *little) { register I32 first; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_INSTR; @@ -435,10 +433,9 @@ Perl_instr(pTHX_ register const char *big, register const char *little) /* same as instr but allow embedded nulls */ char * -Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) +Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) { PERL_ARGS_ASSERT_NINSTR; - PERL_UNUSED_CONTEXT; if (little >= lend) return (char*)big; { @@ -462,12 +459,11 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const /* reverse of the above--find last substring */ char * -Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) +Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend) { register const char *bigbeg; register const I32 first = *little; register const char * const littleend = lend; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_RNINSTR; @@ -883,11 +879,10 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } I32 -Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_ibcmp(const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_IBCMP; @@ -900,12 +895,11 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) } I32 -Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len) { dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_IBCMP_LOCALE; @@ -1235,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; @@ -1260,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); @@ -1274,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); @@ -1286,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; @@ -1314,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); } @@ -1334,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; } @@ -1366,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) @@ -1387,7 +1376,6 @@ Perl_die_nocontext(const char* pat, ...) dTHX; OP *o; va_list args; - PERL_ARGS_ASSERT_DIE_NOCONTEXT; va_start(args, pat); o = vdie(pat, &args); va_end(args); @@ -1410,22 +1398,11 @@ void Perl_vcroak(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - STRLEN msglen; - I32 utf8 = 0; + SV *msv; - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); + msv = S_vdie_croak_common(aTHX_ pat, args); - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - else if (!message) - message = SvPVx_const(ERRSV, msglen); - - write_to_stderr(message, msglen); - my_failure_exit(); + die_where(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1475,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) @@ -1536,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; @@ -1552,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); @@ -1579,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 */ @@ -1607,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. */ @@ -2288,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) { @@ -2436,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) { @@ -3033,26 +3027,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif +#define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) +Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count) { - register I32 todo; - register const char * const frombase = from; - PERL_UNUSED_CONTEXT; - PERL_ARGS_ASSERT_REPEATCPY; - if (len == 1) { - register const char c = *from; - while (count-- > 0) - *to++ = c; - return; - } - while (count-- > 0) { - for (todo = len; todo > 0; todo--) { - *to++ = *from++; + if (len == 1) + memset(to, *from, count); + else if (count) { + register char *p = to; + I32 items, linear, half; + + linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; + for (items = 0; items < linear; ++items) { + register const char *q = from; + I32 todo; + for (todo = len; todo > 0; todo--) + *p++ = *q++; + } + + half = count / 2; + while (items <= half) { + I32 size = items * len; + memcpy(p, to, size); + p += size; + items *= 2; } - from = frombase; + + if (count > items) + memcpy(p, to, (count - items) * len); } } @@ -3251,7 +3255,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ if (len -# if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' # endif @@ -4229,7 +4233,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos = s; /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) + while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) ) { if ( *pos == '.' ) { @@ -4245,6 +4249,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) alpha = 1; width = pos - last - 1; /* natural width of sub-version */ } + else if ( *pos == ',' && isDIGIT(pos[1]) ) + { + saw_period++ ; + last = pos; + } + pos++; } @@ -4292,9 +4302,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; @@ -4311,9 +4320,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; @@ -4332,6 +4340,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; + else if ( *pos == ',' && isDIGIT(pos[1]) ) + s = ++pos; else if ( isDIGIT(*pos) ) s = pos; else { @@ -4559,10 +4569,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; } @@ -5357,7 +5366,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. */ @@ -5471,34 +5480,29 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #ifdef PERL_MEM_LOG -/* - * -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the +/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also * given, and you supply your own implementation. * - * -DPERL_MEM_LOG_ENV: if compiled in, at run time the environment - * variables PERL_MEM_LOG and PERL_SV_LOG are checked (repeatedly). - * If the integer values are true, the respective logging is done. - * (Without this also defined, logging is voluminous) + * The default implementation reads a single env var, PERL_MEM_LOG, + * expecting one or more of the following: + * + * \d+ - fd fd to write to : must be 1st (atoi) + * 'm' - memlog was PERL_MEM_LOG=1 + * 's' - svlog was PERL_SV_LOG=1 + * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 * - * -DPERL_MEM_LOG_TIMESTAMP: if compiled, a timestamp will be logged - * before every memory logging entry. This can be turned off at run - * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP - * to zero. + * This makes the logger controllable enough that it can reasonably be + * added to the system perl. */ -/* - * -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer +/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer * the Perl_mem_log_...() will use (either via sprintf or snprintf). */ #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 -/* - * -DPERL_MEM_LOG_FD=2: the file descriptor the Perl_mem_log_...() - * writes to. You can also define in compile time - * PERL_MEM_LOG_ENV_FD, in which case the environment variable - * PERL_MEM_LOG_FD will be consulted for the file descriptor number to - * use. +/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() + * writes to. In the default logger, this is settable at runtime. */ #ifndef PERL_MEM_LOG_FD # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ @@ -5521,21 +5525,19 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, const char *filename, const int linenumber, const char *funcname) { -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - const char *s; -# endif + const char *pmlenv; - /* PERL_ARGS_ASSERT_MEM_LOG_COMMON; */ + PERL_ARGS_ASSERT_MEM_LOG_COMMON; -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG"); - if (s ? atoi(s) : 0) -# endif + pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); + if (!pmlenv) + return; + if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) { /* We can't use SVs or PerlIO for obvious reasons, * so we'll use stdio and low-level IO instead. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP + # ifdef HAS_GETTIMEOFDAY # define MEM_LOG_TIME_FMT "%10d.%06d: " # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec @@ -5551,24 +5553,17 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, * gettimeofday() (see ext/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ -# endif { - int fd = PERL_MEM_LOG_FD; STRLEN len; + int fd = atoi(pmlenv); + if (!fd) + fd = PERL_MEM_LOG_FD; -# ifdef PERL_MEM_LOG_ENV_FD - if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) { - fd = atoi(s); - } -# endif -# ifdef PERL_MEM_LOG_TIMESTAMP - s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP"); - if (!s || atoi(s)) { + if (strchr(pmlenv, 't')) { len = my_snprintf(buf, sizeof(buf), MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); PerlLIO_write(fd, buf, len); } -# endif switch (mlt) { case MLT_ALLOC: len = my_snprintf(buf, sizeof(buf), @@ -5842,9 +5837,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 */ @@ -5899,9 +5898,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 */ @@ -6031,17 +6034,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;