}
void
+Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd)
+{
+ assert(fd >= 0);
+ if(fd > PL_maxsysfd)
+ setfd_cloexec(fd);
+}
+
+void
Perl_setfd_inhexec_for_sysfd(pTHX_ int fd)
{
assert(fd >= 0);
if(fd <= PL_maxsysfd)
setfd_inhexec(fd);
}
+void
+Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd)
+{
+ assert(fd >= 0);
+ if(fd <= PL_maxsysfd)
+ setfd_inhexec(fd);
+ else
+ setfd_cloexec(fd);
+}
+
#define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
do { \
} while(0)
#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \
defined(F_GETFD)
-enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
-# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \
+enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
+# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
do { \
- static int strategy = CLOEXEC_EXPERIMENT; \
switch (strategy) { \
case CLOEXEC_EXPERIMENT: default: { \
int res = (GENOPEN_CLOEXEC), eno; \
} \
} while(0)
#else
-# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \
+# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC)
#endif
DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \
setfd_cloexec(fd)); \
} while(0)
-#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
+#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+ ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
do { \
int fd; \
- DO_GENOPEN_EXPERIMENTING_CLOEXEC(fd, fd = (ONEOPEN_CLOEXEC), \
+ DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+ fd, \
+ fd = (ONEOPEN_CLOEXEC), \
fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \
} while(0)
} while(0)
#define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \
DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
-#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PIPEFD, PIPEOPEN_CLOEXEC, \
+#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \
PIPEOPEN_NORMAL) \
- DO_GENOPEN_EXPERIMENTING_CLOEXEC((PIPEFD)[0], PIPEOPEN_CLOEXEC, \
+ DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+ (PIPEFD)[0], PIPEOPEN_CLOEXEC, \
PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
int
* to extend it, so for the time being this just isn't available on
* PERL_IMPLICIT_SYS builds.
*/
+ dVAR;
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_dup,
fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
PerlLIO_dup(oldfd));
#else
* to extend it, so for the time being this just isn't available on
* PERL_IMPLICIT_SYS builds.
*/
+ dVAR;
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_dup2,
dup3(oldfd, newfd, O_CLOEXEC),
PerlLIO_dup2(oldfd, newfd));
#else
int
Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag)
{
+ dVAR;
PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC;
#if defined(O_CLOEXEC)
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_open,
PerlLIO_open(file, flag | O_CLOEXEC),
PerlLIO_open(file, flag));
#else
int
Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm)
{
+ dVAR;
PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC;
#if defined(O_CLOEXEC)
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_open3,
PerlLIO_open3(file, flag | O_CLOEXEC, perm),
PerlLIO_open3(file, flag, perm));
#else
int
Perl_my_mkstemp_cloexec(char *templte)
{
+ dVAR;
PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC;
#if defined(O_CLOEXEC)
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_mkstemp,
Perl_my_mkostemp(templte, O_CLOEXEC),
Perl_my_mkstemp(templte));
#else
#endif
}
+int
+Perl_my_mkostemp_cloexec(char *templte, int flags)
+{
+ dVAR;
+ PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
+#if defined(O_CLOEXEC)
+ DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_mkstemp,
+ Perl_my_mkostemp(templte, flags | O_CLOEXEC),
+ Perl_my_mkostemp(templte, flags));
+#else
+ DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
+#endif
+}
+
#ifdef HAS_PIPE
int
Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
{
+ dVAR;
PERL_ARGS_ASSERT_PERLPROC_PIPE_CLOEXEC;
/*
* struct IPerlProc doesn't cover pipe2(), and there's no clear way
* PERL_IMPLICIT_SYS builds.
*/
# if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC)
- DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pipefd,
+ DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd,
pipe2(pipefd, O_CLOEXEC),
PerlProc_pipe(pipefd));
# else
Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol)
{
# if defined(SOCK_CLOEXEC)
+ dVAR;
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_socket,
PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
PerlSock_socket(domain, type, protocol));
# else
* way to extend it, so for the time being this just isn't available
* on PERL_IMPLICIT_SYS builds.
*/
+ dVAR;
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_accept,
accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
PerlSock_accept(listenfd, addr, addrlen));
# else
Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol,
int *pairfd)
{
+ dVAR;
PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC;
# ifdef SOCK_CLOEXEC
- DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pairfd,
+ DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd,
PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd),
PerlSock_socketpair(domain, type, protocol, pairfd));
# else
}
else {
if (dodup)
- wanted_fd = PerlLIO_dup(wanted_fd);
+ wanted_fd = PerlLIO_dup_cloexec(wanted_fd);
else
was_fdopen = TRUE;
if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) {
if (was_fdopen) {
/* need to close fp without closing underlying fd */
int ofd = PerlIO_fileno(fp);
- int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* Assume if we have F_SETFD we have F_GETFD. */
- /* Get a copy of all the fd flags. */
- int fd_flags = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
- if (fd_flags < 0) {
- if (dupfd >= 0)
- PerlLIO_close(dupfd);
- goto say_false;
- }
-#endif
+ int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1;
if (ofd < 0 || dupfd < 0) {
if (dupfd >= 0)
PerlLIO_close(dupfd);
goto say_false;
}
PerlIO_close(fp);
- PerlLIO_dup2(dupfd, ofd);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* The dup trick has lost close-on-exec on ofd,
- * and possibly any other flags, so restore them. */
- if (fcntl(ofd,F_SETFD, fd_flags) < 0) {
- if (dupfd >= 0)
- PerlLIO_close(dupfd);
- goto say_false;
- }
-#endif
+ PerlLIO_dup2_cloexec(dupfd, ofd);
+ setfd_inhexec_for_sysfd(ofd);
PerlLIO_close(dupfd);
}
else
PerlIO_clearerr(fp);
fd = PerlIO_fileno(fp);
}
- if (fd >= 0) {
- setfd_cloexec(fd);
- setfd_inhexec_for_sysfd(fd);
- }
IoIFP(io) = fp;
IoFLAGS(io) &= ~IOf_NOLINE;
{
int old_umask = umask(0177);
- fd = Perl_my_mkstemp(SvPVX(temp_out_name));
+ fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name));
umask(old_umask);
}
/* mg_obj can be NULL if a thread is created with the handle open, in which
case we leave any clean up to the parent thread */
- if (mg->mg_obj && IoIFP(io)) {
- SV **pid_psv;
+ if (mg->mg_obj) {
#ifdef ARGV_USE_ATFUNCTIONS
SV **dir_psv;
DIR *dir;
+
+ dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
+ assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
+ dir = INT2PTR(DIR *, SvIV(*dir_psv));
#endif
- PerlIO *iop = IoIFP(io);
+ if (IoIFP(io)) {
+ if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
+ (void)argvout_final(mg, (IO*)io, FALSE);
+ }
+ else {
+ SV **pid_psv;
+ PerlIO *iop = IoIFP(io);
- assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+ assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
- pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
+ pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
- assert(pid_psv && *pid_psv);
+ assert(pid_psv && *pid_psv);
- if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
- /* if we get here the file hasn't been closed explicitly by the
- user and hadn't been closed implicitly by nextargv(), so
- abandon the edit */
- SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
- const char *temp_pv = SvPVX(*temp_psv);
+ if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
+ /* if we get here the file hasn't been closed explicitly by the
+ user and hadn't been closed implicitly by nextargv(), so
+ abandon the edit */
+ SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
+ const char *temp_pv = SvPVX(*temp_psv);
- assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
- (void)PerlIO_close(iop);
- IoIFP(io) = IoOFP(io) = NULL;
+ assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
+ (void)PerlIO_close(iop);
+ IoIFP(io) = IoOFP(io) = NULL;
#ifdef ARGV_USE_ATFUNCTIONS
- dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
- assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
- dir = INT2PTR(DIR *, SvIV(*dir_psv));
- if (dir) {
- if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
- NotSupported(errno))
- (void)UNLINK(temp_pv);
- closedir(dir);
- }
+ if (dir) {
+ if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
+ NotSupported(errno))
+ (void)UNLINK(temp_pv);
+ }
#else
- (void)UNLINK(temp_pv);
+ (void)UNLINK(temp_pv);
#endif
+ }
+ }
}
+#ifdef ARGV_USE_ATFUNCTIONS
+ if (dir)
+ closedir(dir);
+#endif
}
return 0;
}
#ifdef ARGV_USE_ATFUNCTIONS
-# if defined(__FreeBSD__)
+# if defined(__FreeBSD__) || defined(__FreeBSD_kernel__)
/* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the
* equivalent rename() succeeds
# else
# define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2))
-# endif /* if defined(__FreeBSD__) */
+# endif /* if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) */
#endif
static bool
#define dir_unchanged(orig_psv, mg) \
S_dir_unchanged(aTHX_ (orig_psv), (mg))
-/* explicit renamed to avoid C++ conflict -- kja */
-bool
-Perl_do_close(pTHX_ GV *gv, bool not_implicit)
-{
+STATIC bool
+S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) {
bool retval;
- IO *io;
- MAGIC *mg;
- if (!gv)
- gv = PL_argvgv;
- if (!gv || !isGV_with_GP(gv)) {
- if (not_implicit)
- SETERRNO(EBADF,SS_IVCHAN);
- return FALSE;
- }
- io = GvIO(gv);
- if (!io) { /* never opened */
- if (not_implicit) {
- report_evil_fh(gv);
- SETERRNO(EBADF,SS_IVCHAN);
- }
- return FALSE;
- }
- if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
- && mg->mg_obj) {
+ /* ensure args are checked before we start using them */
+ PERL_ARGS_ASSERT_ARGVOUT_FINAL;
+
+ {
/* handle to an in-place edit work file */
SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE);
SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
SvPVX(*temp_psv), Strerror(errno));
}
}
- freext:
+ freext:
+ ;
+ }
+ return retval;
+}
+
+/* explicit renamed to avoid C++ conflict -- kja */
+bool
+Perl_do_close(pTHX_ GV *gv, bool not_implicit)
+{
+ bool retval;
+ IO *io;
+ MAGIC *mg;
+
+ if (!gv)
+ gv = PL_argvgv;
+ if (!gv || !isGV_with_GP(gv)) {
+ if (not_implicit)
+ SETERRNO(EBADF,SS_IVCHAN);
+ return FALSE;
+ }
+ io = GvIO(gv);
+ if (!io) { /* never opened */
+ if (not_implicit) {
+ report_evil_fh(gv);
+ SETERRNO(EBADF,SS_IVCHAN);
+ }
+ return FALSE;
+ }
+ if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
+ && mg->mg_obj) {
+ retval = argvout_final(mg, io, not_implicit);
mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
}
else {
if (IoIFP(io)) {
if (IoTYPE(io) == IoTYPE_PIPE) {
- const int status = PerlProc_pclose(IoIFP(io));
+ PerlIO *fh = IoIFP(io);
+ int status;
+
+ /* my_pclose() can propagate signals which might bypass any code
+ after the call here if the signal handler throws an exception.
+ This would leave the handle in the IO object and try to close it again
+ when the SV is destroyed on unwind or global destruction.
+ So NULL it early.
+ */
+ IoOFP(io) = IoIFP(io) = NULL;
+ status = PerlProc_pclose(fh);
if (not_implicit) {
STATUS_NATIVE_CHILD_SET(status);
retval = (STATUS_UNIX == 0);
# if defined(OS2)
sv_setpv(tmpcmd, "for a in ");
sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
+ sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
# elif defined(DJGPP)
sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
sv_catsv(tmpcmd, tmpglob);
# else
sv_setpv(tmpcmd, "perlglob ");
sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, " |");
+ sv_catpvs(tmpcmd, " |");
# endif
# elif defined(CSH)
sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
- sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
+ sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob ");
sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "' 2>/dev/null |");
+ sv_catpvs(tmpcmd, "' 2>/dev/null |");
# else
sv_setpv(tmpcmd, "echo ");
sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
+ sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
# endif /* !DOSISH && !CSH */
{
SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
https://perl5.git.perl.org / perl5.git / blobdiff