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
{
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;
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)
+
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 */
-# elif 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 /* __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
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
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)
* timeval. */
{
STRLEN len;
- const char* endptr = pmlenv + stren(pmlenv);
+ const char* endptr = pmlenv + strlen(pmlenv);
int fd;
UV uv;
if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
#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 */