In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/910b8b92a5c097593b840ac1eee578d2da08ad44?hp=dc9ac3ee562166ff93b09c2b5a63cc5c51748c7f>
- Log ----------------------------------------------------------------- commit 910b8b92a5c097593b840ac1eee578d2da08ad44 Merge: dc9ac3ee56 74b421cc87 Author: Tony Cook <[email protected]> Date: Tue Jul 16 15:59:29 2019 +1000 (perl #134221) preserve O_APPEND for open ... undef calls. For most systems this means switching from mkstemp() to mkostemp(), which Zefram helpfully added an emulation for. For Win32 the append seems to happen in the POSIX emulation, not in WriteFile(), so we can simply supply the flags to _open_osfhandle(). After some discussion with Craig Berry, the VMS version of the code now uses largely the same mkostemp() code, with some special code in the mkostemp() emulation to allow marking the file to be deleted automatically when closed. commit 74b421cc877e412c4eda06757396a1e19fc756ba Author: Tony Cook <[email protected]> Date: Mon Jul 15 11:53:23 2019 +1000 (perl #134221) support O_APPEND for open ..., undef on VMS VMS doesn't allow you to delete an open file like POSIXish systems do, but you can mark a file to be deleted once it's closed, but only when you open it. Since VMS doesn't (yet) have mkostemp() we can add our own flag to our mkostemp() emulation to pass the necessary magic to open() call to delete the file on close. commit 0424723402ef153af8ee44222315d9b6a818d1ba Author: Tony Cook <[email protected]> Date: Tue Jul 2 15:22:26 2019 +1000 (perl #134221) support append mode temp files on Win32 too commit ae73d7ec2329275a2dba4be24415743f884d9dfd Author: Tony Cook <[email protected]> Date: Tue Jul 2 14:16:35 2019 +1000 (perl #134221) support append mode for open .. undef ----------------------------------------------------------------------- Summary of changes: doio.c | 15 +++++++++++++++ embed.fnc | 1 + perlio.c | 32 +++++++++++++++++++++++++------- perlio.h | 3 +++ proto.h | 5 +++++ t/io/perlio_open.t | 14 ++++++++++++-- util.c | 15 ++++++++++++++- util.h | 11 +++++++++++ win32/win32.c | 10 +++++++++- win32/win32iop.h | 1 + 10 files changed, 96 insertions(+), 11 deletions(-) diff --git a/doio.c b/doio.c index 05a06968dc..424e0e3205 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 bfc9dca241..c2c56699d6 100644 --- a/embed.fnc +++ b/embed.fnc @@ -543,6 +543,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 pToR |int |my_mkstemp_cloexec|NN char *templte +pToR |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 d32aed0392..805959f840 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) @@ -5042,45 +5044,61 @@ 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; #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(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); + 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 | O_VMS_DELETEONCLOSE); } 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 | O_VMS_DELETEONCLOSE); } 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 | 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(). */ diff --git a/perlio.h b/perlio.h index d515020618..ee16ab8774 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 a708e142cd..58b0816840 100644 --- a/proto.h +++ b/proto.h @@ -2275,6 +2275,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 99d7e51646..56c354bf67 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"); +} diff --git a/util.c b/util.c index e6863f6dfe..165d13a39e 100644 --- a/util.c +++ b/util.c @@ -5712,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) { STRLEN len = strlen(templte); int fd; int attempts = 0; +#ifdef VMS + int delete_on_close = flags & O_VMS_DELETEONCLOSE; + + flags &= ~O_VMS_DELETEONCLOSE; +#endif if (len < 6 || templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' || @@ -5725,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) { for (i = 1; i <= 6; ++i) { templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)]; } - fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); +#ifdef VMS + if (delete_on_close) { + fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt"); + } + else +#endif + { + fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); + } } while (fd == -1 && errno == EEXIST && ++attempts <= 100); return fd; diff --git a/util.h b/util.h index d8fa3e8396..d9df7b39c6 100644 --- a/util.h +++ b/util.h @@ -248,6 +248,17 @@ means arg not present, 1 is empty string/null byte */ int mkstemp(char*); #endif +#ifdef PERL_CORE +# if defined(VMS) +/* only useful for calls to our mkostemp() emulation */ +# define O_VMS_DELETEONCLOSE 0x40000000 +# ifdef HAS_MKOSTEMP +# error 134221 will need a new solution for VMS +# endif +# else +# define O_VMS_DELETEONCLOSE 0 +# endif +#endif #if defined(HAS_MKOSTEMP) && defined(PERL_CORE) # define Perl_my_mkostemp(templte, flags) mkostemp(templte, flags) #endif diff --git a/win32/win32.c b/win32/win32.c index 8104d864c2..91fdffe09b 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -2907,10 +2907,18 @@ win32_rewind(FILE *pf) DllExport int win32_tmpfd(void) +{ + return win32_tmpfd_mode(0); +} + +DllExport int +win32_tmpfd_mode(int mode) { char prefix[MAX_PATH+1]; char filename[MAX_PATH+1]; DWORD len = GetTempPath(MAX_PATH, prefix); + mode &= ~( O_ACCMODE | O_CREAT | O_EXCL ); + mode |= O_RDWR; if (len && len < MAX_PATH) { if (GetTempFileName(prefix, "plx", 0, filename)) { HANDLE fh = CreateFile(filename, @@ -2922,7 +2930,7 @@ win32_tmpfd(void) | FILE_FLAG_DELETE_ON_CLOSE, NULL); if (fh != INVALID_HANDLE_VALUE) { - int fd = win32_open_osfhandle((intptr_t)fh, 0); + int fd = win32_open_osfhandle((intptr_t)fh, mode); if (fd >= 0) { PERL_DEB(dTHX;) DEBUG_p(PerlIO_printf(Perl_debug_log, diff --git a/win32/win32iop.h b/win32/win32iop.h index 53330e5951..559e1f9cd2 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -64,6 +64,7 @@ DllExport int win32_fgetpos(FILE *pf,fpos_t *p); DllExport int win32_fsetpos(FILE *pf,const fpos_t *p); DllExport void win32_rewind(FILE *pf); DllExport int win32_tmpfd(void); +DllExport int win32_tmpfd_mode(int mode); DllExport FILE* win32_tmpfile(void); DllExport void win32_abort(void); DllExport int win32_fstat(int fd,Stat_t *sbufptr); -- Perl5 Master Repository
