803414
From ea685742db78c7a5e7b22c8909fba03ce539f2b1 Mon Sep 17 00:00:00 2001
803414
From: Tony Cook <tony@develop-help.com>
803414
Date: Tue, 2 Jul 2019 14:16:35 +1000
803414
Subject: [PATCH] (perl #134221) support append mode for open .. undef
803414
MIME-Version: 1.0
803414
Content-Type: text/plain; charset=UTF-8
803414
Content-Transfer-Encoding: 8bit
803414
803414
Petr Písař: Ported to 5.28.2 from
803414
45b29440d38be155c5177c8d6f9a5d4e7c2c098c.
803414
803414
Signed-off-by: Petr Písař <ppisar@redhat.com>
803414
---
803414
 doio.c             | 14 ++++++++++++++
803414
 embed.fnc          |  1 +
803414
 perlio.c           | 26 +++++++++++++++++++++-----
803414
 perlio.h           |  3 +++
803414
 proto.h            |  5 +++++
803414
 t/io/perlio_open.t | 14 ++++++++++++--
803414
 6 files changed, 56 insertions(+), 7 deletions(-)
803414
803414
diff --git a/doio.c b/doio.c
803414
index 1bab383..f35045e 100644
803414
--- a/doio.c
803414
+++ b/doio.c
803414
@@ -252,6 +252,20 @@ Perl_my_mkstemp_cloexec(char *templte)
803414
 #endif
803414
 }
803414
 
803414
+int
803414
+Perl_my_mkostemp_cloexec(char *templte, int flags)
803414
+{
803414
+    dVAR;
803414
+    PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
803414
+#if defined(O_CLOEXEC)
803414
+    DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
803414
+	Perl_my_mkostemp(templte, flags | O_CLOEXEC),
803414
+	Perl_my_mkostemp(templte, flags));
803414
+#else
803414
+    DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
803414
+#endif
803414
+}
803414
+
803414
 #ifdef HAS_PIPE
803414
 int
803414
 Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
803414
diff --git a/embed.fnc b/embed.fnc
803414
index e762fe1..f6c4ad8 100644
803414
--- a/embed.fnc
803414
+++ b/embed.fnc
803414
@@ -476,6 +476,7 @@ p	|int	|PerlLIO_dup2_cloexec|int oldfd|int newfd
803414
 pR	|int	|PerlLIO_open_cloexec|NN const char *file|int flag
803414
 pR	|int	|PerlLIO_open3_cloexec|NN const char *file|int flag|int perm
803414
 pnoR	|int	|my_mkstemp_cloexec|NN char *templte
803414
+pnoR	|int	|my_mkostemp_cloexec|NN char *templte|int flags
803414
 #ifdef HAS_PIPE
803414
 pR	|int	|PerlProc_pipe_cloexec|NN int *pipefd
803414
 #endif
803414
diff --git a/perlio.c b/perlio.c
803414
index f5eb485..e22999e 100644
803414
--- a/perlio.c
803414
+++ b/perlio.c
803414
@@ -1478,7 +1478,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
803414
 	     int imode, int perm, PerlIO *f, int narg, SV **args)
