X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/111f73b5d79a652d1b6c6e3df3c6cd4c14c17ea7..cd52bc19d9de6bc9b42404c62e1ebe91ca4b3e3e:/doio.c diff --git a/doio.c b/doio.c index 205365a..0eec22c 100644 --- a/doio.c +++ b/doio.c @@ -60,81 +60,106 @@ #include -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,19 +587,37 @@ 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') + && should_warn_nl(oname) ) { @@ -579,11 +661,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ #ifdef HAS_SOCKET else if ( -#ifdef S_IFMT !(PL_statbuf.st_mode & S_IFMT) -#else - !PL_statbuf.st_mode -#endif && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ ) { /* on OS's that return 0 on fstat()ed pipe */ @@ -691,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; @@ -713,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; @@ -749,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, @@ -822,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)); @@ -854,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); @@ -887,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)) @@ -1321,7 +1407,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags) s = SvPVX_const(PL_statname); /* s now NUL-terminated */ PL_laststype = OP_STAT; PL_laststatval = PerlLIO_stat(s, &PL_statcache); - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) { + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); GCC_DIAG_RESTORE; @@ -1384,7 +1470,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) file = SvPV_flags_const_nolen(sv, flags); sv_setpv(PL_statname,file); PL_laststatval = PerlLIO_lstat(file,&PL_statcache); - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) { + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); GCC_DIAG_RESTORE; @@ -1821,7 +1907,7 @@ nothing in the core. tot--; else if (S_ISDIR(PL_statbuf.st_mode)) { tot--; - SETERRNO(EISDIR, SS$_NOPRIV); + SETERRNO(EISDIR, SS_NOPRIV); } else { if (UNLINK(s)) @@ -2437,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;