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;
#ifdef USE_ENVIRON_ARRAY
/* 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)
{
panic:
croak_memory_wrap();
}
+# endif
# if !defined(WIN32) && !defined(NETWARE)
# endif /* !PERL_USE_SAFE_PUTENV */
- /* 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)
-
+# ifdef MY_HAS_SETENV
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
-# endif /* __CYGWIN__ */
+# endif /* MY_HAS_SETENV */
# ifndef PERL_USE_SAFE_PUTENV
}
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)
#ifndef PERL_GLOBAL_STRUCT_PRIVATE
void *
-Perl_my_cxt_init(pTHX_ int *index, size_t size)
+Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
{
dVAR;
void *p;
+ int index;
+
PERL_ARGS_ASSERT_MY_CXT_INIT;
- if (*index == -1) {
- /* this module hasn't been allocated an index yet */
+
+ index = *indexp;
+ /* do initial check without locking.
+ * -1: not allocated or another thread currently allocating
+ * other: already allocated by another thread
+ */
+ if (index == -1) {
MUTEX_LOCK(&PL_my_ctx_mutex);
- *index = PL_my_cxt_index++;
+ /*now a stricter check with locking */
+ index = *indexp;
+ if (index == -1)
+ /* this module hasn't been allocated an index yet */
+ *indexp = PL_my_cxt_index++;
+ index = *indexp;
MUTEX_UNLOCK(&PL_my_ctx_mutex);
}
-
+
/* make sure the array is big enough */
- if (PL_my_cxt_size <= *index) {
+ if (PL_my_cxt_size <= index) {
if (PL_my_cxt_size) {
IV new_size = PL_my_cxt_size;
- while (new_size <= *index)
+ while (new_size <= index)
new_size *= 2;
Renew(PL_my_cxt_list, new_size, void *);
PL_my_cxt_size = new_size;
}
/* newSV() allocates one more than needed */
p = (void*)SvPVX(newSV(size-1));
- PL_my_cxt_list[*index] = p;
+ PL_my_cxt_list[index] = p;
Zero(p, size, char);
return p;
}
PERL_ARGS_ASSERT_MY_CXT_INIT;
index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+ /* 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 */
+ index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+ if (index == -1)
+ /* this module hasn't been allocated an index yet */
+ 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;
+
MUTEX_UNLOCK(&PL_my_ctx_mutex);
}
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;
https://perl5.git.perl.org / perl5.git / blobdiff