X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b033d66817d14286c927cb28db2c5b0b3903ba77..40d04e100dda727a888fa21457c86dffdbe3b44f:/util.c diff --git a/util.c b/util.c index 4289451..7cd7d0e 100644 --- a/util.c +++ b/util.c @@ -45,6 +45,10 @@ int putenv(char *); #endif +#ifdef __amigaos__ +# include "amigaos4/amigaio.h" +#endif + #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include @@ -128,7 +132,12 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; + +#ifdef USE_MDH + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; size += PERL_MEMORY_DEBUG_HEADER_SIZE; +#endif #ifdef DEBUGGING if ((SSize_t)size < 0) Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); @@ -175,13 +184,18 @@ Perl_safesysmalloc(MEM_SIZE size) } else { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - ptr = NULL; - else - croak_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } return ptr; } @@ -214,6 +228,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else { #ifdef USE_MDH where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; size += PERL_MEMORY_DEBUG_HEADER_SIZE; { struct perl_memory_debug_header *const header @@ -292,13 +308,18 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr == NULL) { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - ptr = NULL; - else - croak_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } } return ptr; @@ -539,10 +560,6 @@ Perl_instr(const char *big, const char *little) PERL_ARGS_ASSERT_INSTR; - /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL - * 'little' */ - if (!little) - return (char*)big; return strstr((char*)big, (char*)little); } @@ -617,7 +634,7 @@ Perl_rninstr(const char *big, const char *bigend, const char *little, const char =for apidoc fbm_compile -Analyses the string in order to make fast searches on it using fbm_instr() +Analyses the string in order to make fast searches on it using C -- the Boyer-Moore algorithm. =cut @@ -710,21 +727,37 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s[rarest], (UV)rarest)); } -/* If SvTAIL(littlestr), it has a fake '\n' at end. */ -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if multiline */ /* =for apidoc fbm_instr Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C -does not have to be fbm_compiled, but the search will not be as fast +C (C) is the char following the last char). +It returns C if the string can't be found. The C +does not have to be C, but the search will not be as fast then. =cut + +If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string +during FBM compilation due to FBMcf_TAIL in flags. It indicates that +the littlestr must be anchored to the end of bigstr (or to any \n if +FBMrf_MULTILINE). + +E.g. The regex compiler would compile /abc/ to a littlestr of "abc", +while /abc$/ compiles to "abc\n" with SvTAIL() true. + +A littlestr of "abc", !SvTAIL matches as /abc/; +a littlestr of "ab\n", SvTAIL matches as: + without FBMrf_MULTILINE: /ab\n?\z/ + with FBMrf_MULTILINE: /ab\n/ || /ab\z/; + +(According to Ilya from 1999; I don't know if this is still true, DAPM 2015): + "If SvTAIL is actually due to \Z or \z, this gives false positives + if multiline". */ + char * Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) { @@ -749,82 +782,103 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U switch (littlelen) { /* Special cases for 0, 1 and 2 */ case 0: return (char*)big; /* Cannot be SvTAIL! */ + case 1: - if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ - /* Know that bigend != big. */ - if (bigend[-1] == '\n') - return (char *)(bigend - 1); - return (char *) bigend; - } - s = big; - while (s < bigend) { - if (*s == *little) - return (char *)s; - s++; - } + if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + /* [-1] is safe because we know that bigend != big. */ + return (char *) (bigend - (bigend[-1] == '\n')); + + s = (unsigned char *)memchr((void*)big, *little, bigend-big); + if (s) + return (char *)s; if (SvTAIL(littlestr)) return (char *) bigend; return NULL; + case 2: if (SvTAIL(littlestr) && !multiline) { - if (bigend[-1] == '\n' && bigend[-2] == *little) + /* a littlestr with SvTAIL must be of the form "X\n" (where X + * is a single char). It is anchored, and can only match + * "....X\n" or "....X" */ + if (bigend[-2] == *little && bigend[-1] == '\n') return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; return NULL; } + { - /* This should be better than FBM if c1 == c2, and almost - as good otherwise: maybe better since we do less indirection. - And we save a lot of memory by caching no table. */ - const unsigned char c1 = little[0]; - const unsigned char c2 = little[1]; - - s = big + 1; - bigend--; - if (c1 != c2) { - while (s <= bigend) { - if (s[0] == c2) { - if (s[-1] == c1) - return (char*)s - 1; - s += 2; - continue; - } - next_chars: - if (s[0] == c1) { - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c2) - return (char*)s; - else { - s++; - goto next_chars; - } - } - else - s += 2; - } - goto check_1char_anchor; - } - /* Now c1 == c2 */ - while (s <= bigend) { - if (s[0] == c1) { - if (s[-1] == c1) - return (char*)s - 1; - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c1) - return (char*)s; - s += 3; - } - else - s += 2; - } - } - check_1char_anchor: /* One char and anchor! */ - if (SvTAIL(littlestr) && (*bigend == *little)) - return (char *)bigend; /* bigend is already decremented. */ - return NULL; + /* memchr() is likely to be very fast, possibly using whatever + * hardware support is available, such as checking a whole + * cache line in one instruction. + * So for a 2 char pattern, calling memchr() is likely to be + * faster than running FBM, or rolling our own. The previous + * version of this code was roll-your-own which typically + * only needed to read every 2nd char, which was good back in + * the day, but no longer. + */ + unsigned char c1 = little[0]; + unsigned char c2 = little[1]; + + /* *** for all this case, bigend points to the last char, + * not the trailing \0: this makes the conditions slightly + * simpler */ + bigend--; + s = big; + if (c1 != c2) { + while (s < bigend) { + /* do a quick test for c1 before calling memchr(); + * this avoids the expensive fn call overhead when + * there are lots of c1's */ + if (LIKELY(*s != c1)) { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s) + break; + } + if (s[1] == c2) + return (char*)s; + + /* failed; try searching for c2 this time; that way + * we don't go pathologically slow when the string + * consists mostly of c1's or vice versa. + */ + s += 2; + if (s > bigend) + break; + s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1); + if (!s) + break; + if (s[-1] == c1) + return (char*)s - 1; + } + } + else { + /* c1, c2 the same */ + while (s < bigend) { + if (s[0] == c1) { + got_1char: + if (s[1] == c1) + return (char*)s; + s += 2; + } + else { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s || s >= bigend) + break; + goto got_1char; + } + } + } + + /* failed to find 2 chars; try anchored match at end without + * the \n */ + if (SvTAIL(littlestr) && bigend[0] == little[0]) + return (char *)bigend; + return NULL; + } + default: break; /* Only lengths 0 1 and 2 have special-case code. */ } @@ -844,7 +898,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } return NULL; } + if (!SvVALID(littlestr)) { + /* not compiled; use Perl_ninstr() instead */ char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); @@ -878,15 +934,30 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U oldlittle = little; if (s < bigend) { const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + const unsigned char lastc = *little; I32 tmp; top2: if ((tmp = table[*s])) { - if ((s += tmp) < bigend) - goto top2; - goto check_end; + /* *s != lastc; earliest position it could match now is + * tmp slots further on */ + if ((s += tmp) >= bigend) + goto check_end; + if (LIKELY(*s != lastc)) { + s++; + s = (unsigned char *)memchr((void*)s, lastc, bigend - s); + if (!s) { + s = bigend; + goto check_end; + } + goto top2; + } } - else { /* less expensive than calling strncmp() */ + + + /* hand-rolled strncmp(): less expensive than calling the + * real function (maybe???) */ + { unsigned char * const olds = s; tmp = littlelen; @@ -913,10 +984,12 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } + /* =for apidoc foldEQ -Returns true if the leading len bytes of the strings s1 and s2 are the same +Returns true if the leading C bytes of the strings C and C are the +same case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes match themselves and their opposite case counterparts. Non-cased and non-ASCII range bytes match only themselves. @@ -969,8 +1042,8 @@ Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) /* =for apidoc foldEQ_locale -Returns true if the leading len bytes of the strings s1 and s2 are the same -case-insensitively in the current locale; false otherwise. +Returns true if the leading C bytes of the strings C and C are the +same case-insensitively in the current locale; false otherwise. =cut */ @@ -1097,7 +1170,7 @@ Perl_savesharedpv(pTHX_ const char *pv) =for apidoc savesharedpvn A version of C which allocates the duplicate string in memory -which is shared between threads. (With the specific difference that a NULL +which is shared between threads. (With the specific difference that a C pointer is not acceptable) =cut @@ -1304,7 +1377,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, if (o->op_flags & OPf_KIDS) { const OP *kid; - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -1358,11 +1431,13 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR) { char *ws; - int wi; + UV wi; /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */ - if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) && - (wi = grok_atou(ws, NULL)) > 0) { - Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1); + if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) + && grok_atoUV(ws, &wi, NULL) + && wi <= PERL_INT_MAX + ) { + Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1); } } #endif @@ -1397,7 +1472,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) */ const COP *cop = - closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE); + closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1429,7 +1504,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) =for apidoc Am|SV *|vmess|const char *pat|va_list *args C and C are a sprintf-style format pattern and encapsulated -argument list. These are used to generate a string message. If the +argument list, respectively. These are used to generate a string message. If +the message does not end with a newline, then it will be extended with some indication of the current location in the code, as described for L. @@ -1514,6 +1590,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) SV *exarg; ENTER; + save_re_context(); if (warn) { SAVESPTR(*hook); *hook = NULL; @@ -1922,7 +1999,10 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { dVAR; PERL_ARGS_ASSERT_VWARNER; - if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { + if ( + (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && + !(PL_in_eval & EVAL_KEEPERR) + ) { SV * const msv = vmess(pat, args); if (PL_parser && PL_parser->error_count) { @@ -2030,6 +2110,9 @@ void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; +#ifdef __amigaos4__ + amigaos4_obtain_environ(__FUNCTION__); +#endif #ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) @@ -2071,7 +2154,11 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) environ[i] = environ[i+1]; i++; } +#ifdef __amigaos4__ + goto my_setenv_out; +#else return; +#endif } if (!environ[i]) { /* does not exist yet */ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); @@ -2091,7 +2178,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. */ -# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) +# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN) # if defined(HAS_UNSETENV) if (val == NULL) { (void)unsetenv(nam); @@ -2132,6 +2219,10 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) } #endif } +#ifdef __amigaos4__ +my_setenv_out: + amigaos4_release_environ(__FUNCTION__); +#endif } #else /* WIN32 || NETWARE */ @@ -2310,7 +2401,7 @@ vsprintf(char *dest, const char *pat, void *args) PerlIO * Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) int p[2]; I32 This, that; Pid_t pid; @@ -2354,7 +2445,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) /* Close parent's end of error status pipe (if any) */ if (did_pipes) { PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) /* Close error pipe automatically if exec works */ if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) return NULL; @@ -2448,8 +2539,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) #endif } - /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) + /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */ +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2623,6 +2714,15 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) /* this is called in parent before the fork() */ void Perl_atfork_lock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_ACQUIRE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_ACQUIRE(PL_malloc_mutex) +# endif + PERL_TSA_ACQUIRE(PL_op_mutex) +#endif { #if defined(USE_ITHREADS) dVAR; @@ -2640,6 +2740,15 @@ Perl_atfork_lock(void) /* this is called in both parent and child after the fork() */ void Perl_atfork_unlock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_RELEASE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_RELEASE(PL_malloc_mutex) +# endif + PERL_TSA_RELEASE(PL_op_mutex) +#endif { #if defined(USE_ITHREADS) dVAR; @@ -2669,6 +2778,8 @@ Perl_my_fork(void) pid = fork(); #endif return pid; +#elif defined(__amigaos4__) + return amigaos_fork(); #else /* this "canna happen" since nothing should be calling here if !HAS_FORK */ Perl_croak_nocontext("fork() not available"); @@ -2868,7 +2979,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2966,7 +3077,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) *statusp = SvIVX(sv); /* The hash iterator is currently on this entry, so simply calling hv_delete would trigger the lazy delete, which on - aggregate does more work, beacuse next call to hv_iterinit() + aggregate does more work, because next call to hv_iterinit() would spot the flag, and have to call the delete routine, while in the meantime any new entries can't re-use that memory. */ @@ -3028,7 +3139,10 @@ S_pidgone(pTHX_ Pid_t pid, int status) } #endif -#if defined(OS2) +#if defined(OS2) || defined(__amigaos4__) +# if defined(__amigaos4__) && defined(pclose) +# undef pclose +# endif int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -3214,6 +3328,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) { + Stat_t statbuf; if (deftypes) { deftypes = 0; *tmpbuf = '\0'; @@ -3240,13 +3355,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0 - && !S_ISDIR(PL_statbuf.st_mode)) { - dosearch = 0; - scriptname = cur; + { + Stat_t statbuf; + if (PerlLIO_stat(cur,&statbuf) >= 0 + && !S_ISDIR(statbuf.st_mode)) { + dosearch = 0; + scriptname = cur; #ifdef SEARCH_EXTS - break; + break; #endif + } } #ifdef SEARCH_EXTS if (cur == scriptname) { @@ -3272,6 +3390,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, bufend = s + strlen(s); while (s < bufend) { + Stat_t statbuf; # ifdef DOSISH for (len = 0; *s && *s != ';'; len++, s++) { @@ -3308,8 +3427,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); - retval = PerlLIO_stat(tmpbuf,&PL_statbuf); - if (S_ISDIR(PL_statbuf.st_mode)) { + retval = PerlLIO_stat(tmpbuf,&statbuf); + if (S_ISDIR(statbuf.st_mode)) { retval = -1; } #ifdef SEARCH_EXTS @@ -3320,10 +3439,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif if (retval < 0) continue; - if (S_ISREG(PL_statbuf.st_mode) - && cando(S_IRUSR,TRUE,&PL_statbuf) + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) #if !defined(DOSISH) - && cando(S_IXUSR,TRUE,&PL_statbuf) + && cando(S_IXUSR,TRUE,&statbuf) #endif ) { @@ -3334,11 +3453,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 - || S_ISDIR(PL_statbuf.st_mode))) + { + Stat_t statbuf; + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&statbuf) < 0 + || S_ISDIR(statbuf.st_mode))) +#endif + seen_dot = 1; /* Disable message. */ +#ifndef DOSISH + } #endif - seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ /* diag_listed_as: Can't execute %s */ @@ -3928,7 +4052,7 @@ return FALSE =for apidoc getcwd_sv -Fill the sv with current working directory +Fill C with current working directory =cut */ @@ -3936,7 +4060,7 @@ Fill the sv with current working directory /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. * rewritten again by dougm, optimized for use with xs TARG, and to prefer * getcwd(3) if available - * Comments from the orignal: + * Comments from the original: * This is a faster version of getcwd. It's also more dangerous * because you might chdir out of a directory that you can't chdir * back into. */ @@ -4359,7 +4483,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { Dummy routine which "shares" an SV when there is no sharing module present. Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument. -Exists to avoid test for a NULL function pointer and because it could +Exists to avoid test for a C function pointer and because it could potentially warn under some level of strict-ness. =cut @@ -4378,7 +4502,7 @@ Perl_sv_nosharing(pTHX_ SV *sv) Dummy routine which reports that object can be destroyed when there is no sharing module present. It ignores its single SV argument, and returns -'true'. Exists to avoid test for a NULL function pointer and because it +'true'. Exists to avoid test for a C function pointer and because it could potentially warn under some level of strict-ness. =cut @@ -4403,15 +4527,22 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { const char* endptr; - opt = (U32) grok_atou(p, &endptr); - p = endptr; - if (*p && *p != '\n' && *p != '\r') { - if(isSPACE(*p)) goto the_end_of_the_opts_parser; - else - Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); - } - } - else { + UV uv; + if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) { + opt = (U32)uv; + p = endptr; + if (p && *p && *p != '\n' && *p != '\r') { + if (isSPACE(*p)) + goto the_end_of_the_opts_parser; + else + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + } + else { + Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p); + } + } + else { for (; *p; p++) { switch (*p) { case PERL_UNICODE_STDIN: @@ -4492,16 +4623,10 @@ Perl_seed(pTHX) int fd; #endif U32 u; -#ifdef VMS - /* when[] = (low 32 bits, high 32 bits) of time since epoch - * in 100-ns units, typically incremented ever 10 ms. */ - unsigned int when[2]; -#else -# ifdef HAS_GETTIMEOFDAY +#ifdef HAS_GETTIMEOFDAY struct timeval when; -# else +#else Time_t when; -# endif #endif /* This test is an escape hatch, this symbol isn't set by Configure. */ @@ -4511,7 +4636,11 @@ Perl_seed(pTHX) * if there isn't enough entropy available. You can compile with * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there * is enough real entropy to fill the seed. */ -# define PERL_RANDOM_DEVICE "/dev/urandom" +# ifdef __amigaos4__ +# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4" +# else +# define PERL_RANDOM_DEVICE "/dev/urandom" +# endif #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { @@ -4523,17 +4652,12 @@ Perl_seed(pTHX) } #endif -#ifdef VMS - _ckvmssts(sys$gettim(when)); - u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; -#else -# ifdef HAS_GETTIMEOFDAY +#ifdef HAS_GETTIMEOFDAY PerlProc_gettimeofday(&when,NULL); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; -# else +#else (void)time(&when); u = (U32)SEED_C1 * when; -# endif #endif u += SEED_C3 * (U32)PerlProc_getpid(); u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); @@ -4712,14 +4836,14 @@ 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 default implementation, unless -DPERL_MEM_LOG_NOIMPL is also * given, and you supply your own implementation. * * 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 (grok_atou) + * \d+ - fd fd to write to : must be 1st (grok_atoUV) * 'm' - memlog was PERL_MEM_LOG=1 * 's' - svlog was PERL_SV_LOG=1 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 @@ -4788,9 +4912,15 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, { STRLEN len; const char* endptr; - int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */ - if (!fd) + int fd; + UV uv; + if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ + && uv && uv <= PERL_INT_MAX + ) { + fd = (int)uv; + } else { fd = PERL_MEM_LOG_FD; + } if (strchr(pmlenv, 't')) { len = my_snprintf(buf, sizeof(buf), @@ -4928,18 +5058,18 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) /* =for apidoc quadmath_format_single -quadmath_snprintf() is very strict about its format string and will -fail, returning -1, if the format is invalid. It acccepts exactly +C is very strict about its C string and will +fail, returning -1, if the format is invalid. It accepts exactly one format spec. -quadmath_format_single() checks that the intended single spec looks +C checks that the intended single spec looks sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, and has C before it. This is not a full "printf syntax check", just the basics. Returns the format if it is valid, NULL if not. -quadmath_format_single() can and will actually patch in the missing +C can and will actually patch in the missing C, if necessary. In this case it will return the modified copy of the format, B @@ -4977,18 +5107,18 @@ Perl_quadmath_format_single(const char* format) /* =for apidoc quadmath_format_needed -quadmath_format_needed() returns true if the format string seems to -contain at least one non-Q-prefixed %[efgaEFGA] format specifier, +C returns true if the C string seems to +contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier, or returns false otherwise. The format specifier detection is not complete printf-syntax detection, but it should catch most common cases. If true is returned, those arguments B in theory be processed -with quadmath_snprintf(), but in case there is more than one such +with C, but in case there is more than one such format specifier (see L), and if there is anything else beyond that one (even just a single byte), they -B be processed because quadmath_snprintf() is very strict, +B be processed because C is very strict, accepting only one format spec, and nothing else. In this case, the code should probably fail. @@ -5140,13 +5270,11 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap va_list apc; PERL_ARGS_ASSERT_MY_VSNPRINTF; -#ifndef HAS_VSNPRINTF - PERL_UNUSED_VAR(len); -#endif Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, apc); # endif va_end(apc); @@ -5154,6 +5282,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, ap); # endif #endif /* #ifdef NEED_VA_COPY */ @@ -5343,28 +5472,42 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* PERL_IMPLICIT_CONTEXT */ -/* The meaning of the varargs is determined U32 key arg. This is not a format - string. The U32 key is assembled with HS_KEY. - - v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and - otherwise "CV * cv" (boot xsub's CV *). v_my_perl will catch where a threaded - future perl526.dll calling IO.dll for example, and IO.dll was linked with - threaded perl524.dll, and both perl526.dll and perl524.dll are in %PATH and - the Win32 DLL loader sucessfully can load IO.dll into the process but - simultaniously it loaded a interp of a different version into the process, - and XS code will naturally pass SV*s created by perl524.dll for perl526.dll - to use through perl526.dll's my_perl->Istack_base. - - v_my_perl (v=void) can not be the first arg since then key will be out of - place in a threaded vs non-threaded mixup and analyzing the key number's - bitfields won't reveal the problem since it will be a valid key - (unthreaded perl) on interp side, but croak reports the XS mod's key as - gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl - and unthreaded XS module, threaded perl will look at uninit C stack or uninit - register to get var key (remember it assumes 1st arg is interp cxt). - -Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, -[U32 items, U32 ax], [char * api_version], [char * xs_version]) */ +/* Perl_xs_handshake(): + implement the various XS_*_BOOTCHECK macros, which are added to .c + files by ExtUtils::ParseXS, to check that the perl the module was built + with is binary compatible with the running perl. + + usage: + Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, + [U32 items, U32 ax], [char * api_version], [char * xs_version]) + + The meaning of the varargs is determined the U32 key arg (which is not + a format string). The fields of key are assembled by using HS_KEY(). + + Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type + "PerlInterpreter *" and represents the callers context; otherwise it is + of type "CV *", and is the boot xsub's CV. + + v_my_perl will catch where a threaded future perl526.dll calling IO.dll + for example, and IO.dll was linked with threaded perl524.dll, and both + perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader + successfully can load IO.dll into the process but simultaneously it + loaded an interpreter of a different version into the process, and XS + code will naturally pass SV*s created by perl524.dll for perl526.dll to + use through perl526.dll's my_perl->Istack_base. + + v_my_perl cannot be the first arg, since then 'key' will be out of + place in a threaded vs non-threaded mixup; and analyzing the key + number's bitfields won't reveal the problem, since it will be a valid + key (unthreaded perl) on interp side, but croak will report the XS mod's + key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if + it's a threaded perl and an unthreaded XS module, threaded perl will + look at an uninit C stack or an uninit register to get 'key' + (remember that it assumes that the 1st arg is the interp cxt). + + 'file' is the source filename of the caller. +*/ + I32 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) { @@ -5411,8 +5554,8 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) if(UNLIKELY(got != need)) { bad_handshake:/* recycle branch and string from above */ if(got != (void *)HSf_NOCHK) - noperl_die("%s: Invalid handshake key got %p" - " needed %p, binaries are mismatched", + noperl_die("%s: loadable library and perl binaries are mismatched" + " (got handshake key %p, needed %p)\n", file, got, need); } @@ -5420,7 +5563,9 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */ PL_xsubfilename = file; /* so the old name must be restored for additional XSUBs to register themselves */ - (void)gv_fetchfile(file); + /* XSUBs can't be perl lang/perl5db.pl debugged + if (PERLDB_LINE_OR_SAVESRC) + (void)gv_fetchfile(file); */ } if(key & HSf_POPMARK) { @@ -5451,15 +5596,16 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) U32 xsverlen; assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); if((xsverlen = HS_GETXSVERLEN(key))) - Perl_xs_version_bootcheck(aTHX_ + S_xs_version_bootcheck(aTHX_ items, ax, va_arg(args, char*), xsverlen); } va_end(args); return ax; } -void -Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, + +STATIC void +S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) { SV *sv; @@ -5661,7 +5807,7 @@ Perl_my_dirfd(DIR * dir) { return dir->dd_fd; #else Perl_croak_nocontext(PL_no_func, "dirfd"); - NOT_REACHED; /* NOT REACHED */ + NOT_REACHED; /* NOTREACHED */ return 0; #endif } @@ -5734,7 +5880,7 @@ Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) PERL_ARGS_ASSERT_DRAND48_INIT_R; #ifdef PERL_DRAND48_QUAD - *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16); + *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16); #else random_state->seed[0] = FREEBSD_DRAND48_SEED_0; random_state->seed[1] = (U16) seed; @@ -5805,6 +5951,9 @@ static void bfd_update(bfd_context* ctx, Dl_info* dl_info) /* BFD open and scan only if the filename changed. */ if (ctx->fname_prev == NULL || strNE(dl_info->dli_fname, ctx->fname_prev)) { + if (ctx->abfd) { + bfd_close(ctx->abfd); + } ctx->abfd = bfd_openr(dl_info->dli_fname, 0); if (ctx->abfd) { if (bfd_check_format(ctx->abfd, bfd_object)) { @@ -5973,6 +6122,8 @@ static const char* atos_parse(const char* p, const char* source_name_end; const char* source_line_end; const char* close_paren; + UV uv; + /* Skip trailing whitespace. */ while (p > start && isspace(*p)) p--; /* Now we should be at the close paren. */ @@ -5999,10 +6150,14 @@ static const char* atos_parse(const char* p, return NULL; p++; *source_name_size = source_name_end - p; - *source_line = grok_atou(source_number_start, &source_line_end); - if (source_line_end != close_paren) - return NULL; - return p; + if (grok_atoUV(source_number_start, &uv, &source_line_end) + && source_line_end == close_paren + && uv <= MAX_STRLEN + ) { + *source_line = (STRLEN)uv; + return p; + } + return NULL; } /* Given a raw frame, read a pipe from the symbolicator (that's the @@ -6085,10 +6240,10 @@ static void atos_symbolize(atos_context* ctx, =for apidoc get_c_backtrace Collects the backtrace (aka "stacktrace") into a single linear -malloced buffer, which the caller B Perl_free_c_backtrace(). +malloced buffer, which the caller B C. -Scans the frames back by depth + skip, then drops the skip innermost, -returning at most depth frames. +Scans the frames back by S>, then drops the C innermost, +returning at most C frames. =cut */ @@ -6301,6 +6456,9 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) } #ifdef USE_BFD Safefree(symbol_names); + if (bfd_ctx.abfd) { + bfd_close(bfd_ctx.abfd); + } #endif Safefree(source_lines); Safefree(source_name_sizes); @@ -6331,8 +6489,8 @@ Deallocates a backtrace received from get_c_bracktrace. /* =for apidoc get_c_backtrace_dump -Returns a SV a dump of |depth| frames of the call stack, skipping -the |skip| innermost ones. depth of 20 is usually enough. +Returns a SV containing a dump of C frames of the call stack, skipping +the C innermost ones. C of 20 is usually enough. The appended output looks like: @@ -6343,12 +6501,12 @@ The appended output looks like: The fields are tab-separated. The first column is the depth (zero being the innermost non-skipped frame). In the hex:offset, the hex is -where the program counter was in S_parse_body, and the :offset (might -be missing) tells how much inside the S_parse_body the program counter was. +where the program counter was in C, and the :offset (might +be missing) tells how much inside the C the program counter was. -The util.c:1716 is the source code file and line number. +The C is the source code file and line number. -The /usr/bin/perl is obvious (hopefully). +The F is obvious (hopefully). Unknowns are C<"-">. Unknowns can happen unfortunately quite easily: if the platform doesn't support retrieving the information; @@ -6414,7 +6572,7 @@ Perl_get_c_backtrace_dump(pTHX_ int depth, int skip) /* =for apidoc dump_c_backtrace -Dumps the C backtrace to the given fp. +Dumps the C backtrace to the given C. Returns true if a backtrace could be retrieved, false if not. @@ -6439,12 +6597,28 @@ Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip) #endif /* #ifdef USE_C_BACKTRACE */ +#ifdef PERL_TSA_ACTIVE + +/* pthread_mutex_t and perl_mutex are typedef equivalent + * so casting the pointers is fine. */ + +int perl_tsa_mutex_lock(perl_mutex* mutex) +{ + return pthread_mutex_lock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_unlock(perl_mutex* mutex) +{ + return pthread_mutex_unlock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_destroy(perl_mutex* mutex) +{ + return pthread_mutex_destroy((pthread_mutex_t *) mutex); +} + +#endif + /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */