From 8e9cf86aa69cb79c91edf5ff0586f87bfe4c91bd Mon Sep 17 00:00:00 2001

From: Tony Cook <tony@develop-help.com>

Date: Tue, 2 Jul 2019 14:16:35 +1000

Subject: [PATCH] (perl #134221) support append mode for open .. undef

MIME-Version: 1.0

Content-Type: text/plain; charset=UTF-8

Content-Transfer-Encoding: 8bit

Petr Písař: Ported to 5.30.0 from

45b29440d38be155c5177c8d6f9a5d4e7c2c098c.

Signed-off-by: Petr Písař <ppisar@redhat.com>

---

 doio.c             | 15 +++++++++++++++

 embed.fnc          |  1 +

 perlio.c           | 26 +++++++++++++++++++++-----

 perlio.h           |  3 +++

 proto.h            |  5 +++++

 t/io/perlio_open.t | 14 ++++++++++++--

 6 files changed, 57 insertions(+), 7 deletions(-)

diff --git a/doio.c b/doio.c

index 05a0696..424e0e3 100644

--- a/doio.c

+++ b/doio.c

@@ -265,6 +265,21 @@ Perl_my_mkstemp_cloexec(char *templte)

 #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)

diff --git a/embed.fnc b/embed.fnc

index 259affd..c977d39 100644

--- a/embed.fnc

+++ b/embed.fnc

@@ -476,6 +476,7 @@ p	|int	|PerlLIO_dup2_cloexec|int oldfd|int newfd

 pR	|int	|PerlLIO_open_cloexec|NN const char *file|int flag

 pR	|int	|PerlLIO_open3_cloexec|NN const char *file|int flag|int perm

 pnoR	|int	|my_mkstemp_cloexec|NN char *templte

+pnoR	|int	|my_mkostemp_cloexec|NN char *templte|int flags

 #ifdef HAS_PIPE

 pR	|int	|PerlProc_pipe_cloexec|NN int *pipefd

 #endif

diff --git a/perlio.c b/perlio.c

index 904d47a..5a0cd36 100644

--- a/perlio.c

+++ b/perlio.c

@@ -1490,7 +1490,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,

 	     int imode, int perm, PerlIO *f, int narg, SV **args)

 {

     if (!f && narg == 1 && *args == &PL_sv_undef) {

-	if ((f = PerlIO_tmpfile())) {

+        int 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)

@@ -5048,6 +5050,15 @@ PerlIO_stdoutf(const char *fmt, ...)

 #undef PerlIO_tmpfile

 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;

@@ -5063,27 +5074,32 @@ PerlIO_tmpfile(void)

      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");

      SV * sv = NULL;

      int old_umask = umask(0177);

+     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 = Perl_my_mkstemp_cloexec(SvPVX(sv));

+	 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);

      }

      if (fd < 0) {

 	 SvREFCNT_dec(sv);

 	 sv = NULL;

 	 /* else we try /tmp */

-	 fd = Perl_my_mkstemp_cloexec(tempname);

+	 fd = Perl_my_mkostemp_cloexec(tempname, imode);

      }

      if (fd < 0) {

          /* Try cwd */

          sv = newSVpvs(".");

          sv_catpv(sv, tempname + 4);

-         fd = Perl_my_mkstemp_cloexec(SvPVX(sv));

+         fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);

      }

      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;

 	  PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);

diff --git a/perlio.h b/perlio.h

index d515020..ee16ab8 100644

--- a/perlio.h

+++ b/perlio.h

@@ -286,6 +286,9 @@ PERL_CALLCONV SSize_t PerlIO_get_bufsiz(PerlIO *);

 #ifndef PerlIO_tmpfile

 PERL_CALLCONV PerlIO *PerlIO_tmpfile(void);

 #endif

+#ifndef PerlIO_tmpfile_flags

+PERL_CALLCONV PerlIO *PerlIO_tmpfile_flags(int flags);

+#endif

 #ifndef PerlIO_stdin

 PERL_CALLCONV PerlIO *PerlIO_stdin(void);

 #endif

diff --git a/proto.h b/proto.h

index 74a8e46..e0ea55b 100644

--- a/proto.h

+++ b/proto.h

@@ -2270,6 +2270,11 @@ PERL_CALLCONV Pid_t	Perl_my_fork(void);

 PERL_CALLCONV I32	Perl_my_lstat(pTHX);

 #endif

 PERL_CALLCONV I32	Perl_my_lstat_flags(pTHX_ const U32 flags);

+PERL_CALLCONV int	Perl_my_mkostemp_cloexec(char *templte, int flags)

+			__attribute__warn_unused_result__;

+#define PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC	\

+	assert(templte)

+

 PERL_CALLCONV int	Perl_my_mkstemp_cloexec(char *templte)

 			__attribute__warn_unused_result__;

 #define PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC	\

diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t

index 99d7e51..56c354b 100644

--- a/t/io/perlio_open.t

+++ b/t/io/perlio_open.t

@@ -11,7 +11,7 @@ BEGIN {

 use strict;

 use warnings;

-plan tests => 6;

+plan tests => 10;

 use Fcntl qw(:seek);

@@ -31,6 +31,16 @@ use Fcntl qw(:seek);

     is($data, "the right read stuff", "found the right stuff");

 }

-

+SKIP:

+{

+    ok((open my $fh, "+>>", undef), "open my \$fh, '+>>', undef")

+      or skip "can't open temp for append: $!", 3;

+    print $fh "abc";

+    ok(seek($fh, 0, SEEK_SET), "seek to zero");

+    print $fh "xyz";

+    ok(seek($fh, 0, SEEK_SET), "seek to zero again");

+    my $data = <$fh>;

+    is($data, "abcxyz", "check the second write appended");

+}

-- 

2.20.1