dTHX;
#endif
Malloc_t ptr;
+ dSAVEDERRNO;
#ifdef USE_MDH
if (size + PERL_MEMORY_DEBUG_HEADER_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) {
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
? ((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);
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)
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
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
{
/*
=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<strstr()>, extended to handle
/*
=head1 Miscellaneous Functions
-=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
+=for apidoc rninstr
Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
sequence of bytes within another sequence, returning C<NULL> if there is no
=for apidoc fbm_compile
-Analyses the string in order to make fast searches on it using C<fbm_instr()>
+Analyzes the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.
=cut
}
/*
-=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,
}
/*
-=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
}
/*
-=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+=for apidoc vmess
C<pat> and C<args> are a sprintf-style format pattern and encapsulated
argument list, respectively. These are used to generate a string message. If
STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
+ dVAR;
HV *stash;
GV *gv;
CV *cv;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- if (!oldhook)
+ if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
return FALSE;
ENTER;
}
/*
-=for apidoc Am|OP *|die_sv|SV *baseex
+=for apidoc die_sv
Behaves the same as L</croak_sv>, except for the return type.
It should be used only where the C<OP *> return type is required.
=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)
{
/* 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</croak>, except for the return type.
It should be used only where the C<OP *> return type is required.
*/
#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, ...)
{
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, ...)
{
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<die> function.
}
/*
-=for apidoc Am|void|vcroak|const char *pat|va_list *args
+=for apidoc vcroak
This is an XS interface to Perl's C<die> function.
}
/*
-=for apidoc Am|void|croak|const char *pat|...
+=for apidoc croak
This is an XS interface to Perl's C<die> function.
}
/*
-=for apidoc Am|void|croak_no_modify
+=for apidoc croak_no_modify
Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
terser object code than using C<Perl_croak>. Less code used on exception code
}
/*
-=for apidoc Am|void|warn_sv|SV *baseex
+=for apidoc warn_sv
This is an XS interface to Perl's C<warn> function.
}
/*
-=for apidoc Am|void|vwarn|const char *pat|va_list *args
+=for apidoc vwarn
This is an XS interface to Perl's C<warn> function.
}
/*
-=for apidoc Am|void|warn|const char *pat|...
+=for apidoc warn
This is an XS interface to Perl's C<warn> function.
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<setenv(3)>. 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<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ const Size_t len = strlen(environ[j]);
+ tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
Copy(environ[j], tmpenv[j], len+1, char);
}
+
tmpenv[max] = NULL;
environ = tmpenv; /* tell exec where it is now */
}
+
if (!val) {
safesysfree(environ[i]);
while (environ[i]) {
environ[i] = environ[i+1];
i++;
}
-#ifdef __amigaos4__
+# ifdef __amigaos4__
goto my_setenv_out;
-#else
+# else
return;
-#endif
+# endif
}
+
if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
environ[i+1] = NULL; /* make sure it's null terminated */
}
else
safesysfree(environ[i]);
- nlen = strlen(nam);
+
vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(environ[i], nam, nlen, val, vlen);
- } else {
-# endif
- /* This next branch should only be called #if defined(HAS_SETENV), but
- 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)) || defined(PERL_DARWIN)
-# if defined(HAS_UNSETENV)
+ }
+ else {
+
+# endif /* !PERL_USE_SAFE_PUTENV */
+
+# ifdef MY_HAS_SETENV
+# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
} else {
(void)setenv(nam, val, 1);
}
-# else /* ! HAS_UNSETENV */
+# else /* ! HAS_UNSETENV */
(void)setenv(nam, val, 1);
-# endif /* HAS_UNSETENV */
-# else
-# if defined(HAS_UNSETENV)
+# endif /* HAS_UNSETENV */
+
+# elif defined(HAS_UNSETENV)
+
if (val == NULL) {
if (environ) /* old glibc can crash with null environ */
(void)unsetenv(nam);
} else {
- const int nlen = strlen(nam);
- const int vlen = strlen(val);
- char * const new_env =
- (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ const Size_t nlen = strlen(nam);
+ const Size_t vlen = strlen(val);
+ char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
}
-# else /* ! HAS_UNSETENV */
+
+# else /* ! HAS_UNSETENV */
+
char *new_env;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
-# endif /* HAS_UNSETENV */
-# endif /* __CYGWIN__ */
-#ifndef PERL_USE_SAFE_PUTENV
+
+# endif /* MY_HAS_SETENV */
+
+# ifndef PERL_USE_SAFE_PUTENV
}
-#endif
+# endif
}
-#ifdef __amigaos4__
+
+# ifdef __amigaos4__
my_setenv_out:
amigaos4_release_environ(__FUNCTION__);
-#endif
+# endif
}
-#else /* WIN32 || NETWARE */
+# else /* WIN32 || NETWARE */
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
char *envstr;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- Newx(envstr, nlen+vlen+2, char);
+ envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
}
-#endif /* WIN32 || NETWARE */
+# endif /* WIN32 || NETWARE */
+
+#endif /* USE_ENVIRON_ARRAY */
+
+
-#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
I32
}
#endif
-#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 <stdio.h>,
- but probably won't on others.
-*/
-
-int
-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
- return 0; /* perl doesn't use return value */
-}
-
-#endif /* HAS_VPRINTF */
-
PerlIO *
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) {
#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');
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
#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];
}
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) {
#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)
#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];
}
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)
*/
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 */
#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
+/*
+=for apidoc rsignal
+
+A wrapper for the C library L<signal(2)>. 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)
{
: 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__)
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;
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++)
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
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;
return -1;
}
+#ifdef SOCK_CLOEXEC
+ type &= ~SOCK_CLOEXEC;
+#endif
+
#ifdef EMULATE_SOCKETPAIR_UDP
if (type == SOCK_DGRAM)
return S_socketpair_udp(fd);
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:
{
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;
# 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;
* timeval. */
{
STRLEN len;
- const char* endptr;
+ const char* endptr = pmlenv + strlen(pmlenv);
int fd;
UV uv;
if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
#endif /* PERL_MEM_LOG */
/*
-=for apidoc my_sprintf
-
-The C library C<sprintf>, 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<sprintf>.
-
-=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<quadmath_snprintf()> is very strict about its C<format> string and will
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];
/*
=for apidoc my_snprintf
-The C library C<snprintf> functionality (using C<vsnprintf>).
-Consider using C<sv_vcatpvf> instead.
+The C library C<snprintf> functionality, if available and
+standards-compliant (uses C<vsnprintf>, actually). However, if the
+C<vsnprintf> is not available, will unfortunately use the unsafe
+C<vsprintf> which can overrun the buffer (there is an overrun check,
+but that may be too late). Consider using C<sv_vcatpvf> instead, or
+getting C<vsnprintf>.
=cut
*/
int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
+#ifndef HAS_VSNPRINTF
+ PERL_UNUSED_VAR(len);
+#endif
va_start(ap, format);
#ifdef USE_QUADMATH
{
* Handling the "Q-less" cases right would require walking
* through the va_list and rewriting the format, calling
* quadmath for the NVs, building a new va_list, and then
- * letting vsnprintf to take care of the other
+ * letting vsnprintf/vsprintf to take care of the other
* arguments. This may be doable.
*
* We do not attempt that now. But for paranoia, we here try
* to detect some common (but not all) cases where the
* "Q-less" %[efgaEFGA] formats are present, and die if
* detected. This doesn't fix the problem, but it stops the
- * vsnprintf pulling doubles off the va_list when
+ * vsnprintf/vsprintf pulling doubles off the va_list when
* __float128 NVs should be pulled off instead.
*
* If quadmath_format_needed() returns false, we are reasonably
}
#endif
if (retval == -1)
+#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
+#else
+ retval = vsprintf(buffer, format, ap);
+#endif
va_end(ap);
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
/* vsnprintf() shows failure with >= len */
- if (len > 0 && (Size_t)retval >= len)
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak_nocontext("panic: my_snprintf buffer overflow");
return retval;
}
/*
=for apidoc my_vsnprintf
-The C library C<vsnprintf>. Consider using C<sv_vcatpvf> instead.
+The C library C<vsnprintf> if available and standards-compliant.
+However, if if the C<vsnprintf> is not available, will unfortunately
+use the unsafe C<vsprintf> which can overrun the buffer (there is an
+overrun check, but that may be too late). Consider using
+C<sv_vcatpvf> instead, or getting C<vsnprintf>.
=cut
*/
PERL_ARGS_ASSERT_MY_VSNPRINTF;
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);
#else
+# 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 */
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
/* vsnprintf() shows failure with >= len */
- if (len > 0 && (Size_t)retval >= len)
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
#endif
#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)
{
}
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;
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 */
}
#endif
+/*
+=for apidoc my_strnlen
+
+The C library C<strnlen> if available, or a Perl implementation of it.
+
+C<my_strnlen()> computes the length of the string, up to C<maxlen>
+characters. It will will never attempt to address more than C<maxlen>
+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. */
#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;
}
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;
#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) {
#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
* 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;
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
}