X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=a953d54dd21bc42731627fd70be104dd8cc2d6ba;hb=b0ce926a45891e83ffb4badae874161f93c0eb49;hp=39e2e9f6acbb2cd8371dc93f66c9ee24c943401e;hpb=6520202708b2a849ca8538ed88e0f75376c3b2d7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index 39e2e9f..a953d54 100644 --- a/doio.c +++ b/doio.c @@ -87,7 +87,17 @@ #endif bool -Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp) +Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, + int rawmode, int rawperm, PerlIO *supplied_fp) +{ + return do_open9(gv, name, len, as_raw, rawmode, rawperm, + supplied_fp, Nullsv, 0); +} + +bool +Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, + int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, + I32 num_svs) { register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; @@ -116,7 +126,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode else if (IoIFP(io) != IoOFP(io)) { if (IoOFP(io)) { result = PerlIO_close(IoOFP(io)); - PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else result = PerlIO_close(IoIFP(io)); @@ -124,8 +134,9 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode else result = PerlIO_close(IoIFP(io)); if (result == EOF && fd > PL_maxsysfd) - PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n", - GvENAME(gv)); + PerlIO_printf(PerlIO_stderr(), + "Warning: unable to close filehandle %s properly.\n", + GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } @@ -173,26 +184,44 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode } else { char *myname; + char *type = name; + char *otype = name; + STRLEN tlen; + STRLEN otlen = len; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ int dodup; + if (num_svs) { + type = name; + name = SvPV(svs, tlen) ; + len = (I32)tlen; + } + + tlen = otlen; myname = savepvn(name, len); SAVEFREEPV(myname); name = myname; - while (len && isSPACE(name[len-1])) - name[--len] = '\0'; + if (!num_svs) + while (tlen && isSPACE(type[tlen-1])) + type[--tlen] = '\0'; mode[0] = mode[1] = mode[2] = '\0'; - IoTYPE(io) = *name; - if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ - mode[1] = *name++; - --len; + IoTYPE(io) = *type; + if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */ + mode[1] = *type++; + --tlen; writing = 1; } - if (*name == '|') { + if (*type == '|') { + if (num_svs && (tlen != 2 || type[1] != '-')) { + unknown_desr: + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype); + } /*SUPPRESS 530*/ - for (name++; isSPACE(*name); name++) ; + for (type++; isSPACE(*type); type++) ; + if (!num_svs) + name = type; if (*name == '\0') { /* command is missing 19990114 */ dTHR; if (ckWARN(WARN_PIPE)) @@ -200,7 +229,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode errno = EPIPE; goto say_false; } - if (strNE(name,"-")) + if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); if (name[strlen(name)-1] == '|') { @@ -212,18 +241,22 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode fp = PerlProc_popen(name,"w"); writing = 1; } - else if (*name == '>') { + else if (*type == '>') { TAINT_PROPER("open"); - name++; - if (*name == '>') { + type++; + if (*type == '>') { mode[0] = IoTYPE(io) = 'a'; - name++; + type++; + tlen--; } else mode[0] = 'w'; writing = 1; - if (*name == '&') { + if (num_svs && tlen != 1) + goto unknown_desr; + if (*type == '&') { + name = type; duplicity: dodup = 1; name++; @@ -249,7 +282,10 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode goto say_false; } if (IoIFP(thatio)) { - fd = PerlIO_fileno(IoIFP(thatio)); + PerlIO *fp = IoIFP(thatio); + /* Flush stdio buffer before dup */ + PerlIO_seek(fp, 0, SEEK_CUR); + fd = PerlIO_fileno(fp); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } @@ -268,35 +304,46 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode } else { /*SUPPRESS 530*/ - for (; isSPACE(*name); name++) ; - if (strEQ(name,"-")) { + for (; isSPACE(*type); type++) ; + if (strEQ(type,"-")) { fp = PerlIO_stdout(); IoTYPE(io) = '-'; } else { - fp = PerlIO_open(name,mode); + fp = PerlIO_open((num_svs ? name : type), mode); } } } - else if (*name == '<') { + else if (*type == '<') { + if (num_svs && tlen != 1) + goto unknown_desr; /*SUPPRESS 530*/ - for (name++; isSPACE(*name); name++) ; + for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; - if (*name == '&') + if (*type == '&') { + name = type; goto duplicity; - if (strEQ(name,"-")) { + } + if (strEQ(type,"-")) { fp = PerlIO_stdin(); IoTYPE(io) = '-'; } else - fp = PerlIO_open(name,mode); + fp = PerlIO_open((num_svs ? name : type), mode); } - else if (len > 1 && name[len-1] == '|') { - name[--len] = '\0'; - while (len && isSPACE(name[len-1])) - name[--len] = '\0'; - /*SUPPRESS 530*/ - for (; isSPACE(*name); name++) ; + else if (tlen > 1 && type[tlen-1] == '|') { + if (num_svs) { + if (tlen != 2 || type[0] != '-') + goto unknown_desr; + } + else { + type[--tlen] = '\0'; + while (tlen && isSPACE(type[tlen-1])) + type[--tlen] = '\0'; + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; + name = type; + } if (*name == '\0') { /* command is missing 19990114 */ dTHR; if (ckWARN(WARN_PIPE)) @@ -304,13 +351,16 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode errno = EPIPE; goto say_false; } - if (strNE(name,"-")) + if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); fp = PerlProc_popen(name,"r"); IoTYPE(io) = '|'; } else { + if (num_svs) + goto unknown_desr; + name = type; IoTYPE(io) = '<'; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; @@ -366,7 +416,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode } } if (fd != PerlIO_fileno(fp)) { - int pid; + Pid_t pid; SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); @@ -460,8 +510,10 @@ Perl_nextargv(pTHX_ register GV *gv) fileuid = PL_statbuf.st_uid; filegid = PL_statbuf.st_gid; if (!S_ISREG(PL_filemode)) { - Perl_warn(aTHX_ "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); do_close(gv,FALSE); continue; } @@ -488,18 +540,23 @@ Perl_nextargv(pTHX_ register GV *gv) #ifdef DJGPP || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0 #endif - ) { - Perl_warn(aTHX_ "Can't do inplace edit: %s would not be unique", - SvPVX(sv) ); + ) + { + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't do inplace edit: %s would not be unique", + SvPVX(sv)); do_close(gv,FALSE); continue; } #endif #ifdef HAS_RENAME -#ifndef DOSISH +#if !defined(DOSISH) && !defined(CYGWIN) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { - Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't rename %s to %s: %s, skipping file", + PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -512,8 +569,10 @@ Perl_nextargv(pTHX_ register GV *gv) #else (void)UNLINK(SvPVX(sv)); if (link(PL_oldname,SvPVX(sv)) < 0) { - Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't rename %s to %s: %s, skipping file", + PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -524,8 +583,10 @@ Perl_nextargv(pTHX_ register GV *gv) #if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(PL_oldname) < 0) { - Perl_warn(aTHX_ "Can't remove %s: %s, skipping file", - PL_oldname, Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't remove %s: %s, skipping file", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -545,8 +606,9 @@ Perl_nextargv(pTHX_ register GV *gv) if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { #endif - Perl_warn(aTHX_ "Can't do inplace edit on %s: %s", - PL_oldname, Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -573,9 +635,18 @@ Perl_nextargv(pTHX_ register GV *gv) } return IoIFP(GvIOp(gv)); } - else - PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n", - SvPV(sv, oldlen), Strerror(errno)); + else { + dTHR; + if (ckWARN_d(WARN_INPLACE)) { + if (!S_ISREG(PL_statbuf.st_mode)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); + else + Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s\n", + PL_oldname, Strerror(errno)); + } + } } if (PL_inplace) { (void)do_close(PL_argvoutgv,FALSE); @@ -654,7 +725,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) } return FALSE; } - retval = io_close(io); + retval = io_close(io, not_implicit); if (not_implicit) { IoLINES(io) = 0; IoPAGE(io) = 0; @@ -665,7 +736,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) } bool -Perl_io_close(pTHX_ IO *io) +Perl_io_close(pTHX_ IO *io, bool not_implicit) { bool retval = FALSE; int status; @@ -673,8 +744,13 @@ Perl_io_close(pTHX_ IO *io) if (IoIFP(io)) { if (IoTYPE(io) == '|') { status = PerlProc_pclose(IoIFP(io)); - STATUS_NATIVE_SET(status); - retval = (STATUS_POSIX == 0); + if (not_implicit) { + STATUS_NATIVE_SET(status); + retval = (STATUS_POSIX == 0); + } + else { + retval = (status != -1); + } } else if (IoTYPE(io) == '-') retval = TRUE; @@ -688,7 +764,7 @@ Perl_io_close(pTHX_ IO *io) } IoOFP(io) = IoIFP(io) = Nullfp; } - else { + else if (not_implicit) { SETERRNO(EBADF,SS$_IVCHAN); } @@ -706,6 +782,15 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; + else if (ckWARN(WARN_IO) + && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() + || IoIFP(io) == PerlIO_stderr())) + { + SV* sv = sv_newmortal(); + gv_efullname3(sv, gv, Nullch); + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", + SvPV_nolen(sv)); + } while (IoIFP(io)) { @@ -919,10 +1004,17 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); - if (SvIsUV(sv)) /* XXXX 64-bit? */ +#ifdef IV_IS_QUAD + if (SvIsUV(sv)) + PerlIO_printf(fp, "%" PERL_PRIu64, (UV)SvUVX(sv)); + else + PerlIO_printf(fp, "%" PERL_PRId64, (IV)SvIVX(sv)); +#else + if (SvIsUV(sv)) PerlIO_printf(fp, "%lu", (unsigned long)SvUVX(sv)); else PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); +#endif return !PerlIO_error(fp); } /* FALL THROUGH */ @@ -1019,6 +1111,13 @@ Perl_my_lstat(pTHX) bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) { + return do_aexec5(really, mark, sp, 0, 0); +} + +bool +Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, + int fd, int do_report) +{ register char **a; char *tmps; STRLEN n_a; @@ -1043,6 +1142,12 @@ Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); + if (do_report) { + int e = errno; + + PerlLIO_write(fd, (void*)&e, sizeof(int)); + PerlLIO_close(fd); + } } do_execfree(); return FALSE; @@ -1126,6 +1231,20 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) *s = '\0'; break; } + /* handle the 2>&1 construct at the end */ + if (*s == '>' && s[1] == '&' && s[2] == '1' + && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) + && (!s[3] || isSPACE(s[3]))) + { + char *t = s + 3; + + while (*t && isSPACE(*t)) + ++t; + if (!*t && (dup2(1,2) != -1)) { + s[-2] = '\0'; + break; + } + } doshell: PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0); return FALSE; @@ -1371,8 +1490,10 @@ nothing in the core. /* Do the permissions allow some operation? Assumes statcache already set. */ #ifndef VMS /* VMS' cando is in vms.c */ -I32 -Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) +bool +Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp) +/* Note: we use `effective' both for uids and gids. + * Here we are betting on Uid_t being equal or wider than Gid_t. */ { #ifdef DOSISH /* [Comments and code from Len Reed] @@ -1396,11 +1517,11 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat * too so it will actually look into the files for magic numbers */ - return (bit & statbufp->st_mode) ? TRUE : FALSE; + return (mode & statbufp->st_mode) ? TRUE : FALSE; #else /* ! DOSISH */ if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */ - if (bit == S_IXUSR) { + if (mode == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; } @@ -1409,22 +1530,22 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) return FALSE; } if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) { - if (statbufp->st_mode & bit) + if (statbufp->st_mode & mode) return TRUE; /* ok as "user" */ } - else if (ingroup((I32)statbufp->st_gid,effective)) { - if (statbufp->st_mode & bit >> 3) + else if (ingroup(statbufp->st_gid,effective)) { + if (statbufp->st_mode & mode >> 3) return TRUE; /* ok as "group" */ } - else if (statbufp->st_mode & bit >> 6) + else if (statbufp->st_mode & mode >> 6) return TRUE; /* ok as "other" */ return FALSE; #endif /* ! DOSISH */ } #endif /* ! VMS */ -I32 -Perl_ingroup(pTHX_ I32 testgid, I32 effective) +bool +Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) { if (testgid == (effective ? PL_egid : PL_gid)) return TRUE;