X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=c8bc22dd5c158dae8ee20763cc110d1791e01eaf;hb=e1ec3a884f8d8c64eb7e391b2a363f47cbeed570;hp=cad08a7d0da89d335a53d47f545d0018806f19fd;hpb=35990314f73df48945aa05a488674262637a7abb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index cad08a7..c8bc22d 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,7 @@ /* doio.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -14,6 +15,11 @@ * chattering, into calmer and more level reaches." */ +/* This file contains functions that do the actual I/O on behalf of ops. + * For example, pp_print() calls the do_print() function in this file for + * each argument needing printing. + */ + #include "EXTERN.h" #define PERL_IN_DOIO_C #include "perl.h" @@ -47,9 +53,10 @@ # define OPEN_EXCL 0 #endif -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#define PERL_MODE_MAX 8 +#define PERL_FLAGS_MAX 10 + #include -#endif bool Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, @@ -85,7 +92,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, bool was_fdopen = FALSE; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; char *type = NULL; - char mode[8]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + char mode[PERL_MODE_MAX]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ SV *namesv; Zero(mode,sizeof(mode),char); @@ -93,7 +100,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* Collect default raw/crlf info from the op */ if (PL_op && PL_op->op_type == OP_OPEN) { - /* set up disciplines */ + /* set up IO layers */ U8 flags = PL_op->op_private; in_raw = (flags & OPpOPEN_IN_RAW); in_crlf = (flags & OPpOPEN_IN_CRLF); @@ -140,19 +147,44 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (as_raw) { /* sysopen style args, i.e. integer mode and permissions */ STRLEN ix = 0; - if (num_svs != 0) { - Perl_croak(aTHX_ "panic: sysopen with multiple args"); - } - if (rawmode & (O_WRONLY|O_RDWR|O_CREAT + const int appendtrunc = + 0 #ifdef O_APPEND /* Not fully portable. */ - |O_APPEND + |O_APPEND #endif #ifdef O_TRUNC /* Not fully portable. */ - |O_TRUNC + |O_TRUNC #endif - )) - TAINT_PROPER("sysopen"); - mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */ + ; + int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; + int ismodifying; + + if (num_svs != 0) { + Perl_croak(aTHX_ "panic: sysopen with multiple args"); + } + /* It's not always + + O_RDONLY 0 + O_WRONLY 1 + O_RDWR 2 + + It might be (in OS/390 and Mac OS Classic it is) + + O_WRONLY 1 + O_RDONLY 2 + O_RDWR 3 + + This means that simple & with O_RDWR would look + like O_RDONLY is present. Therefore we have to + be more careful. + */ + if ((ismodifying = (rawmode & modifyingmode))) { + if ((ismodifying & O_WRONLY) == O_WRONLY || + (ismodifying & O_RDWR) == O_RDWR || + (ismodifying & (O_CREAT|appendtrunc))) + TAINT_PROPER("sysopen"); + } + mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; /* Transparently largefiley. */ @@ -185,8 +217,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, *--tend = '\0'; if (num_svs) { - /* New style explict name, type is just mode and discipline/layer info */ + /* New style explicit name, type is just mode and layer info */ STRLEN l = 0; +#ifdef USE_STDIO + if (SvROK(*svp) && !strchr(name,'&')) { + if (ckWARN(WARN_IO)) + Perl_warner(aTHX_ packWARN(WARN_IO), + "Can't open a reference"); + SETERRNO(EINVAL, LIB_INVARG); + goto say_false; + } +#endif /* USE_STDIO */ name = SvOK(*svp) ? SvPV(*svp, l) : ""; len = (I32)l; name = savepvn(name, len); @@ -200,7 +241,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if ((*type == IoTYPE_RDWR) && /* scary */ (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { - TAINT_PROPER("open"); + TAINT_PROPER("open"); mode[1] = *type++; writing = 1; } @@ -208,7 +249,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == IoTYPE_PIPE) { if (num_svs) { if (type[1] != IoTYPE_STD) { - unknown_desr: + unknown_open_mode: Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); } type++; @@ -222,31 +263,45 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*name == '\0') { /* command is missing 19990114 */ if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); errno = EPIPE; goto say_false; } - if (strNE(name,"-") || num_svs) + if ((*name == '-' && name[1] == '\0') || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); if (!num_svs && name[len-1] == '|') { name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); } mode[0] = 'w'; writing = 1; +#ifdef HAS_STRLCAT + if (out_raw) + strlcat(mode, "b", PERL_MODE_MAX); + else if (out_crlf) + strlcat(mode, "t", PERL_MODE_MAX); +#else if (out_raw) strcat(mode, "b"); else if (out_crlf) strcat(mode, "t"); +#endif if (num_svs > 1) { fp = PerlProc_popen_list(mode, num_svs, svp); } else { fp = PerlProc_popen(name,mode); } - } + if (num_svs) { + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + goto say_false; + } + } + } + } /* IoTYPE_PIPE */ else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); type++; @@ -260,11 +315,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } writing = 1; +#ifdef HAS_STRLCAT + if (out_raw) + strlcat(mode, "b", PERL_MODE_MAX); + else if (out_crlf) + strlcat(mode, "t", PERL_MODE_MAX); +#else if (out_raw) strcat(mode, "b"); else if (out_crlf) strcat(mode, "t"); - +#endif if (*type == '&') { duplicity: dodup = PERLIO_DUP_FD; @@ -281,29 +342,28 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs > 1) { Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); } - if (num_svs && SvIOK(*svp)) { + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; + if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) { fd = SvUV(*svp); + num_svs = 0; } else if (isDIGIT(*type)) { - /*SUPPRESS 530*/ - for (; isSPACE(*type); type++) ; fd = atoi(type); } else { - IO* thatio; + const IO* thatio; if (num_svs) { thatio = sv_2io(*svp); } else { GV *thatgv; - /*SUPPRESS 530*/ - for (; isSPACE(*type); type++) ; thatgv = gv_fetchpv(type,FALSE,SVt_PVIO); thatio = GvIO(thatgv); } if (!thatio) { #ifdef EINVAL - SETERRNO(EINVAL,SS$_IVCHAN); + SETERRNO(EINVAL,SS_IVCHAN); #endif goto say_false; } @@ -380,16 +440,24 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } /* !& */ - } + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_WRONLY */ else if (*type == IoTYPE_RDONLY) { /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; +#ifdef HAS_STRLCAT + if (in_raw) + strlcat(mode, "b", PERL_MODE_MAX); + else if (in_crlf) + strlcat(mode, "t", PERL_MODE_MAX); +#else if (in_raw) strcat(mode, "b"); else if (in_crlf) strcat(mode, "t"); - +#endif if (*type == '&') { goto duplicity; } @@ -411,8 +479,11 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } - } - else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_RDONLY */ + else if ((num_svs && /* '-|...' or '...|' */ + type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { if (num_svs) { type += 2; /* skip over '-|' */ @@ -429,18 +500,27 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*name == '\0') { /* command is missing 19990114 */ if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); errno = EPIPE; goto say_false; } - if (strNE(name,"-") || num_svs) + if (!(*name == '-' && name[1] == '\0') || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); mode[0] = 'r'; + +#ifdef HAS_STRLCAT + if (in_raw) + strlcat(mode, "b", PERL_MODE_MAX); + else if (in_crlf) + strlcat(mode, "t", PERL_MODE_MAX); +#else if (in_raw) strcat(mode, "b"); else if (in_crlf) strcat(mode, "t"); +#endif + if (num_svs > 1) { fp = PerlProc_popen_list(mode,num_svs,svp); } @@ -448,20 +528,37 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlProc_popen(name,mode); } IoTYPE(io) = IoTYPE_PIPE; + if (num_svs) { + for (; isSPACE(*type); type++) ; + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + goto say_false; + } + } + } } - else { + else { /* layer(Args) */ if (num_svs) - goto unknown_desr; + goto unknown_open_mode; name = type; IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; mode[0] = 'r'; + +#ifdef HAS_STRLCAT + if (in_raw) + strlcat(mode, "b", PERL_MODE_MAX); + else if (in_crlf) + strlcat(mode, "t", PERL_MODE_MAX); +#else if (in_raw) strcat(mode, "b"); else if (in_crlf) strcat(mode, "t"); - if (strEQ(name,"-")) { +#endif + + if (*name == '-' && name[1] == '\0') { fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } @@ -478,26 +575,28 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } if (!fp) { if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n')) - Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); goto say_false; } if (ckWARN(WARN_IO)) { if ((IoTYPE(io) == IoTYPE_RDONLY) && (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { - Perl_warner(aTHX_ WARN_IO, - "Filehandle STD%s opened only for input", - (fp == PerlIO_stdout()) ? "OUT" : "ERR"); + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STD%s reopened as %s only for input", + ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), + GvENAME(gv)); } else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { - Perl_warner(aTHX_ WARN_IO, - "Filehandle STDIN opened only for output"); + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STDIN reopened as %s only for output", + GvENAME(gv)); } } fd = PerlIO_fileno(fp); - /* If there is no fd (e.g. PerlIO::Scalar) assume it isn't a - * socket - this covers PerlIO::Scalar - otherwise unless we "know" the + /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a + * socket - this covers PerlIO::scalar - otherwise unless we "know" the * type probe for socket-ness. */ if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { @@ -546,9 +645,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } if (savefd != fd) { - Pid_t pid; - SV *sv; - /* Still a small can-of-worms here if (say) PerlIO::Scalar + /* Still a small can-of-worms here if (say) PerlIO::scalar is assigned to (say) STDOUT - for now let dup2() fail and provide the error */ @@ -558,25 +655,53 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #ifdef VMS if (savefd != PerlIO_fileno(PerlIO_stdin())) { - char newname[FILENAME_MAX+1]; - if (PerlIO_getname(fp, newname)) { - if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname); - if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname); - } + char newname[FILENAME_MAX+1]; + if (PerlIO_getname(fp, newname)) { + if (fd == PerlIO_fileno(PerlIO_stdout())) + Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname); + if (fd == PerlIO_fileno(PerlIO_stderr())) + Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname); + } } #endif - LOCK_FDPID_MUTEX; - sv = *av_fetch(PL_fdpid,fd,TRUE); - (void)SvUPGRADE(sv, SVt_IV); - pid = SvIVX(sv); - SvIVX(sv) = 0; - sv = *av_fetch(PL_fdpid,savefd,TRUE); - UNLOCK_FDPID_MUTEX; - (void)SvUPGRADE(sv, SVt_IV); - SvIVX(sv) = pid; - if (!was_fdopen) { - PerlIO_close(fp); + +#if !defined(WIN32) + /* PL_fdpid isn't used on Windows, so avoid this useless work. + * XXX Probably the same for a lot of other places. */ + { + Pid_t pid; + SV *sv; + + LOCK_FDPID_MUTEX; + sv = *av_fetch(PL_fdpid,fd,TRUE); + (void)SvUPGRADE(sv, SVt_IV); + pid = SvIVX(sv); + SvIVX(sv) = 0; + sv = *av_fetch(PL_fdpid,savefd,TRUE); + (void)SvUPGRADE(sv, SVt_IV); + SvIVX(sv) = pid; + UNLOCK_FDPID_MUTEX; + } +#endif + + if (was_fdopen) { + /* need to close fp without closing underlying fd */ + int ofd = PerlIO_fileno(fp); + int dupfd = PerlLIO_dup(ofd); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* Assume if we have F_SETFD we have F_GETFD */ + int coe = fcntl(ofd,F_GETFD); +#endif + PerlIO_close(fp); + PerlLIO_dup2(dupfd,ofd); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* The dup trick has lost close-on-exec on ofd */ + fcntl(ofd,F_SETFD, coe); +#endif + PerlLIO_close(dupfd); } + else + PerlIO_close(fp); } fp = saveifp; PerlIO_clearerr(fp); @@ -595,8 +720,11 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (writing) { if (IoTYPE(io) == IoTYPE_SOCKET || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) { - mode[0] = 'w'; - if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { + char *s = mode; + if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) + s++; + *s = 'w'; + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; @@ -639,12 +767,16 @@ Perl_nextargv(pTHX_ register GV *gv) if (PL_filemode & (S_ISUID|S_ISGID)) { PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD - (void)fchmod(PL_lastfd,PL_filemode); + if (PL_lastfd != -1) + (void)fchmod(PL_lastfd,PL_filemode); #else (void)PerlLIO_chmod(PL_oldname,PL_filemode); #endif } + PL_lastfd = -1; PL_filemode = 0; + if (!GvAV(gv)) + return Nullfp; while (av_len(GvAV(gv)) >= 0) { STRLEN oldlen; sv = av_shift(GvAV(gv)); @@ -668,7 +800,7 @@ Perl_nextargv(pTHX_ register GV *gv) filegid = PL_statbuf.st_gid; if (!S_ISREG(PL_filemode)) { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, + Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit: %s is not a regular file", PL_oldname ); do_close(gv,FALSE); @@ -700,20 +832,20 @@ Perl_nextargv(pTHX_ register GV *gv) ) { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, - "Can't do inplace edit: %s would not be unique", - SvPVX(sv)); + Perl_warner(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %"SVf" would not be unique", + sv); do_close(gv,FALSE); continue; } #endif #ifdef HAS_RENAME -#if !defined(DOSISH) && !defined(__CYGWIN__) +#if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { 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) ); + Perl_warner(aTHX_ packWARN(WARN_INPLACE), + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -727,9 +859,9 @@ Perl_nextargv(pTHX_ register GV *gv) (void)UNLINK(SvPVX(sv)); if (link(PL_oldname,SvPVX(sv)) < 0) { 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) ); + Perl_warner(aTHX_ packWARN(WARN_INPLACE), + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -741,7 +873,7 @@ Perl_nextargv(pTHX_ register GV *gv) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(PL_oldname) < 0) { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, + Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't remove %s: %s, skipping file", PL_oldname, Strerror(errno) ); do_close(gv,FALSE); @@ -765,7 +897,7 @@ Perl_nextargv(pTHX_ register GV *gv) #endif { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s", + Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; @@ -799,12 +931,12 @@ Perl_nextargv(pTHX_ register GV *gv) if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 && !S_ISREG(PL_statbuf.st_mode)) { - Perl_warner(aTHX_ WARN_INPLACE, + Perl_warner(aTHX_ packWARN(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", + Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", PL_oldname, Strerror(eno)); } } @@ -849,8 +981,9 @@ Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv) if (PerlProc_pipe(fd) < 0) goto badexit; - IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); - IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); + IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; IoTYPE(wstio) = IoTYPE_WRONLY; @@ -882,7 +1015,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) gv = PL_argvgv; if (!gv || SvTYPE(gv) != SVt_PVGV) { if (not_implicit) - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); return FALSE; } io = GvIO(gv); @@ -890,7 +1023,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) if (not_implicit) { if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); } return FALSE; } @@ -925,16 +1058,19 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) retval = TRUE; else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ - retval = (PerlIO_close(IoOFP(io)) != EOF); + bool prev_err = PerlIO_error(IoOFP(io)); + retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } - else - retval = (PerlIO_close(IoIFP(io)) != EOF); + else { + bool prev_err = PerlIO_error(IoIFP(io)); + retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); + } } IoOFP(io) = IoIFP(io) = Nullfp; } else if (not_implicit) { - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); } return retval; @@ -951,41 +1087,31 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY)) - { - /* integrate to report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for output", name); - else - Perl_warner(aTHX_ WARN_IO, - "Filehandle opened only for output"); - } + report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); while (IoIFP(io)) { + int saverrno; if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ return FALSE; /* this is the most usual case */ } + saverrno = errno; /* getc and ungetc can stomp on errno */ ch = PerlIO_getc(IoIFP(io)); if (ch != EOF) { (void)PerlIO_ungetc(IoIFP(io),ch); + errno = saverrno; return FALSE; } + errno = saverrno; if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { if (PerlIO_get_cnt(IoIFP(io)) < -1) PerlIO_set_cnt(IoIFP(io),-1); } if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ - if (!nextargv(PL_argvgv)) /* get another fp handy */ + if (gv != PL_argvgv || !nextargv(gv)) /* get another fp handy */ return TRUE; } else @@ -1009,7 +1135,7 @@ Perl_do_tell(pTHX_ GV *gv) } if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return (Off_t)-1; } @@ -1028,7 +1154,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) } if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return FALSE; } @@ -1042,7 +1168,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return (Off_t)-1; } @@ -1057,7 +1183,7 @@ Perl_mode_from_discipline(pTHX_ SV *discp) if (*s == ':') { switch (s[1]) { case 'r': - if (len > 3 && strnEQ(s+1, "raw", 3) + if (s[2] == 'a' && s[3] == 'w' && (!s[4] || s[4] == ':' || isSPACE(s[4]))) { mode = O_BINARY; @@ -1067,7 +1193,7 @@ Perl_mode_from_discipline(pTHX_ SV *discp) } /* FALL THROUGH */ case 'c': - if (len > 4 && strnEQ(s+1, "crlf", 4) + if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' && (!s[5] || s[5] == ':' || isSPACE(s[5]))) { mode = O_TEXT; @@ -1091,8 +1217,9 @@ fail_discipline: if (!end) end = s+len; #ifndef PERLIO_LAYERS - Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); + Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); #else + len -= end-s; s = end; #endif } @@ -1107,9 +1234,9 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) /* The old body of this is now in non-LAYER part of perlio.c * This is a stub for any XS code which might have been calling it. */ - char *name = ":raw"; + const char *name = ":raw"; #ifdef PERLIO_USING_CRLF - if (!(mode & O_BINARY))) + if (!(mode & O_BINARY)) name = ":crlf"; #endif return PerlIO_binmode(aTHX_ fp, iotype, mode, name); @@ -1124,7 +1251,7 @@ I32 fd; /* file descriptor */ Off_t length; /* length to set file to */ { struct flock fl; - struct stat filebuf; + Stat_t filebuf; if (PerlLIO_fstat(fd, &filebuf) < 0) return -1; @@ -1169,7 +1296,7 @@ Off_t length; /* length to set file to */ bool Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { - register char *tmps; + register const char *tmps; STRLEN len; /* assuming fp is checked earlier */ @@ -1191,7 +1318,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) switch (SvTYPE(sv)) { case SVt_NULL: if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); return TRUE; case SVt_IV: if (SvIOK(sv)) { @@ -1207,13 +1334,14 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) default: if (PerlIO_isutf8(fp)) { if (!SvUTF8(sv)) - sv_utf8_upgrade(sv = sv_mortalcopy(sv)); + sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv), + SV_GMAGIC|SV_UTF8_NO_ENCODING); } else if (DO_UTF8(sv)) { if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE) - && ckWARN(WARN_UTF8)) + && ckWARN_d(WARN_UTF8)) { - Perl_warner(aTHX_ WARN_UTF8, "Wide character in print"); + Perl_warner(aTHX_ packWARN(WARN_UTF8), "Wide character in print"); } } tmps = SvPV(sv, len); @@ -1258,10 +1386,13 @@ Perl_my_stat(pTHX) return (PL_laststatval = -1); } } + else if (PL_op->op_private & OPpFT_STACKED) { + return PL_laststatval; + } else { SV* sv = POPs; char *s; - STRLEN n_a; + STRLEN len; PUTBACK; if (SvTYPE(sv) == SVt_PVGV) { gv = (GV*)sv; @@ -1272,17 +1403,20 @@ Perl_my_stat(pTHX) goto do_fstat; } - s = SvPV(sv, n_a); + s = SvPV(sv, len); PL_statgv = Nullgv; - sv_setpv(PL_statname, s); + sv_setpvn(PL_statname, s, len); + s = SvPVX(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')) - Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); return PL_laststatval; } } +static char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; + I32 Perl_my_lstat(pTHX) { @@ -1293,28 +1427,42 @@ Perl_my_lstat(pTHX) EXTEND(SP,1); if (cGVOP_gv == PL_defgv) { if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat"); + Perl_croak(aTHX_ no_prev_lstat); return PL_laststatval; } - Perl_croak(aTHX_ "You can't use -l on a filehandle"); + if (ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s", + GvENAME(cGVOP_gv)); + return (PL_laststatval = -1); + } } + else if (ckWARN(WARN_IO) && PL_laststype != OP_LSTAT + && (PL_op->op_private & OPpFT_STACKED)) + Perl_croak(aTHX_ no_prev_lstat); PL_laststype = OP_LSTAT; PL_statgv = Nullgv; sv = POPs; PUTBACK; + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s", + GvENAME((GV*) SvRV(sv))); + return (PL_laststatval = -1); + } sv_setpv(PL_statname,SvPV(sv, n_a)); PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache); if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) - Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); return PL_laststatval; } +#ifndef OS2 bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) { return do_aexec5(really, mark, sp, 0, 0); } +#endif bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, @@ -1324,7 +1472,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); #else register char **a; - char *tmps = Nullch; + const char *tmps = Nullch; STRLEN n_a; if (sp > mark) { @@ -1342,12 +1490,14 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, if ((!really && *PL_Argv[0] != '/') || (really && *tmps != '/')) /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ + PERL_FPU_PRE_EXEC if (really && *tmps) PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); else PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); + PERL_FPU_POST_EXEC if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", (really ? tmps : PL_Argv[0]), Strerror(errno)); if (do_report) { int e = errno; @@ -1395,14 +1545,22 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) #ifdef CSH { - char flags[10]; + char flags[PERL_FLAGS_MAX]; if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) { +#ifdef HAS_STRLCPY + strlcpy(flags, "-c", PERL_FLAGS_MAX); +#else strcpy(flags,"-c"); +#endif s = cmd+PL_cshlen+3; if (*s == 'f') { s++; +#ifdef HAS_STRLCPY + strlcat(flags, "f", PERL_FLAGS_MAX); +#else strcat(flags,"f"); +#endif } if (*s == ' ') s++; @@ -1415,7 +1573,9 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) *--s = '\0'; if (s[-1] == '\'') { *--s = '\0'; + PERL_FPU_PRE_EXEC PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0); + PERL_FPU_POST_EXEC *s = '\''; return FALSE; } @@ -1452,13 +1612,15 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) while (*t && isSPACE(*t)) ++t; - if (!*t && (dup2(1,2) != -1)) { + if (!*t && (PerlLIO_dup2(1,2) != -1)) { s[-2] = '\0'; break; } } doshell: + PERL_FPU_PRE_EXEC PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0); + PERL_FPU_POST_EXEC return FALSE; } } @@ -1476,7 +1638,9 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) } *a = Nullch; if (PL_Argv[0]) { + PERL_FPU_PRE_EXEC PerlProc_execvp(PL_Argv[0],PL_Argv); + PERL_FPU_POST_EXEC if (errno == ENOEXEC) { /* for system V NIH syndrome */ do_execfree(); goto doshell; @@ -1485,7 +1649,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) int e = errno; if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); if (do_report) { PerlLIO_write(fd, (void*)&e, sizeof(int)); @@ -1505,7 +1669,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) register I32 val; register I32 val2; register I32 tot = 0; - char *what; + const char *what; char *s; SV **oldmark = mark; STRLEN n_a; @@ -1572,10 +1736,10 @@ nothing in the core. if (mark == sp) break; s = SvPVx(*++mark, n_a); - if (isUPPER(*s)) { + if (isALPHA(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; - if (!(val = whichsig(s))) + if ((val = whichsig(s)) < 0) Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s); } else @@ -1675,22 +1839,23 @@ nothing in the core. SV* modified = *++mark; void * utbufp = &utbuf; - /* be like C, and if both times are undefined, let the C - library figure out what to do. This usually means - "current time" */ + /* Be like C, and if both times are undefined, let the C + * library figure out what to do. This usually means + * "current time". */ if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) - utbufp = NULL; - - Zero(&utbuf, sizeof utbuf, char); + utbufp = NULL; + else { + Zero(&utbuf, sizeof utbuf, char); #ifdef BIG_TIME - utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */ - utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */ + utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */ #else - utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */ - utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */ + utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */ #endif - APPLY_TAINT_PROPER(); + } + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { char *name = SvPVx(*mark, n_a); @@ -2022,7 +2187,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) opbuf = SvPV(opstr, opsize); if (opsize < 3 * SHORTSIZE || (opsize % (3 * SHORTSIZE))) { - SETERRNO(EINVAL,LIB$_INVARG); + SETERRNO(EINVAL,LIB_INVARG); return -1; } SETERRNO(0,0); @@ -2079,7 +2244,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) if (shmctl(id, IPC_STAT, &shmds) == -1) return -1; if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) { - SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */ + SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ return -1; } shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); @@ -2120,6 +2285,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #endif /* SYSV IPC */ /* +=head1 IO Functions + =for apidoc start_glob Function called by C to spawn a glob (or do the glob inside @@ -2187,8 +2354,9 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io) if (*cp == '?') *cp = '%'; /* VMS style single-char wildcard */ while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, &dfltdsc,NULL,NULL,NULL))&1)) { - end = rstr + (unsigned long int) *rslt; - if (!hasver) while (*end != ';') end--; + /* with varying string, 1st word of buffer contains result length */ + end = rstr + *((unsigned short int*)rslt); + if (!hasver) while (*end != ';' && end > rstr) end--; *(end++) = '\n'; *end = '\0'; for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); if (hasdir) { @@ -2204,7 +2372,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io) } if (cxt) (void)lib$find_file_end(&cxt); if (ok && sts != RMS$_NMF && - sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; + sts != RMS$_DNF && sts != RMS_FNF) ok = 0; if (!ok) { if (!(sts & 1)) { SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);