}
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
* PERL_IMPLICIT_SYS builds.
*/
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_dup,
fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
PerlLIO_dup(oldfd));
#else
* PERL_IMPLICIT_SYS builds.
*/
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_dup2,
dup3(oldfd, newfd, O_CLOEXEC),
PerlLIO_dup2(oldfd, newfd));
#else
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
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
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)
+{
+ 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)
* 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
{
# if defined(SOCK_CLOEXEC)
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_socket,
PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
PerlSock_socket(domain, type, protocol));
# else
* on PERL_IMPLICIT_SYS builds.
*/
DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+ PL_strategy_accept,
accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
PerlSock_accept(listenfd, addr, addrlen));
# else
{
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 {
const int old_fd = PerlIO_fileno(IoIFP(io));
- if (old_fd >= 0 && old_fd <= PL_maxsysfd) {
+ if (inRANGE(old_fd, 0, PL_maxsysfd)) {
/* This is one of the original STD* handles */
*saveifp = IoIFP(io);
*saveofp = IoOFP(io);
}
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))) {
Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
}
}
- else {
+ else {
if (num_svs) {
fp = PerlIO_openn(aTHX_ type,mode,-1,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;
PL_filemode = 0;
if (!GvAV(gv))
return NULL;
- while (av_tindex(GvAV(gv)) >= 0) {
+ while (av_count(GvAV(gv)) > 0) {
STRLEN oldlen;
SV *const sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
}
#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);
Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
int fd, int do_report)
{
- dVAR;
PERL_ARGS_ASSERT_DO_AEXEC5;
-#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
+#if defined(__LIBCATAMOUNT__)
Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
#else
assert(sp >= mark);
bool
Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
{
- dVAR;
const char **argv, **a;
char *s;
char *buf;
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) &&
- strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+ memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && !s[1]) {
*s = '\0';
break;
PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
/* Doing this ahead of the switch statement preserves the old behaviour,
- where attempting to use kill as a taint test test would fail on
+ where attempting to use kill as a taint test would fail on
platforms where kill was not defined. */
#ifndef HAS_KILL
if (type == OP_KILL)
{
if (getinfo)
{
- SvPV_force_nolen(astr);
+ /* we're not using the value here, so don't SvPVanything */
+ SvUPGRADE(astr, SVt_PV);
+ SvGETMAGIC(astr);
+ if (SvTHINKFIRST(astr))
+ sv_force_normal_flags(astr, 0);
a = SvGROW(astr, infosize+1);
}
else
{
STRLEN len;
- a = SvPV(astr, len);
+ a = SvPVbyte(astr, len);
if (len != infosize)
Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
PL_op_desc[optype],
}
else
{
- const IV i = SvIV(astr);
- a = INT2PTR(char *,i); /* ouch */
+ /* We historically treat this as a pointer if we don't otherwise recognize
+ the op, but for many ops the value is simply ignored anyway, so
+ don't warn on undef.
+ */
+ SvGETMAGIC(astr);
+ if (SvOK(astr)) {
+ const IV i = SvIV_nomg(astr);
+ a = INT2PTR(char *,i); /* ouch */
+ }
+ else {
+ a = NULL;
+ }
}
SETERRNO(0,0);
switch (optype)
if (getinfo && ret >= 0) {
SvCUR_set(astr, infosize);
*SvEND(astr) = '\0';
+ SvPOK_only(astr);
SvSETMAGIC(astr);
}
return ret;
const I32 id = SvIVx(*++mark);
SV * const mstr = *++mark;
const I32 flags = SvIVx(*++mark);
- const char * const mbuf = SvPV_const(mstr, len);
+ const char * const mbuf = SvPVbyte(mstr, len);
const I32 msize = len - sizeof(long);
PERL_ARGS_ASSERT_DO_MSGSND;
}
if (ret >= 0) {
SvCUR_set(mstr, sizeof(long)+ret);
+ SvPOK_only(mstr);
*SvEND(mstr) = '\0';
/* who knows who has been playing with this message? */
SvTAINTED_on(mstr);
STRLEN opsize;
const I32 id = SvIVx(*++mark);
SV * const opstr = *++mark;
- const char * const opbuf = SvPV_const(opstr, opsize);
+ const char * const opbuf = SvPVbyte(opstr, opsize);
PERL_ARGS_ASSERT_DO_SEMOP;
PERL_UNUSED_ARG(sp);
else {
STRLEN len;
- const char *mbuf = SvPV_const(mstr, len);
+ const char *mbuf = SvPVbyte(mstr, len);
const I32 n = ((I32)len > msize) ? msize : (I32)len;
Copy(mbuf, shm + mpos, n, char);
if (n < msize)
#endif /* SYSV IPC */
/*
-=head1 IO Functions
-
=for apidoc start_glob
Function called by C<do_readline> to spawn a glob (or do the glob inside
# 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