In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f0fe019a81bffdc6f23c6c00d5fa100df21f8428?hp=f5957b2f8fe72d02f44bba1d1da1eb1dc6c5c6ae>
- Log ----------------------------------------------------------------- commit f0fe019a81bffdc6f23c6c00d5fa100df21f8428 Merge: f5957b2 1fa0529 Author: Nicholas Clark <[email protected]> Date: Wed Mar 19 11:03:04 2014 +0100 Merge the refactoring of Perl_do_openn() to blead. This makes Perl_do_openn() a wrapper around two functions Perl_do_open_raw() and Perl_do_open6(), which provide sysopen and open functionality. In turn, shared setup and cleanup code from these two is moved to two static functions S_openn_setup() and S_openn_cleanup(). For now both functions are not part of the public API, as they may change, and offer no functionality that isn't already accessible via Perl_do_openn(). These changes make it easi*er* to follow the twisted logic of open. commit 1fa0529f3cc4d34c0e6de25fce89bf2721ccac5f Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 10:12:08 2014 +0100 In Perl_nextargv(), move variable declarations into the blocks that use them. This makes it clearer that variables don't hold values between iterations of the loop, and permits the variable sv to be made const. M doio.c commit d8015975ab8da00c47775a05a91a9d72f379bf1b Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 10:02:51 2014 +0100 Simplify the code in Perl_nextargv(). Split the ternary that called Perl_do_open_raw() and Perl_do_open6() based on PL_inplace into two different if blocks, and merge these with the following code which is also conditional on PL_inplace. Remove the warning code from an else block and re-indent it, to make it clear that it is always called if control reaches the end of the while loop. M doio.c commit d5eb9a4687ba974ffd0d02aab53326c5aba6a9e0 Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 09:50:38 2014 +0100 Change core uses of Perl_do_openn() to Perl_do_open6() or Perl_do_open_raw(). Calls to Perl_do_openn() all have at least 2 unused arguments which clutter the code and hinder easy understanding. Perl_do_open6() and Perl_do_open_raw() each only do one job, so don't have the dead arguments. M doio.c M os2/os2.c M pp_hot.c M pp_sys.c commit 4b451737e0f77cc9e91b1336d04f21659d96b732 Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 09:26:29 2014 +0100 Split Perl_do_openn() into Perl_do_open_raw() and Perl_do_open6(). Perl_do_open_raw() handles the as_raw part of Perl_do_openn(). Perl_do_open6() handles the !as_raw part of Perl_do_openn(). do_open6() isn't a great name, but I can't see an obvious concise name that covers 2 arg open, 3 arg open, piped open, implicit fork, and layers. M doio.c M embed.fnc M embed.h M proto.h commit a6fc70e55b0240c99a09f1d7185e5c59ffd57206 Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 08:14:13 2014 +0100 Extract the cleanup code of Perl_do_openn() into S_openn_cleanup(). A 12 parameter function is extremely ugly (as demonstrated by the need to add macros for it to perl.h), but it's private, and it will permit the two-headed public interface of Perl_do_openn() to be simplified. M doio.c M embed.fnc M embed.h M perl.h M proto.h commit a2b41d5ca668b3be2860093f464392277e1d0034 Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 07:38:00 2014 +0100 Extract the setup code of Perl_do_openn() into S_openn_setup(). M doio.c M embed.fnc M embed.h M proto.h commit b4464d55c8c3facb333bef167fb547bff86d55ae Author: Nicholas Clark <[email protected]> Date: Sat Mar 1 22:53:52 2014 +0100 In Perl_do_openn(), disambiguate the two separate uses of the variable fd. Rename the first uses of the variable fd to wanted_fd to show that the variable is not used to pass a value to later in the function. M doio.c commit 26297fe91bb067fd2c1370f1d9b8b1120e30e50e Author: Nicholas Clark <[email protected]> Date: Sat Mar 1 22:38:18 2014 +0100 In Perl_do_openn(), move the variable result into the block that uses it. This also removes a couple of places which would set result = 0 to simulate "success" for an a later if block. Those paths now don't even reach that if block. M doio.c commit 9229bf8d9dfb18c8cb2feba39b2482f9fd83cf11 Author: Nicholas Clark <[email protected]> Date: Sat Mar 1 21:32:19 2014 +0100 Perl_do_openn() doesn't need to set num_svs and svp. These variables are no longer used later in the function, so no need to set them. This permits the declaration of the variable namesv to be moved from the top of the function into the blocks that use it. M doio.c commit 7c491510e1dbbc37aae15850c893746a82211cf5 Author: Nicholas Clark <[email protected]> Date: Sat Mar 1 21:10:38 2014 +0100 Perl_do_openn() should call PerlIO_openn() with arg NULL if narg is 0. If narg is NULL, then PerlIO_openn() doesn't look at args. (Technically except for PerlIOStdio_open() if f is non-NULL, which doesn't check narg and assumes that args[0] is valid. That lack of check is probably a bug. But it doesn't matter in this case, as f is NULL) This makes it clear that arg isn't needed at this point in Perl_do_openn(). This is a more complete version of the change made by commit dd37d22f759197ae (March 2002), which just changed the call to pass 0 for narg. M doio.c commit c564b489757973ad664254ae00cf16880e1f7db5 Author: Nicholas Clark <[email protected]> Date: Sat Mar 1 22:00:29 2014 +0100 In Perl_do_openn(), move {in,out}_{raw,crlf} into the !as_raw block. These 4 variables are only needed there, so by moving them into the block we save doing unneeded work for the as_raw case (ie sysopen), and as a side effect make the function a bit clearer. M doio.c commit 0c9de5b7970eafe06ebc3a92f5f24b972581372d Author: Nicholas Clark <[email protected]> Date: Sun Mar 2 15:36:52 2014 +0100 Tests that warnings are emitted if in-place edit fails to open a pathname. These have the same text as other warnings which are tested. However the existing tests only covered the code path where a directory was able to be opened (read only) and then caught by an explicit stat test for non-files. M t/lib/warnings/doio ----------------------------------------------------------------------- Summary of changes: doio.c | 340 +++++++++++++++++++++++++++++++++------------------- embed.fnc | 15 +++ embed.h | 4 + os2/os2.c | 2 +- perl.h | 2 + pp_hot.c | 2 +- pp_sys.c | 7 +- proto.h | 30 +++++ t/lib/warnings/doio | 26 +++- 9 files changed, 291 insertions(+), 137 deletions(-) diff --git a/doio.c b/doio.c index bdff84c..e2bfda5 100644 --- a/doio.c +++ b/doio.c @@ -60,81 +60,106 @@ #include <signal.h> -bool -Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, - I32 num_svs) +static IO * +S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, + int *savefd, char *savetype) { dVAR; IO * const io = GvIOn(gv); - PerlIO *saveifp = NULL; - PerlIO *saveofp = NULL; - int savefd = -1; - char savetype = IoTYPE_CLOSED; - int writing = 0; - PerlIO *fp; - int fd; - int result; - bool was_fdopen = FALSE; - bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; - char *type = NULL; - char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ - SV *namesv; - PERL_ARGS_ASSERT_DO_OPENN; + PERL_ARGS_ASSERT_OPENN_SETUP; + + *saveifp = NULL; + *saveofp = NULL; + *savefd = -1; + *savetype = IoTYPE_CLOSED; Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ - /* Collect default raw/crlf info from the op */ - if (PL_op && PL_op->op_type == OP_OPEN) { - /* set up IO layers */ - const U8 flags = PL_op->op_private; - in_raw = (flags & OPpOPEN_IN_RAW); - in_crlf = (flags & OPpOPEN_IN_CRLF); - out_raw = (flags & OPpOPEN_OUT_RAW); - out_crlf = (flags & OPpOPEN_OUT_CRLF); - } - /* If currently open - close before we re-open */ if (IoIFP(io)) { - fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == IoTYPE_STD) { /* This is a clone of one of STD* handles */ - result = 0; - } - else if (fd >= 0 && fd <= PL_maxsysfd) { - /* This is one of the original STD* handles */ - saveifp = IoIFP(io); - saveofp = IoOFP(io); - savetype = IoTYPE(io); - savefd = fd; - result = 0; - } - else if (IoTYPE(io) == IoTYPE_PIPE) - result = PerlProc_pclose(IoIFP(io)); - else if (IoIFP(io) != IoOFP(io)) { - if (IoOFP(io)) { - result = PerlIO_close(IoOFP(io)); - PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ - } - else - result = PerlIO_close(IoIFP(io)); - } - else - result = PerlIO_close(IoIFP(io)); - if (result == EOF && fd > PL_maxsysfd) { - /* Why is this not Perl_warn*() call ? */ - PerlIO_printf(Perl_error_log, - "Warning: unable to close filehandle %"HEKf" properly.\n", - HEKfARG(GvENAME_HEK(gv)) - ); } + else { + const int old_fd = PerlIO_fileno(IoIFP(io)); + + if (old_fd >= 0 && old_fd <= PL_maxsysfd) { + /* This is one of the original STD* handles */ + *saveifp = IoIFP(io); + *saveofp = IoOFP(io); + *savetype = IoTYPE(io); + *savefd = old_fd; + } + else { + int result; + + if (IoTYPE(io) == IoTYPE_PIPE) + result = PerlProc_pclose(IoIFP(io)); + else if (IoIFP(io) != IoOFP(io)) { + if (IoOFP(io)) { + result = PerlIO_close(IoOFP(io)); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ + } + else + result = PerlIO_close(IoIFP(io)); + } + else + result = PerlIO_close(IoIFP(io)); + + if (result == EOF && old_fd > PL_maxsysfd) { + /* Why is this not Perl_warn*() call ? */ + PerlIO_printf(Perl_error_log, + "Warning: unable to close filehandle %"HEKf" properly.\n", + HEKfARG(GvENAME_HEK(gv)) + ); + } + } + } IoOFP(io) = IoIFP(io) = NULL; } + return io; +} + +bool +Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, + int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, + I32 num_svs) +{ + PERL_ARGS_ASSERT_DO_OPENN; if (as_raw) { /* sysopen style args, i.e. integer mode and permissions */ + + if (num_svs != 0) { + Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", + (long) num_svs); + } + return do_open_raw(gv, oname, len, rawmode, rawperm); + } + return do_open6(gv, oname, len, supplied_fp, svp, num_svs); +} + +bool +Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, + int rawmode, int rawperm) +{ + dVAR; + PerlIO *saveifp; + PerlIO *saveofp; + int savefd; + char savetype; + char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ + IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); + int writing = 0; + PerlIO *fp; + + PERL_ARGS_ASSERT_DO_OPEN_RAW; + + /* For ease of blame back to 5.000, keep the existing indenting. */ + { + /* sysopen style args, i.e. integer mode and permissions */ STRLEN ix = 0; const int appendtrunc = 0 @@ -147,11 +172,8 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, ; const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; int ismodifying; + SV *namesv; - if (num_svs != 0) { - Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", - (long) num_svs); - } /* It's not always O_RDONLY 0 @@ -183,17 +205,48 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); namesv = newSVpvn_flags(oname, len, SVs_TEMP); - num_svs = 1; - svp = &namesv; - type = NULL; - fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp); + fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); } - else { + return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, + savetype, writing, 0, NULL); +} + +bool +Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, + PerlIO *supplied_fp, SV **svp, U32 num_svs) +{ + dVAR; + PerlIO *saveifp; + PerlIO *saveofp; + int savefd; + char savetype; + char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ + IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); + int writing = 0; + PerlIO *fp; + bool was_fdopen = FALSE; + char *type = NULL; + + PERL_ARGS_ASSERT_DO_OPEN6; + + /* For ease of blame back to 5.000, keep the existing indenting. */ + { /* Regular (non-sys) open */ char *name; STRLEN olen = len; char *tend; int dodup = 0; + bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; + + /* Collect default raw/crlf info from the op */ + if (PL_op && PL_op->op_type == OP_OPEN) { + /* set up IO layers */ + const U8 flags = PL_op->op_private; + in_raw = (flags & OPpOPEN_IN_RAW); + in_crlf = (flags & OPpOPEN_IN_CRLF); + out_raw = (flags & OPpOPEN_OUT_RAW); + out_crlf = (flags & OPpOPEN_OUT_CRLF); + } type = savepvn(oname, len); tend = type+len; @@ -215,13 +268,16 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, Perl_warner(aTHX_ packWARN(WARN_IO), "Can't open a reference"); SETERRNO(EINVAL, LIB_INVARG); + fp = NULL; goto say_false; } #endif /* USE_STDIO */ p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; - if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) + if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) { + fp = NULL; goto say_false; + } name = p ? savepvn(p, nlen) : savepvs(""); @@ -260,6 +316,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); errno = EPIPE; + fp = NULL; goto say_false; } if (!(*name == '-' && name[1] == '\0') || num_svs) @@ -285,6 +342,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, if (num_svs) { if (*type) { if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + fp = NULL; goto say_false; } } @@ -321,6 +379,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, } else { PerlIO *that_fp = NULL; + int wanted_fd; if (num_svs > 1) { /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); @@ -331,11 +390,11 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, SvIOK(*svp) || (SvPOKp(*svp) && looks_like_number(*svp)) )) { - fd = SvUV(*svp); + wanted_fd = SvUV(*svp); num_svs = 0; } else if (isDIGIT(*type)) { - fd = atoi(type); + wanted_fd = atoi(type); } else { const IO* thatio; @@ -351,6 +410,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, #ifdef EINVAL SETERRNO(EINVAL,SS_IVCHAN); #endif + fp = NULL; goto say_false; } if ((that_fp = IoIFP(thatio))) { @@ -364,7 +424,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, * filehandle? Perhaps we should do * fsetpos(src)+fgetpos(dst)? --nik */ PerlIO_flush(that_fp); - fd = PerlIO_fileno(that_fp); + wanted_fd = PerlIO_fileno(that_fp); /* When dup()ing STDIN, STDOUT or STDERR * explicitly set appropriate access mode */ if (that_fp == PerlIO_stdout() @@ -378,7 +438,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, IoTYPE(io) = IoTYPE_SOCKET; } else - fd = -1; + wanted_fd = -1; } if (!num_svs) type = NULL; @@ -387,12 +447,12 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, } else { if (dodup) - fd = PerlLIO_dup(fd); + wanted_fd = PerlLIO_dup(wanted_fd); else was_fdopen = TRUE; - if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { - if (dodup && fd >= 0) - PerlLIO_close(fd); + if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) { + if (dodup && wanted_fd >= 0) + PerlLIO_close(wanted_fd); } } } @@ -410,13 +470,14 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, } } else { - if (!num_svs) { - namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - num_svs = 1; - svp = &namesv; + if (num_svs) { + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); + } + else { + SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); type = NULL; + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); } - fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } /* !& */ if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) @@ -444,13 +505,14 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, } } else { - if (!num_svs) { - namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - num_svs = 1; - svp = &namesv; + if (num_svs) { + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); + } + else { + SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); type = NULL; + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); } - fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) goto unknown_open_mode; @@ -475,6 +537,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); errno = EPIPE; + fp = NULL; goto say_false; } if (!(*name == '-' && name[1] == '\0') || num_svs) @@ -499,6 +562,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, type++; if (*type) { if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + fp = NULL; goto say_false; } } @@ -523,16 +587,34 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, IoTYPE(io) = IoTYPE_STD; } else { - if (!num_svs) { - namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - num_svs = 1; - svp = &namesv; + if (num_svs) { + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); + } + else { + SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); type = NULL; + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); } - fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } } + + say_false: + return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, + savetype, writing, was_fdopen, type); +} + +/* Yes, this is ugly, but it's private, and I don't see a cleaner way to + simplify the two-headed public interface of do_openn. */ +static bool +S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, + PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype, + int writing, bool was_fdopen, const char *type) +{ + int fd; + + PERL_ARGS_ASSERT_OPENN_CLEANUP; + if (!fp) { if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) && strchr(oname, '\n') @@ -687,7 +769,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) s++; *s = 'w'; - if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) { + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { PerlIO_close(fp); IoIFP(io) = NULL; goto say_false; @@ -709,13 +791,6 @@ PerlIO * Perl_nextargv(pTHX_ GV *gv) { dVAR; - SV *sv; -#ifndef FLEXFILENAMES - int filedev; - int fileino; -#endif - Uid_t fileuid; - Gid_t filegid; IO * const io = GvIOp(gv); PERL_ARGS_ASSERT_NEXTARGV; @@ -745,14 +820,30 @@ Perl_nextargv(pTHX_ GV *gv) return NULL; while (av_tindex(GvAV(gv)) >= 0) { STRLEN oldlen; - sv = av_shift(GvAV(gv)); + SV *const sv = av_shift(GvAV(gv)); SAVEFREESV(sv); SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ sv_setsv(GvSVn(gv),sv); SvSETMAGIC(GvSV(gv)); PL_oldname = SvPVx(GvSV(gv), oldlen); - if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,NULL)) { - if (PL_inplace) { + if (LIKELY(!PL_inplace)) { + if (do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)) { + return IoIFP(GvIOp(gv)); + } + } + else { + /* This very long block ends with return IoIFP(GvIOp(gv)); + Both this block and the block above fall through on open + failure to the warning code, and then the while loop above tries + the next entry. */ + if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) { +#ifndef FLEXFILENAMES + int filedev; + int fileino; +#endif + Uid_t fileuid; + Gid_t filegid; + TAINT_PROPER("inplace open"); if (oldlen == 1 && *PL_oldname == '-') { setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, @@ -818,7 +909,7 @@ Perl_nextargv(pTHX_ GV *gv) do_close(gv,FALSE); (void)PerlLIO_unlink(SvPVX_const(sv)); (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv)); - do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),TRUE,O_RDONLY,0,NULL); + do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0); #endif /* DOSISH */ #else (void)UNLINK(SvPVX_const(sv)); @@ -850,14 +941,14 @@ Perl_nextargv(pTHX_ GV *gv) sv_setpvn(sv,PL_oldname,oldlen); SETERRNO(0,0); /* in case sprintf set errno */ - if (!Perl_do_openn(aTHX_ PL_argvoutgv, (char*)SvPVX_const(sv), - SvCUR(sv), TRUE, + if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv), + SvCUR(sv), #ifdef VMS - O_WRONLY|O_CREAT|O_TRUNC,0, + O_WRONLY|O_CREAT|O_TRUNC, 0 #else - O_WRONLY|O_CREAT|OPEN_EXCL,0600, + O_WRONLY|O_CREAT|OPEN_EXCL, 0600 #endif - NULL, NULL, 0)) { + )) { Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", PL_oldname, Strerror(errno) ); do_close(gv,FALSE); @@ -883,23 +974,22 @@ Perl_nextargv(pTHX_ GV *gv) /* XXX silently ignore failures */ PERL_UNUSED_VAR(rc); } + return IoIFP(GvIOp(gv)); } - return IoIFP(GvIOp(gv)); - } - else { - if (ckWARN_d(WARN_INPLACE)) { - const int eno = errno; - if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 - && !S_ISREG(PL_statbuf.st_mode)) - { - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s is not a regular file", - PL_oldname); - } - else - Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", - PL_oldname, Strerror(eno)); - } + } /* successful do_open_raw(), PL_inplace non-NULL */ + + if (ckWARN_d(WARN_INPLACE)) { + const int eno = errno; + if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 + && !S_ISREG(PL_statbuf.st_mode)) { + Perl_warner(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %s is not a regular file", + PL_oldname); + } + else { + Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", + PL_oldname, Strerror(eno)); + } } } if (io && (IoFLAGS(io) & IOf_ARGV)) @@ -2433,8 +2523,8 @@ Perl_vms_start_glob if (home && *home) SvSETMAGIC(*home); if (path && *path) SvSETMAGIC(*path); } - (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd), - FALSE, O_RDONLY, 0, NULL); + (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd), + NULL, NULL, 0); fp = IoIFP(io); #endif /* !VMS */ LEAVE; diff --git a/embed.fnc b/embed.fnc index c85d219..567e587 100644 --- a/embed.fnc +++ b/embed.fnc @@ -394,10 +394,25 @@ Apmb |bool |do_open |NN GV* gv|NN const char* name|I32 len|int as_raw \ Ap |bool |do_open9 |NN GV *gv|NN const char *name|I32 len|int as_raw \ |int rawmode|int rawperm|NULLOK PerlIO *supplied_fp \ |NN SV *svs|I32 num +#if defined(PERL_IN_DOIO_C) +s |IO * |openn_setup |NN GV *gv|NN char *mode|NN PerlIO **saveifp \ + |NN PerlIO **saveofp|NN int *savefd \ + |NN char *savetype +s |bool |openn_cleanup |NN GV *gv|NN IO *io|NULLOK PerlIO *fp \ + |NN char *mode|NN const char *oname \ + |NULLOK PerlIO *saveifp|NULLOK PerlIO *saveofp \ + |int savefd|char savetype|int writing \ + |bool was_fdopen|NULLOK const char *type +#endif Ap |bool |do_openn |NN GV *gv|NN const char *oname|I32 len \ |int as_raw|int rawmode|int rawperm \ |NULLOK PerlIO *supplied_fp|NULLOK SV **svp \ |I32 num +Mp |bool |do_open_raw |NN GV *gv|NN const char *oname|STRLEN len \ + |int rawmode|int rawperm +Mp |bool |do_open6 |NN GV *gv|NN const char *oname|STRLEN len \ + |NULLOK PerlIO *supplied_fp|NULLOK SV **svp \ + |U32 num : Used in pp_hot.c and pp_sys.c p |bool |do_print |NULLOK SV* sv|NN PerlIO* fp : Used in pp_sys.c diff --git a/embed.h b/embed.h index 824d294..0ddaca7 100644 --- a/embed.h +++ b/embed.h @@ -1101,6 +1101,8 @@ #define do_eof(a) Perl_do_eof(aTHX_ a) #define do_execfree() Perl_do_execfree(aTHX) #define do_ncmp(a,b) Perl_do_ncmp(aTHX_ a,b) +#define do_open6(a,b,c,d,e,f) Perl_do_open6(aTHX_ a,b,c,d,e,f) +#define do_open_raw(a,b,c,d,e) Perl_do_open_raw(aTHX_ a,b,c,d,e) #define do_print(a,b) Perl_do_print(aTHX_ a,b) #define do_readline() Perl_do_readline(aTHX) #define do_seek(a,b,c) Perl_do_seek(aTHX_ a,b,c) @@ -1383,6 +1385,8 @@ # if defined(PERL_IN_DOIO_C) #define exec_failed(a,b,c) S_exec_failed(aTHX_ a,b,c) #define ingroup(a,b) S_ingroup(aTHX_ a,b) +#define openn_cleanup(a,b,c,d,e,f,g,h,i,j,k,l) S_openn_cleanup(aTHX_ a,b,c,d,e,f,g,h,i,j,k,l) +#define openn_setup(a,b,c,d,e,f) S_openn_setup(aTHX_ a,b,c,d,e,f) # endif # if defined(PERL_IN_DOOP_C) #define do_trans_complex(a) S_do_trans_complex(aTHX_ a) diff --git a/os2/os2.c b/os2/os2.c index d4e9c90..4ae39e7 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -4257,7 +4257,7 @@ XS(XS_OS2_pipe) ST(0) = sv_newmortal(); { GV *gv = newGVgen("OS2::pipe"); - if ( do_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) ) + if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) ) sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); else ST(0) = &PL_sv_undef; diff --git a/perl.h b/perl.h index 574a8a3..6da39f3 100644 --- a/perl.h +++ b/perl.h @@ -175,6 +175,7 @@ # define pTHX_7 8 # define pTHX_8 9 # define pTHX_9 10 +# define pTHX_12 13 # if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL) # define PERL_TRACK_MEMPOOL # endif @@ -384,6 +385,7 @@ # define pTHX_7 7 # define pTHX_8 8 # define pTHX_9 9 +# define pTHX_12 12 #endif #ifndef dVAR diff --git a/pp_hot.c b/pp_hot.c index 3a19f52..c3637cd 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1562,7 +1562,7 @@ Perl_do_readline(pTHX) IoLINES(io) = 0; if (av_tindex(GvAVn(PL_last_in_gv)) < 0) { IoFLAGS(io) &= ~IOf_START; - do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL); + do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ sv_setpvs(GvSVn(PL_last_in_gv), "-"); SvSETMAGIC(GvSV(PL_last_in_gv)); diff --git a/pp_sys.c b/pp_sys.c index 01e397a..9f97177 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -638,7 +638,7 @@ PP(pp_open) } tmps = SvPV_const(sv, len); - ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK)); + ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) PUSHi( (I32)PL_forkprocess ); @@ -1598,8 +1598,7 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); - /* FIXME? do_open should do const */ - if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) { + if (do_open_raw(gv, tmps, len, mode, perm)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } @@ -2088,7 +2087,7 @@ PP(pp_eof) if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) { IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); + do_open6(gv, "-", 1, NULL, NULL, 0); if (GvSV(gv)) sv_setpvs(GvSV(gv), "-"); else diff --git a/proto.h b/proto.h index b4f22dd..dd5edde 100644 --- a/proto.h +++ b/proto.h @@ -934,6 +934,12 @@ PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #define PERL_ARGS_ASSERT_DO_OPEN \ assert(gv); assert(name) +PERL_CALLCONV bool Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, PerlIO *supplied_fp, SV **svp, U32 num) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_DO_OPEN6 \ + assert(gv); assert(oname) + PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) @@ -941,6 +947,12 @@ PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int as #define PERL_ARGS_ASSERT_DO_OPEN9 \ assert(gv); assert(name); assert(svs) +PERL_CALLCONV bool Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, int rawmode, int rawperm) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_DO_OPEN_RAW \ + assert(gv); assert(oname) + PERL_CALLCONV bool Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); @@ -5712,6 +5724,24 @@ STATIC void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) STATIC bool S_ingroup(pTHX_ Gid_t testgid, bool effective) __attribute__warn_unused_result__; +STATIC bool S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype, int writing, bool was_fdopen, const char *typ ... [2 chars truncated] + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_4) + __attribute__nonnull__(pTHX_5); +#define PERL_ARGS_ASSERT_OPENN_CLEANUP \ + assert(gv); assert(io); assert(mode); assert(oname) + +STATIC IO * S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, int *savefd, char *savetype) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3) + __attribute__nonnull__(pTHX_4) + __attribute__nonnull__(pTHX_5) + __attribute__nonnull__(pTHX_6); +#define PERL_ARGS_ASSERT_OPENN_SETUP \ + assert(gv); assert(mode); assert(saveifp); assert(saveofp); assert(savefd); assert(savetype) + #endif #if defined(PERL_IN_DOOP_C) STATIC I32 S_do_trans_complex(pTHX_ SV * const sv) diff --git a/t/lib/warnings/doio b/t/lib/warnings/doio index bf0cd78..63250e1 100644 --- a/t/lib/warnings/doio +++ b/t/lib/warnings/doio @@ -209,31 +209,45 @@ EXPECT ######## # doio.c [Perl_nextargv] $^W = 0 ; +# These happen to warn at different points within doio.c +# This will open read only, and then be caught by an explicit check: my $filename = "./temp.dir" ; +# Whereas these two will fail to open: +my $dir0 = "./zero.dir" ; +# but files and directories have a different error message if they don't open: +my $file3 = "date|" ; mkdir $filename, 0777 or die "Cannot create directory $filename: $!\n" ; +mkdir $dir0, 0 + or die "Cannot create directory dir0: $!\n" ; { - local (@ARGV) = ($filename) ; + local (@ARGV) = ($filename, $dir0, $file3) ; local ($^I) = "" ; my $x = <> ; } { no warnings 'inplace' ; - local (@ARGV) = ($filename) ; + local (@ARGV) = ($filename, $dir0, $file3) ; local ($^I) = "" ; my $x = <> ; } { use warnings 'inplace' ; - local (@ARGV) = ($filename) ; + local (@ARGV) = ($filename, $dir0, $file3) ; local ($^I) = "" ; my $x = <> ; } rmdir $filename ; +chmod 0777, $dir0 ; +rmdir $dir0 ; EXPECT -Can't do inplace edit: ./temp.dir is not a regular file at - line 9. -Can't do inplace edit: ./temp.dir is not a regular file at - line 21. - +OPTION regex +Can't do inplace edit: \./temp\.dir is not a regular file at - line 17\. +Can't do inplace edit: \./zero\.dir is not a regular file at - line 17\. +Can't open date\|: .*? at - line 17\. +Can't do inplace edit: \./temp\.dir is not a regular file at - line 29\. +Can't do inplace edit: \./zero\.dir is not a regular file at - line 29\. +Can't open date\|: .*? at - line 29\. ######## # doio.c [Perl_do_eof] use warnings 'io' ; -- Perl5 Master Repository
