X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1c1d7d5ba0bc33e7bea0a9aeb2d420fc5a8128ab..62e6d5d299c661f697b0236723418078b4b94071:/util.c diff --git a/util.c b/util.c index 53fcf17..76f6ef4 100644 --- a/util.c +++ b/util.c @@ -132,6 +132,7 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; + dSAVEDERRNO; #ifdef USE_MDH if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) @@ -143,6 +144,7 @@ Perl_safesysmalloc(MEM_SIZE size) Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); #endif if (!size) size = 1; /* malloc(0) is NASTY on our system */ + SAVE_ERRNO; #ifdef PERL_DEBUG_READONLY_COW if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { @@ -182,6 +184,11 @@ Perl_safesysmalloc(MEM_SIZE size) ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + /* malloc() can modify errno() even on success, but since someone + writing perl code doesn't have any control over when perl calls + malloc() we need to hide that. + */ + RESTORE_ERRNO; } else { #ifdef USE_MDH @@ -214,9 +221,6 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size : 0; #endif -#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) - Malloc_t PerlMem_realloc(); -#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ if (!size) { safesysfree(where); @@ -226,6 +230,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) ptr = safesysmalloc(size); } else { + dSAVE_ERRNO; #ifdef USE_MDH where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) @@ -299,6 +304,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) maybe_protect_ro(header->prev); #endif ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + + /* realloc() can modify errno() even on success, but since someone + writing perl code doesn't have any control over when perl calls + realloc() we need to hide that. + */ + RESTORE_ERRNO; } /* In particular, must do that fixup above before logging anything via @@ -442,7 +453,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size)); if (ptr != NULL) { #ifdef USE_MDH { @@ -580,7 +591,7 @@ Perl_delimcpy_no_escape(char *to, const char *toend, const char *from, /* =head1 Miscellaneous Functions -=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end +=for apidoc ninstr Find the first (leftmost) occurrence of a sequence of bytes within another sequence. This is the Perl version of C, extended to handle @@ -641,7 +652,7 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char /* =head1 Miscellaneous Functions -=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end +=for apidoc rninstr Like C>, but instead finds the final (rightmost) occurrence of a sequence of bytes within another sequence, returning C if there is no @@ -693,7 +704,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 C +Analyzes the string in order to make fast searches on it using C -- the Boyer-Moore algorithm. =cut @@ -1276,7 +1287,7 @@ Perl_vform(pTHX_ const char *pat, va_list *args) } /* -=for apidoc Am|SV *|mess|const char *pat|... +=for apidoc mess Take a sprintf-style format pattern and argument list. These are used to generate a string message. If the message does not end with a newline, @@ -1357,7 +1368,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, } /* -=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume +=for apidoc mess_sv Expands a message, intended for the user, to include an indication of the current location in the code, if the message does not already appear @@ -1461,7 +1472,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) } /* -=for apidoc Am|SV *|vmess|const char *pat|va_list *args +=for apidoc vmess C and C are a sprintf-style format pattern and encapsulated argument list, respectively. These are used to generate a string message. If @@ -1530,6 +1541,7 @@ S_with_queued_errors(pTHX_ SV *ex) STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { + dVAR; HV *stash; GV *gv; CV *cv; @@ -1537,7 +1549,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) /* sv_2cv might call Perl_croak() or Perl_warner() */ SV * const oldhook = *hook; - if (!oldhook) + if (!oldhook || oldhook == PERL_WARNHOOK_FATAL) return FALSE; ENTER; @@ -1572,7 +1584,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) } /* -=for apidoc Am|OP *|die_sv|SV *baseex +=for apidoc die_sv Behaves the same as L, except for the return type. It should be used only where the C return type is required. @@ -1581,13 +1593,8 @@ The function never actually returns. =cut */ -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die_sv(pTHX_ SV *baseex) { @@ -1596,12 +1603,10 @@ Perl_die_sv(pTHX_ SV *baseex) /* NOTREACHED */ NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE /* -=for apidoc Am|OP *|die|const char *pat|... +=for apidoc die Behaves the same as L, except for the return type. It should be used only where the C return type is required. @@ -1611,13 +1616,9 @@ The function never actually returns. */ #if defined(PERL_IMPLICIT_CONTEXT) -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif + +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die_nocontext(const char* pat, ...) { @@ -1629,18 +1630,12 @@ Perl_die_nocontext(const char* pat, ...) va_end(args); NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE + #endif /* PERL_IMPLICIT_CONTEXT */ -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die(pTHX_ const char* pat, ...) { @@ -1651,12 +1646,10 @@ Perl_die(pTHX_ const char* pat, ...) va_end(args); NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE /* -=for apidoc Am|void|croak_sv|SV *baseex +=for apidoc croak_sv This is an XS interface to Perl's C function. @@ -1686,7 +1679,7 @@ Perl_croak_sv(pTHX_ SV *baseex) } /* -=for apidoc Am|void|vcroak|const char *pat|va_list *args +=for apidoc vcroak This is an XS interface to Perl's C function. @@ -1719,7 +1712,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } /* -=for apidoc Am|void|croak|const char *pat|... +=for apidoc croak This is an XS interface to Perl's C function. @@ -1766,7 +1759,7 @@ Perl_croak(pTHX_ const char *pat, ...) } /* -=for apidoc Am|void|croak_no_modify +=for apidoc croak_no_modify Exactly equivalent to C, but generates terser object code than using C. Less code used on exception code @@ -1809,7 +1802,7 @@ Perl_croak_popstack(void) } /* -=for apidoc Am|void|warn_sv|SV *baseex +=for apidoc warn_sv This is an XS interface to Perl's C function. @@ -1837,7 +1830,7 @@ Perl_warn_sv(pTHX_ SV *baseex) } /* -=for apidoc Am|void|vwarn|const char *pat|va_list *args +=for apidoc vwarn This is an XS interface to Perl's C function. @@ -1865,7 +1858,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } /* -=for apidoc Am|void|warn|const char *pat|... +=for apidoc warn This is an XS interface to Perl's C function. @@ -2063,151 +2056,216 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, Copy(val, s+(nlen+1), vlen, char); \ *(s+(nlen+1+vlen)) = '\0' + + #ifdef USE_ENVIRON_ARRAY - /* VMS' my_setenv() is in vms.c */ -#if !defined(WIN32) && !defined(NETWARE) +/* NB: VMS' my_setenv() is in vms.c */ + +/* Configure doesn't test for HAS_SETENV yet, so decide based on platform. + * 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)) || defined(PERL_DARWIN) +# define MY_HAS_SETENV +# endif + +/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if + * 'current' is non-null, with up to three sizes that are added together. + * It handles integer overflow. + */ +# ifndef MY_HAS_SETENV +static char * +S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size) +{ + void *p; + Size_t sl, l = l1 + l2; + + if (l < l2) + goto panic; + l += l3; + if (l < l3) + goto panic; + sl = l * size; + if (sl < l) + goto panic; + + p = current + ? safesysrealloc(current, sl) + : safesysmalloc(sl); + if (p) + return (char*)p; + + panic: + croak_memory_wrap(); +} +# endif + + +# if !defined(WIN32) && !defined(NETWARE) + +/* +=for apidoc my_setenv + +A wrapper for the C library L. Don't use the latter, as the perl +version has desirable safeguards + +=cut +*/ + void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; -#ifdef __amigaos4__ +# ifdef __amigaos4__ amigaos4_obtain_environ(__FUNCTION__); -#endif -#ifdef USE_ITHREADS +# endif + +# ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) -#endif +# endif { -#ifndef PERL_USE_SAFE_PUTENV + +# ifndef PERL_USE_SAFE_PUTENV if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ - I32 i; - const I32 len = strlen(nam); - int nlen, vlen; + UV i; + Size_t vlen, nlen = strlen(nam); /* where does it go? */ for (i = 0; environ[i]; i++) { - if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=') break; } if (environ == PL_origenviron) { /* need we copy environment? */ - I32 j; - I32 max; + UV j, max; char **tmpenv; max = i; while (environ[max]) max++; - tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); + + /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */ + tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*)); + for (j=0; j= 0) { - while (len--) - *to++ = *from++; - } - else { - to += len; - from += len; - while (len--) - *(--to) = *(--from); - } -#endif - - return vto; -} -#endif - -/* this is a drop-in replacement for memcmp() */ -#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) -int -Perl_my_memcmp(const void *vs1, const void *vs2, size_t len) -{ - const U8 *a = (const U8 *)vs1; - const U8 *b = (const U8 *)vs2; - int tmp; - - PERL_ARGS_ASSERT_MY_MEMCMP; - - while (len--) { - if ((tmp = *a++ - *b++)) - return tmp; - } - return 0; -} -#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ - -#ifndef HAS_VPRINTF -/* This vsprintf replacement should generally never get used, since - vsprintf was available in both System V and BSD 2.11. (There may - be some cross-compilation or embedded set-ups where it is needed, - however.) - - If you encounter a problem in this function, it's probably a symptom - that Configure failed to detect your system's vprintf() function. - See the section on "item vsprintf" in the INSTALL file. - - This version may compile on systems with BSD-ish , - but probably won't on others. -*/ - -#ifdef USE_CHAR_VSPRINTF -char * -#else -int -#endif -vsprintf(char *dest, const char *pat, void *args) -{ - FILE fakebuf; - -#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) - FILE_ptr(&fakebuf) = (STDCHAR *) dest; - FILE_cnt(&fakebuf) = 32767; -#else - /* These probably won't compile -- If you really need - this, you'll have to figure out some other method. */ - fakebuf._ptr = dest; - fakebuf._cnt = 32767; -#endif -#ifndef _IOSTRG -#define _IOSTRG 0 -#endif - fakebuf._flag = _IOWRT|_IOSTRG; - _doprnt(pat, args, &fakebuf); /* what a kludge */ -#if defined(STDIO_PTR_LVALUE) - *(FILE_ptr(&fakebuf)++) = '\0'; -#else - /* PerlIO has probably #defined away fputc, but we want it here. */ -# ifdef fputc -# undef fputc /* XXX Should really restore it later */ -# endif - (void)fputc('\0', &fakebuf); -#endif -#ifdef USE_CHAR_VSPRINTF - return(dest); -#else - return 0; /* perl doesn't use return value */ -#endif -} - -#endif /* HAS_VPRINTF */ - PerlIO * Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { @@ -2347,10 +2301,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) taint_env(); taint_proper("Insecure %s%s", "EXEC"); } - if (PerlProc_pipe(p) < 0) + if (PerlProc_pipe_cloexec(p) < 0) return NULL; /* Try for another pipe pair for error return */ - if (PerlProc_pipe(pp) >= 0) + if (PerlProc_pipe_cloexec(pp) >= 0) did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { @@ -2372,14 +2326,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) #define THIS that #define THAT This /* Close parent's end of error status pipe (if any) */ - if (did_pipes) { + if (did_pipes) PerlLIO_close(pp[0]); -#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; -#endif - } /* Now dup our end of _the_ pipe to right position */ if (p[THIS] != (*mode == 'r')) { PerlLIO_dup2(p[THIS], *mode == 'r'); @@ -2387,8 +2335,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ } - else + else { + setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ + } #if !defined(HAS_FCNTL) || !defined(F_SETFD) /* No automatic close - do it by hand */ # ifndef NOFILE @@ -2409,12 +2359,11 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on fork */ if (did_pipes) PerlLIO_close(pp[1]); /* Keep the lower of the two fd numbers */ if (p[that] < p[This]) { - PerlLIO_dup2(p[This], p[that]); + PerlLIO_dup2_cloexec(p[This], p[that]); PerlLIO_close(p[This]); p[This] = p[that]; } @@ -2494,9 +2443,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) taint_env(); taint_proper("Insecure %s%s", "EXEC"); } - if (PerlProc_pipe(p) < 0) + if (PerlProc_pipe_cloexec(p) < 0) return NULL; - if (doexec && PerlProc_pipe(pp) >= 0) + if (doexec && PerlProc_pipe_cloexec(pp) >= 0) did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { @@ -2519,21 +2468,18 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #undef THAT #define THIS that #define THAT This - if (did_pipes) { + if (did_pipes) PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) - return NULL; -#endif - } if (p[THIS] != (*mode == 'r')) { PerlLIO_dup2(p[THIS], *mode == 'r'); PerlLIO_close(p[THIS]); if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ PerlLIO_close(p[THAT]); } - else + else { + setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); PerlLIO_close(p[THAT]); + } #ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) @@ -2568,11 +2514,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on vfork */ if (did_pipes) PerlLIO_close(pp[1]); if (p[that] < p[This]) { - PerlLIO_dup2(p[This], p[that]); + PerlLIO_dup2_cloexec(p[This], p[that]); PerlLIO_close(p[This]); p[This] = p[that]; } @@ -2613,8 +2558,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); } -#else -#if defined(DJGPP) +#elif defined(DJGPP) FILE *djgpp_popen(); PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) @@ -2626,15 +2570,12 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) */ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); } -#else -#if defined(__LIBCATAMOUNT__) +#elif defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { return NULL; } -#endif -#endif #endif /* !DOSISH */ @@ -2751,6 +2692,15 @@ dup2(int oldfd, int newfd) #ifndef PERL_MICRO #ifdef HAS_SIGACTION +/* +=for apidoc rsignal + +A wrapper for the C library L. Don't use the latter, as the Perl +version knows things that interact with the rest of the perl interpreter. + +=cut +*/ + Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { @@ -2952,14 +2902,12 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) : 0 ); } -#else -#if defined(__LIBCATAMOUNT__) +#elif defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { return -1; } -#endif #endif /* !DOSISH */ #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) @@ -3412,16 +3360,14 @@ Perl_get_context(void) dVAR; # ifdef OLD_PTHREADS_API pthread_addr_t t; - int error = pthread_getspecific(PL_thr_key, &t) + int error = pthread_getspecific(PL_thr_key, &t); if (error) Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); return (void*)t; -# else -# ifdef I_MACH_CTHREADS +# elif defined(I_MACH_CTHREADS) return (void*)cthread_data(cthread_self()); -# else +# else return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); -# endif # endif #else return (void*)NULL; @@ -3537,23 +3483,15 @@ Perl_my_fflush_all(pTHX) long open_max = -1; # ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; -# else -# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) +# elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); -# else -# ifdef FOPEN_MAX +# elif defined(FOPEN_MAX) open_max = FOPEN_MAX; -# else -# ifdef OPEN_MAX +# elif defined(OPEN_MAX) open_max = OPEN_MAX; -# else -# ifdef _NFILE +# elif defined(_NFILE) open_max = _NFILE; -# endif -# endif -# endif -# endif -# endif +# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -3918,9 +3856,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in buflen = 64; Newx(buf, buflen, char); - GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ len = strftime(buf, buflen, fmt, &mytm); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; /* ** The following is needed to handle to the situation where @@ -3946,9 +3884,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in Renew(buf, bufsize, char); while (buf) { - GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ buflen = strftime(buf, bufsize, fmt, &mytm); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; if (buflen > 0 && buflen < bufsize) break; @@ -4314,6 +4252,10 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { return -1; } +#ifdef SOCK_CLOEXEC + type &= ~SOCK_CLOEXEC; +#endif + #ifdef EMULATE_SOCKETPAIR_UDP if (type == SOCK_DGRAM) return S_socketpair_udp(fd); @@ -4373,12 +4315,10 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { abort_tidy_up_and_fail: #ifdef ECONNABORTED errno = ECONNABORTED; /* This would be the standard thing to do. */ -#else -# ifdef ECONNREFUSED +#elif defined(ECONNREFUSED) errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ -# else +#else errno = ETIMEDOUT; /* Desperation time. */ -# endif #endif tidy_up_and_fail: { @@ -4456,7 +4396,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { - const char* endptr; + const char* endptr = p + strlen(p); UV uv; if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) { opt = (U32)uv; @@ -4572,7 +4512,7 @@ Perl_seed(pTHX) # define PERL_RANDOM_DEVICE "/dev/urandom" # endif #endif - fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0); if (fd != -1) { if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) u = 0; @@ -4843,7 +4783,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, * timeval. */ { STRLEN len; - const char* endptr; + const char* endptr = pmlenv + strlen(pmlenv); int fd; UV uv; if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ @@ -4972,28 +4912,6 @@ Perl_mem_log_del_sv(const SV *sv, #endif /* PERL_MEM_LOG */ /* -=for apidoc my_sprintf - -The C library C, wrapped if necessary, to ensure that it will return -the length of the string written to the buffer. Only rare pre-ANSI systems -need the wrapper function - usually this is a direct call to C. - -=cut -*/ -#ifndef SPRINTF_RETURNS_STRLEN -int -Perl_my_sprintf(char *buffer, const char* pat, ...) -{ - va_list args; - PERL_ARGS_ASSERT_MY_SPRINTF; - va_start(args, pat); - vsprintf(buffer, pat, args); - va_end(args); - return strlen(buffer); -} -#endif - -/* =for apidoc quadmath_format_single C is very strict about its C string and will @@ -5031,7 +4949,7 @@ Perl_quadmath_format_single(const char* format) return NULL; if (format[len - 2] != 'Q') { char* fixed; - Newx(fixed, len + 1, char); + Newx(fixed, len + 2, char); memcpy(fixed, format, len - 1); fixed[len - 1] = 'Q'; fixed[len ] = format[len - 1]; @@ -5179,7 +5097,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) #ifdef HAS_VSNPRINTF /* vsnprintf() shows failure with >= len */ || - (len > 0 && (Size_t)retval >= len) + (len > 0 && (Size_t)retval >= len) #endif ) Perl_croak_nocontext("panic: my_snprintf buffer overflow"); @@ -5235,7 +5153,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap #ifdef HAS_VSNPRINTF /* vsnprintf() shows failure with >= len */ || - (len > 0 && (Size_t)retval >= len) + (len > 0 && (Size_t)retval >= len) #endif ) Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); @@ -5299,50 +5217,12 @@ Perl_my_clearenv(pTHX) #ifdef PERL_IMPLICIT_CONTEXT -/* Implements the MY_CXT_INIT macro. The first time a module is loaded, -the global PL_my_cxt_index is incremented, and that value is assigned to -that module's static my_cxt_index (who's address is passed as an arg). -Then, for each interpreter this function is called for, it makes sure a -void* slot is available to hang the static data off, by allocating or -extending the interpreter's PL_my_cxt_list array */ - -#ifndef PERL_GLOBAL_STRUCT_PRIVATE -void * -Perl_my_cxt_init(pTHX_ int *index, size_t size) -{ - dVAR; - void *p; - PERL_ARGS_ASSERT_MY_CXT_INIT; - if (*index == -1) { - /* this module hasn't been allocated an index yet */ - MUTEX_LOCK(&PL_my_ctx_mutex); - *index = PL_my_cxt_index++; - MUTEX_UNLOCK(&PL_my_ctx_mutex); - } - - /* make sure the array is big enough */ - if (PL_my_cxt_size <= *index) { - if (PL_my_cxt_size) { - IV new_size = PL_my_cxt_size; - while (new_size <= *index) - new_size *= 2; - Renew(PL_my_cxt_list, new_size, void *); - PL_my_cxt_size = new_size; - } - else { - PL_my_cxt_size = 16; - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - } - } - /* newSV() allocates one more than needed */ - p = (void*)SvPVX(newSV(size-1)); - PL_my_cxt_list[*index] = p; - Zero(p, size, char); - return p; -} -#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +/* rather than each module having a static var holding its index, + * use a global array of name to index mappings + */ int Perl_my_cxt_index(pTHX_ const char *my_cxt_key) { @@ -5361,9 +5241,22 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key) } return -1; } +# endif + + +/* Implements the MY_CXT_INIT macro. The first time a module is loaded, +the global PL_my_cxt_index is incremented, and that value is assigned to +that module's static my_cxt_index (who's address is passed as an arg). +Then, for each interpreter this function is called for, it makes sure a +void* slot is available to hang the static data off, by allocating or +extending the interpreter's PL_my_cxt_list array */ void * +# ifdef PERL_GLOBAL_STRUCT_PRIVATE Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) +# else +Perl_my_cxt_init(pTHX_ int *indexp, size_t size) +# endif { dVAR; void *p; @@ -5371,44 +5264,81 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) PERL_ARGS_ASSERT_MY_CXT_INIT; +# ifdef PERL_GLOBAL_STRUCT_PRIVATE index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif + /* do initial check without locking. + * -1: not allocated or another thread currently allocating + * other: already allocated by another thread + */ if (index == -1) { - /* this module hasn't been allocated an index yet */ MUTEX_LOCK(&PL_my_ctx_mutex); - index = PL_my_cxt_index++; + /*now a stricter check with locking */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif + if (index == -1) + /* this module hasn't been allocated an index yet */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + index = PL_my_cxt_index++; + + /* Store the index in a global MY_CXT_KEY string to index mapping + * table. This emulates the perl-module static my_cxt_index var on + * builds which don't allow static vars */ + if (PL_my_cxt_keys_size <= index) { + int old_size = PL_my_cxt_keys_size; + int i; + if (PL_my_cxt_keys_size) { + IV new_size = PL_my_cxt_keys_size; + while (new_size <= index) + new_size *= 2; + PL_my_cxt_keys = (const char **)PerlMemShared_realloc( + PL_my_cxt_keys, + new_size * sizeof(const char *)); + PL_my_cxt_keys_size = new_size; + } + else { + PL_my_cxt_keys_size = 16; + PL_my_cxt_keys = (const char **)PerlMemShared_malloc( + PL_my_cxt_keys_size * sizeof(const char *)); + } + for (i = old_size; i < PL_my_cxt_keys_size; i++) { + PL_my_cxt_keys[i] = 0; + } + } + PL_my_cxt_keys[index] = my_cxt_key; +# else + *indexp = PL_my_cxt_index++; + index = *indexp; +# endif MUTEX_UNLOCK(&PL_my_ctx_mutex); } /* make sure the array is big enough */ if (PL_my_cxt_size <= index) { - int old_size = PL_my_cxt_size; - int i; if (PL_my_cxt_size) { IV new_size = PL_my_cxt_size; while (new_size <= index) new_size *= 2; Renew(PL_my_cxt_list, new_size, void *); - Renew(PL_my_cxt_keys, new_size, const char *); PL_my_cxt_size = new_size; } else { PL_my_cxt_size = 16; Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); - } - for (i = old_size; i < PL_my_cxt_size; i++) { - PL_my_cxt_keys[i] = 0; - PL_my_cxt_list[i] = 0; } } - PL_my_cxt_keys[index] = my_cxt_key; /* newSV() allocates one more than needed */ p = (void*)SvPVX(newSV(size-1)); PL_my_cxt_list[index] = p; Zero(p, size, char); return p; } -#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + #endif /* PERL_IMPLICIT_CONTEXT */ @@ -5666,6 +5596,36 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size) } #endif +/* +=for apidoc my_strnlen + +The C library C if available, or a Perl implementation of it. + +C computes the length of the string, up to C +characters. It will will never attempt to address more than C +characters, making it suitable for use with strings that are not +guaranteed to be NUL-terminated. + +=cut + +Description stolen from http://man.openbsd.org/strnlen.3, +implementation stolen from PostgreSQL. +*/ +#ifndef HAS_STRNLEN +Size_t +Perl_my_strnlen(const char *str, Size_t maxlen) +{ + const char *p = str; + + PERL_ARGS_ASSERT_MY_STRNLEN; + + while(maxlen-- && *p) + p++; + + return p - str; +} +#endif + #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) /* VC7 or 7.1, building with pre-VC7 runtime libraries. */ long _ftol( double ); /* Defined by VC6 C libs. */ @@ -5759,24 +5719,27 @@ Perl_my_dirfd(DIR * dir) { #endif } -#ifndef HAS_MKSTEMP +#if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP) #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789" #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1) -int -Perl_my_mkstemp(char *templte) { +static int +S_my_mkostemp(char *templte, int flags) { dTHX; STRLEN len = strlen(templte); int fd; int attempts = 0; +#ifdef VMS + int delete_on_close = flags & O_VMS_DELETEONCLOSE; - PERL_ARGS_ASSERT_MY_MKSTEMP; + flags &= ~O_VMS_DELETEONCLOSE; +#endif if (len < 6 || templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' || templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') { - errno = EINVAL; + SETERRNO(EINVAL, LIB_INVARG); return -1; } @@ -5785,7 +5748,15 @@ Perl_my_mkstemp(char *templte) { for (i = 1; i <= 6; ++i) { templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)]; } - fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL, 0600); +#ifdef VMS + if (delete_on_close) { + fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt"); + } + else +#endif + { + fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); + } } while (fd == -1 && errno == EEXIST && ++attempts <= 100); return fd; @@ -5793,6 +5764,24 @@ Perl_my_mkstemp(char *templte) { #endif +#ifndef HAS_MKOSTEMP +int +Perl_my_mkostemp(char *templte, int flags) +{ + PERL_ARGS_ASSERT_MY_MKOSTEMP; + return S_my_mkostemp(templte, flags); +} +#endif + +#ifndef HAS_MKSTEMP +int +Perl_my_mkstemp(char *templte) +{ + PERL_ARGS_ASSERT_MY_MKSTEMP; + return S_my_mkostemp(templte, 0); +} +#endif + REGEXP * Perl_get_re_arg(pTHX_ SV *sv) { @@ -5833,9 +5822,9 @@ Perl_get_re_arg(pTHX_ SV *sv) { #ifdef PERL_DRAND48_QUAD -#define DRAND48_MULT U64_CONST(0x5deece66d) +#define DRAND48_MULT UINT64_C(0x5deece66d) #define DRAND48_ADD 0xb -#define DRAND48_MASK U64_CONST(0xffffffffffff) +#define DRAND48_MASK UINT64_C(0xffffffffffff) #else @@ -6101,7 +6090,7 @@ static const char* atos_parse(const char* p, * The matched regular expression is roughly "\(.*:\d+\)\s*$" */ const char* source_number_start; const char* source_name_end; - const char* source_line_end; + const char* source_line_end = start; const char* close_paren; UV uv; @@ -6454,8 +6443,8 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) Safefree(raw_frames); return bt; #else - PERL_UNUSED_ARGV(depth); - PERL_UNUSED_ARGV(skip); + PERL_UNUSED_ARG(depth); + PERL_UNUSED_ARG(skip); return NULL; #endif }