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
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
/*
=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
}
}
+const char *
+Perl_cntrl_to_mnemonic(const U8 c)
+{
+ /* Returns the mnemonic string that represents character 'c', if one
+ * exists; NULL otherwise. The only ones that exist for the purposes of
+ * this routine are a few control characters */
+
+ switch (c) {
+ case '\a': return "\\a";
+ case '\b': return "\\b";
+ case ESC_NATIVE: return "\\e";
+ case '\f': return "\\f";
+ case '\n': return "\\n";
+ case '\r': return "\\r";
+ case '\t': return "\\t";
+ }
+
+ return NULL;
+}
+
/* copy a string to a safe spot */
/*
Perl's version of C<strdup()>. Returns a pointer to a newly allocated
string which is a duplicate of C<pv>. The size of the string is
determined by C<strlen()>, which means it may not contain embedded C<NUL>
-characters and must have a trailing C<NUL>. The memory allocated for the new
-string can be freed with the C<Safefree()> function.
+characters and must have a trailing C<NUL>. To prevent memory leaks, the
+memory allocated for the new string needs to be freed when no longer needed.
+This can be done with the L</C<Safefree>> function, or
+L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends. So if you need that not to happen, you
*/
char *
-Perl_savepvn(pTHX_ const char *pv, I32 len)
+Perl_savepvn(pTHX_ const char *pv, Size_t len)
{
char *newaddr;
PERL_UNUSED_CONTEXT;
- assert(len >= 0);
-
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
}
/*
-=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
}
/*
-=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.
}
#endif /* PERL_IMPLICIT_CONTEXT */
+/* saves machine code for a common noreturn idiom typically used in Newx*() */
+GCC_DIAG_IGNORE_DECL(-Wunused-function);
+void
+Perl_croak_memory_wrap(void)
+{
+ Perl_croak_nocontext("%s",PL_memory_wrap);
+}
+GCC_DIAG_RESTORE_DECL;
+
void
Perl_croak(pTHX_ const char *pat, ...)
{
}
/*
-=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.
# 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)
{
# endif
# ifdef USE_ITHREADS
- /* only parent thread can modify process environment */
+ /* only parent thread can modify process environment, so no need to use a
+ * mutex */
if (PL_curinterp == aTHX)
# endif
{
envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
- Safefree(envstr);
+ safesysfree(envstr);
}
# endif /* WIN32 || NETWARE */
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
int errkid;
- unsigned n = 0;
+ unsigned read_total = 0;
- while (n < sizeof(int)) {
+ while (read_total < sizeof(int)) {
const SSize_t n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+n),
- (sizeof(int)) - n);
+ (void*)(((char*)&errkid)+read_total),
+ (sizeof(int)) - read_total);
if (n1 <= 0)
break;
- n += n1;
+ read_total += n1;
}
PerlLIO_close(pp[0]);
did_pipes = 0;
- if (n) { /* Error */
+ if (read_total) { /* Error */
int pid2, status;
PerlLIO_close(p[This]);
- if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
+ if (read_total != sizeof(int))
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
#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)
{
return (Sighandler_t) SIG_ERR;
#endif
- act.sa_handler = (void(*)(int))handler;
+ act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
return -1;
#endif
- act.sa_handler = (void(*)(int))handler;
+ act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
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;
Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
{
#ifdef HAS_TM_TM_ZONE
+ dVAR;
Time_t now;
const struct tm* my_tm;
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
+ ENV_LOCALE_READ_LOCK;
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
+ ENV_LOCALE_READ_UNLOCK;
#else
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
** If there is a better way to make it portable, go ahead by
** all means.
*/
- if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
+ if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
return buf;
else {
/* Possibly buf overflowed - try again with a bigger buf */
buflen = strftime(buf, bufsize, fmt, &mytm);
GCC_DIAG_RESTORE_STMT;
- if (buflen > 0 && buflen < bufsize)
+ if (inRANGE(buflen, 1, bufsize - 1))
break;
/* heuristic to prevent out-of-memory errors */
if (bufsize > 100*fmtlen) {
#endif /* PERL_MEM_LOG */
/*
-=for apidoc quadmath_format_single
+=for apidoc quadmath_format_valid
C<quadmath_snprintf()> is very strict about its C<format> string and will
fail, returning -1, if the format is invalid. It accepts exactly
one format spec.
-C<quadmath_format_single()> checks that the intended single spec looks
+C<quadmath_format_valid()> checks that the intended single spec looks
sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
and has C<Q> before it. This is not a full "printf syntax check",
just the basics.
-Returns the format if it is valid, NULL if not.
-
-C<quadmath_format_single()> can and will actually patch in the missing
-C<Q>, if necessary. In this case it will return the modified copy of
-the format, B<which the caller will need to free.>
+Returns true if it is valid, false if not.
See also L</quadmath_format_needed>.
=cut
*/
#ifdef USE_QUADMATH
-const char*
-Perl_quadmath_format_single(const char* format)
+bool
+Perl_quadmath_format_valid(const char* format)
{
STRLEN len;
- PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
if (format[0] != '%' || strchr(format + 1, '%'))
- return NULL;
+ return FALSE;
len = strlen(format);
/* minimum length three: %Qg */
- if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
- return NULL;
- if (format[len - 2] != 'Q') {
- char* fixed;
- Newx(fixed, len + 1, char);
- memcpy(fixed, format, len - 1);
- fixed[len - 1] = 'Q';
- fixed[len ] = format[len - 1];
- fixed[len + 1] = 0;
- return (const char*)fixed;
- }
- return format;
+ if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
+ return FALSE;
+ if (format[len - 2] != 'Q')
+ return FALSE;
+ return TRUE;
}
#endif
If true is returned, those arguments B<should> in theory be processed
with C<quadmath_snprintf()>, but in case there is more than one such
-format specifier (see L</quadmath_format_single>), and if there is
+format specifier (see L</quadmath_format_valid>), and if there is
anything else beyond that one (even just a single byte), they
B<cannot> be processed because C<quadmath_snprintf()> is very strict,
accepting only one format spec, and nothing else.
else
while (isDIGIT(*q)) q++;
}
- if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
return TRUE;
p = q + 1;
}
va_start(ap, format);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(format);
bool quadmath_valid = FALSE;
- if (qfmt) {
+ if (quadmath_format_valid(format)) {
/* If the format looked promising, use it as quadmath. */
- retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
if (retval == -1) {
- if (qfmt != format) {
- dTHX;
- SAVEFREEPV(qfmt);
- }
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
}
quadmath_valid = TRUE;
- if (qfmt != format)
- Safefree(qfmt);
- qfmt = NULL;
}
- assert(qfmt == NULL);
/* quadmath_format_single() will return false for example for
* "foo = %g", or simply "%g". We could handle the %g by
* using quadmath for the NV args. More complex cases of
# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
# if defined(USE_ENVIRON_ARRAY)
# if defined(USE_ITHREADS)
- /* only the parent thread can clobber the process environment */
+ /* only the parent thread can clobber the process environment, so no need
+ * to use a mutex */
if (PL_curinterp == aTHX)
# endif /* USE_ITHREADS */
{
#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;
- /* 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);
- /*now a stricter check with locking */
- if (*index == -1)
- /* this module hasn't been allocated an index yet */
- *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) {
MUTEX_LOCK(&PL_my_ctx_mutex);
/*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. */
STRLEN len = strlen(templte);
int fd;
int attempts = 0;
+#ifdef VMS
+ int delete_on_close = flags & O_VMS_DELETEONCLOSE;
+
+ flags &= ~O_VMS_DELETEONCLOSE;
+#endif
if (len < 6 ||
templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
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 | flags, 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;
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
}
https://perl5.git.perl.org / perl5.git / blobdiff