803414
 {
803414
     if (!f && narg == 1 && *args == &PL_sv_undef) {
803414
-	if ((f = PerlIO_tmpfile())) {
803414
+        int imode = PerlIOUnix_oflags(mode);
803414
+
803414
+	if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
803414
 	    if (!layers || !*layers)
803414
 		layers = Perl_PerlIO_context_layers(aTHX_ mode);
803414
 	    if (layers && *layers)
803414
@@ -5036,6 +5038,15 @@ PerlIO_stdoutf(const char *fmt, ...)
803414
 #undef PerlIO_tmpfile
803414
 PerlIO *
803414
 PerlIO_tmpfile(void)
803414
+{
803414
+    return PerlIO_tmpfile_flags(0);
803414
+}
803414
+
803414
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
803414
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
803414
+
803414
+PerlIO *
803414
+PerlIO_tmpfile_flags(int imode)
803414
 {
803414
 #ifndef WIN32
803414
      dTHX;
803414
@@ -5051,27 +5062,32 @@ PerlIO_tmpfile(void)
803414
      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
803414
      SV * sv = NULL;
803414
      int old_umask = umask(0177);
803414
+     imode &= ~MKOSTEMP_MODE_MASK;
803414
      if (tmpdir && *tmpdir) {
803414
 	 /* if TMPDIR is set and not empty, we try that first */
803414
 	 sv = newSVpv(tmpdir, 0);
803414
 	 sv_catpv(sv, tempname + 4);
803414
-	 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
803414
+	 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
803414
      }
803414
      if (fd < 0) {
803414
 	 SvREFCNT_dec(sv);
803414
 	 sv = NULL;
803414
 	 /* else we try /tmp */
803414
-	 fd = Perl_my_mkstemp_cloexec(tempname);
803414
+	 fd = Perl_my_mkostemp_cloexec(tempname, imode);
803414
      }
803414
      if (fd < 0) {
803414
          /* Try cwd */
803414
          sv = newSVpvs(".");
803414
          sv_catpv(sv, tempname + 4);
803414
-         fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
803414
+         fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
803414
      }
803414
      umask(old_umask);
803414
      if (fd >= 0) {
803414
-	  f = PerlIO_fdopen(fd, "w+");
803414
+         /* fdopen() with a numeric mode */
803414
+         char mode[8];
803414
+         int writing = 1;
803414
+         (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
803414
+         f = PerlIO_fdopen(fd, mode);
803414
 	  if (f)
803414
 	       PerlIOBase(f)->flags |= PERLIO_F_TEMP;
803414
 	  PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
803414
diff --git a/perlio.h b/perlio.h
803414
index d515020..ee16ab8 100644
803414
--- a/perlio.h
803414
+++ b/perlio.h
803414
@@ -286,6 +286,9 @@ PERL_CALLCONV SSize_t PerlIO_get_bufsiz(PerlIO *);
803414
 #ifndef PerlIO_tmpfile
803414
 PERL_CALLCONV PerlIO *PerlIO_tmpfile(void);
803414
 #endif
803414
+#ifndef PerlIO_tmpfile_flags
803414
+PERL_CALLCONV PerlIO *PerlIO_tmpfile_flags(int flags);
803414
+#endif
803414
 #ifndef PerlIO_stdin
803414
 PERL_CALLCONV PerlIO *PerlIO_stdin(void);
803414
 #endif
803414
diff --git a/proto.h b/proto.h
803414
index 66bb29b..26b3750 100644
803414
--- a/proto.h
803414
+++ b/proto.h
803414
@@ -2237,6 +2237,11 @@ PERL_CALLCONV Pid_t	Perl_my_fork(void);
803414
 PERL_CALLCONV I32	Perl_my_lstat(pTHX);
803414
 #endif
803414
 PERL_CALLCONV I32	Perl_my_lstat_flags(pTHX_ const U32 flags);
803414
+PERL_CALLCONV int	Perl_my_mkostemp_cloexec(char *templte, int flags)
803414
+			__attribute__warn_unused_result__;
803414
+#define PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC	\
803414
+	assert(templte)
803414
+
803414
 PERL_CALLCONV int	Perl_my_mkstemp_cloexec(char *templte)
803414
 			__attribute__warn_unused_result__;
803414
 #define PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC	\
803414
diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t
803414
index 99d7e51..56c354b 100644
803414
--- a/t/io/perlio_open.t
803414
+++ b/t/io/perlio_open.t
803414
@@ -11,7 +11,7 @@ BEGIN {
803414
 use strict;
803414
 use warnings;
803414
 
803414
-plan tests => 6;
803414
+plan tests => 10;
803414
 
803414
 use Fcntl qw(:seek);
803414
 
803414
@@ -31,6 +31,16 @@ use Fcntl qw(:seek);
803414
     is($data, "the right read stuff", "found the right stuff");
803414
 }
803414
 
803414
-
803414
+SKIP:
803414
+{
803414
+    ok((open my $fh, "+>>", undef), "open my \$fh, '+>>', undef")
803414
+      or skip "can't open temp for append: $!", 3;
803414
+    print $fh "abc";
803414
+    ok(seek($fh, 0, SEEK_SET), "seek to zero");
803414
+    print $fh "xyz";
803414
+    ok(seek($fh, 0, SEEK_SET), "seek to zero again");
803414
+    my $data = <$fh>;
803414
+    is($data, "abcxyz", "check the second write appended");
803414
+}
803414
 
803414
 
803414
-- 
803414
2.20.1
803414