#include "XSUB.h"
-#ifdef __Lynx__
-/* Missing proto on LynxOS */
-int mkstemp(char*);
-#endif
-
#ifdef VMS
#include <rms.h>
#endif
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
-#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
+#if defined(PERL_MICRO)
return NULL;
#elif defined(PERL_IMPLICIT_SYS)
return PerlSIO_fdupopen(f);
return win32_fdupopen(f);
# else
if (f) {
- const int fd = PerlLIO_dup(PerlIO_fileno(f));
+ const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
if (fd >= 0) {
char mode[8];
# ifdef DJGPP
return NULL;
if (*mode == IoTYPE_NUMERIC) {
- fd = PerlLIO_open3(name, imode, perm);
+ fd = PerlLIO_open3_cloexec(name, imode, perm);
if (fd >= 0)
return PerlIO_fdopen(fd, mode + 1);
}
PerlProc_getgid() == PerlProc_getegid()) {
const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
if (s && *s)
- PL_perlio_debug_fd
- = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
+ PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
+ O_WRONLY | O_CREAT | O_APPEND, 0666);
else
- PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
+ PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
} else {
/* tainting or set*id, so ignore the environment and send the
debug output to stderr, like other -D switches. */
- PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
+ PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
}
}
if (PL_perlio_debug_fd > 0) {
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char buffer[1024];
const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
+# ifdef USE_QUADMATH
+# ifdef HAS_VSNPRINTF
+ /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
+ should be, otherwise the system isn't likely to support quadmath.
+ Nothing should be calling PerlIO_debug() with floating point anyway.
+ */
+ const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
+# else
+ STATIC_ASSERT_STMT(0);
+# endif
+# else
const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
+# endif
PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
#else
const char *s = CopFILE(PL_curcop);
int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (!f && narg == 1 && *args == &PL_sv_undef) {
- if ((f = PerlIO_tmpfile())) {
+ imode = PerlIOUnix_oflags(mode);
+
+ if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
if (!layers || !*layers)
layers = Perl_PerlIO_context_layers(aTHX_ mode);
if (layers && *layers)
S_more_refcounted_fds(pTHX_ const int new_fd)
PERL_TSA_REQUIRES(PL_perlio_mutex)
{
- dVAR;
const int old_max = PL_perlio_fd_refcnt_size;
const int new_max = 16 + (new_fd & ~15);
int *new_array;
{
dTHX;
if (fd >= 0) {
- dVAR;
MUTEX_LOCK(&PL_perlio_mutex);
if (fd >= PL_perlio_fd_refcnt_size)
#ifdef DEBUGGING
dTHX;
#else
- dVAR;
#endif
MUTEX_LOCK(&PL_perlio_mutex);
if (fd >= PL_perlio_fd_refcnt_size) {
dTHX;
int cnt = 0;
if (fd >= 0) {
- dVAR;
MUTEX_LOCK(&PL_perlio_mutex);
if (fd >= PL_perlio_fd_refcnt_size) {
/* diag_listed_as: refcnt: fd %d%s */
void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
{
- dVAR;
#if 0
/* XXX we can't rely on an interpreter being present at this late stage,
XXX so we can't use a function like PerlLIO_write that relies on one
IV n, const char *mode, int fd, int imode,
int perm, PerlIO *f, int narg, SV **args)
{
+ bool known_cloexec = 0;
if (PerlIOValid(f)) {
if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
const char *path = SvPV_const(*args, len);
if (!IS_SAFE_PATHNAME(path, len, "open"))
return NULL;
- fd = PerlLIO_open3(path, imode, perm);
+ fd = PerlLIO_open3_cloexec(path, imode, perm);
+ known_cloexec = 1;
}
}
if (fd >= 0) {
+ if (known_cloexec)
+ setfd_inhexec_for_sysfd(fd);
+ else
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
if (*mode == IoTYPE_IMPLICIT)
mode++;
if (!f) {
const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
int fd = os->fd;
if (flags & PERLIO_DUP_FD) {
- fd = PerlLIO_dup(fd);
+ fd = PerlLIO_dup_cloexec(fd);
+ if (fd >= 0)
+ setfd_inhexec_for_sysfd(fd);
}
if (fd >= 0) {
f = PerlIOBase_dup(aTHX_ f, o, param, flags);
if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
return -1;
fd = PerlIOSelf(f, PerlIOUnix)->fd;
-#ifdef PERLIO_STD_SPECIAL
- if (fd == 0)
- return PERLIO_STD_IN(fd, vbuf, count);
-#endif
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
return -1;
fd = PerlIOSelf(f, PerlIOUnix)->fd;
-#ifdef PERLIO_STD_SPECIAL
- if (fd == 1 || fd == 2)
- return PERLIO_STD_OUT(fd, vbuf, count);
-#endif
while (1) {
const SSize_t len = PerlLIO_write(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
+ code = PerlIOBase_close(aTHX_ f);
if (PerlIOUnix_refcnt_dec(fd) > 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return 0;
Note that the errno value set by a failing fdopen
varies between stdio implementations.
*/
- const int fd = PerlLIO_dup(fd0);
+ const int fd = PerlLIO_dup_cloexec(fd0);
FILE *f2;
if (fd < 0) {
return f;
if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
+ fd0 = fileno(stdio);
+ if(fd0 != -1){
+ PerlIOUnix_refcnt_inc(fd0);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd0);
+ }
#ifdef EBCDIC
- fd0 = fileno(stdio);
- if(fd0 != -1){
- PerlIOUnix_refcnt_inc(fd0);
- }
else{
rc = fldata(stdio,filename,&fileinfo);
if(rc != 0){
}
/*This MVS dataset , OK!*/
}
-#else
- PerlIOUnix_refcnt_inc(fileno(stdio));
#endif
}
}
if (!s->stdio)
return NULL;
s->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
return f;
}
else {
return NULL;
if (*mode == IoTYPE_NUMERIC) {
mode++;
- fd = PerlLIO_open3(path, imode, perm);
+ fd = PerlLIO_open3_cloexec(path, imode, perm);
}
else {
FILE *stdio;
f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
if (f) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
} else {
PerlSIO_fclose(stdio);
}
}
if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
}
return f;
}
const int fd = fileno(stdio);
char mode[8];
if (flags & PERLIO_DUP_FD) {
- const int dfd = PerlLIO_dup(fileno(stdio));
+ const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
if (dfd >= 0) {
stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
goto set_this;
set_this:
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
if(stdio) {
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ int fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
}
}
return f;
f->_file = -1;
return 1;
# elif defined(WIN32)
-# if defined(UNDER_CE)
- /* WIN_CE does not have access to FILE internals, it hardly has FILE
- structure at all
- */
-# else
PERLIO_FILE_file(f) = -1;
-# endif
return 1;
# else
#if 0
int dupfd = -1;
dSAVEDERRNO;
#ifdef USE_ITHREADS
- dVAR;
#endif
#ifdef SOCKS5_VERSION_NAME
/* Socks lib overrides close() but stdio isn't linked to
SAVE_ERRNO;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
if (!invalidate) {
- dupfd = PerlLIO_dup(fd);
+ dupfd = PerlLIO_dup_cloexec(fd);
#ifdef USE_ITHREADS
if (dupfd < 0) {
/* Oh cXap. This isn't going to go well. Not sure if we can
result = close(fd);
#endif
if (dupfd >= 0) {
- PerlLIO_dup2(dupfd,fd);
+ PerlLIO_dup2_cloexec(dupfd, fd);
+ setfd_inhexec_for_sysfd(fd);
PerlLIO_close(dupfd);
}
MUTEX_UNLOCK(&PL_perlio_mutex);
PerlIO_pop(aTHX_ f);
#endif
}
- return 0;
+ return PerlIOBase_binmode(aTHX_ f);
}
PERLIO_FUNCS_DECL(PerlIO_crlf) = {
PerlIO *
PerlIO_tmpfile(void)
{
+ return PerlIO_tmpfile_flags(0);
+}
+
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
+
+PerlIO *
+PerlIO_tmpfile_flags(int imode)
+{
#ifndef WIN32
dTHX;
#endif
PerlIO *f = NULL;
#ifdef WIN32
- const int fd = win32_tmpfd();
+ const int fd = win32_tmpfd_mode(imode);
if (fd >= 0)
f = PerlIO_fdopen(fd, "w+b");
-#elif defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
+#elif ! defined(OS2)
int fd = -1;
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
SV * sv = NULL;
int old_umask = umask(0177);
- /*
- * I have no idea how portable mkstemp() is ... NI-S
- */
+ imode &= ~MKOSTEMP_MODE_MASK;
if (tmpdir && *tmpdir) {
/* if TMPDIR is set and not empty, we try that first */
sv = newSVpv(tmpdir, 0);
sv_catpv(sv, tempname + 4);
- fd = mkstemp(SvPVX(sv));
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
}
if (fd < 0) {
SvREFCNT_dec(sv);
sv = NULL;
/* else we try /tmp */
- fd = mkstemp(tempname);
+ fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
}
if (fd < 0) {
/* Try cwd */
sv = newSVpvs(".");
sv_catpv(sv, tempname + 4);
- fd = mkstemp(SvPVX(sv));
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
}
umask(old_umask);
if (fd >= 0) {
- f = PerlIO_fdopen(fd, "w+");
+ /* fdopen() with a numeric mode */
+ char mode[8];
+ int writing = 1;
+ (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
+ f = PerlIO_fdopen(fd, mode);
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
+# ifndef VMS
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
+# endif
}
SvREFCNT_dec(sv);
#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
void
Perl_noperl_die(const char* pat, ...)
{
- va_list(arglist);
+ va_list arglist;
PERL_ARGS_ASSERT_NOPERL_DIE;
va_start(arglist, pat);
vfprintf(stderr, pat, arglist);
https://perl5.git.perl.org / perl5.git / blobdiff