X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a52cb5f71fdb108349442902e9c003c02608aae2..97017a809da405a36dfccf88d7bd13d26ca0e932:/doio.c diff --git a/doio.c b/doio.c index 4a255b2..0121633 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,6 @@ /* doio.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -41,12 +41,6 @@ # endif #endif -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif #ifdef O_EXCL # define OPEN_EXCL O_EXCL #else @@ -77,15 +71,6 @@ # endif #endif -/* Put this after #includes because defines _XOPEN_*. */ -#ifndef Sock_size_t -# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__) -# define Sock_size_t Size_t -# else -# define Sock_size_t int -# endif -#endif - bool Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp) @@ -108,9 +93,19 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int fd; int result; bool was_fdopen = FALSE; + bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; PL_forkprocess = 1; /* assume true if no fork */ + if (PL_op && PL_op->op_type == OP_OPEN) { + /* set up disciplines */ + 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 (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == '-') @@ -168,44 +163,58 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (fd == -1) fp = NULL; else { - char *fpmode; + char fpmode[4]; + STRLEN ix = 0; if (result == O_RDONLY) - fpmode = "r"; + fpmode[ix++] = 'r'; #ifdef O_APPEND - else if (rawmode & O_APPEND) - fpmode = (result == O_WRONLY) ? "a" : "a+"; + else if (rawmode & O_APPEND) { + fpmode[ix++] = 'a'; + if (result != O_WRONLY) + fpmode[ix++] = '+'; + } #endif - else - fpmode = (result == O_WRONLY) ? "w" : "r+"; + else { + if (result == O_WRONLY) + fpmode[ix++] = 'w'; + else { + fpmode[ix++] = 'r'; + fpmode[ix++] = '+'; + } + } + if (rawmode & O_BINARY) + fpmode[ix++] = 'b'; + fpmode[ix] = '\0'; fp = PerlIO_fdopen(fd, fpmode); if (!fp) PerlLIO_close(fd); } } else { - char *myname; - char *type = name; - char *otype = name; + char *type; + char *oname = name; STRLEN tlen; - STRLEN otlen = len; - char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ + STRLEN olen = len; + char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ int dodup; + type = savepvn(name, len); + tlen = len; + SAVEFREEPV(type); if (num_svs) { - type = name; - name = SvPV(svs, tlen) ; - len = (I32)tlen; + STRLEN l; + name = SvPV(svs, l) ; + len = (I32)l; + name = savepvn(name, len); + SAVEFREEPV(name); } - - tlen = otlen; - myname = savepvn(name, len); - SAVEFREEPV(myname); - name = myname; - if (!num_svs) + else { while (tlen && isSPACE(type[tlen-1])) type[--tlen] = '\0'; - - mode[0] = mode[1] = mode[2] = '\0'; + name = type; + len = tlen; + } + mode[0] = mode[1] = mode[2] = mode[3] = '\0'; IoTYPE(io) = *type; if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */ mode[1] = *type++; @@ -216,12 +225,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == '|') { if (num_svs && (tlen != 2 || type[1] != '-')) { unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype); + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); } /*SUPPRESS 530*/ - for (type++; isSPACE(*type); type++) ; - if (!num_svs) + for (type++, tlen--; isSPACE(*type); type++, tlen--) ; + if (!num_svs) { name = type; + len = tlen; + } if (*name == '\0') { /* command is missing 19990114 */ dTHR; if (ckWARN(WARN_PIPE)) @@ -232,13 +243,22 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - if (name[strlen(name)-1] == '|') { + if (name[len-1] == '|') { dTHR; - name[strlen(name)-1] = '\0' ; + name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Can't do bidirectional pipe"); + Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); + } + { + char *mode; + if (out_raw) + mode = "wb"; + else if (out_crlf) + mode = "wt"; + else + mode = "w"; + fp = PerlProc_popen(name,mode); } - fp = PerlProc_popen(name,"w"); writing = 1; } else if (*type == '>') { @@ -253,6 +273,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, mode[0] = 'w'; writing = 1; + if (out_raw) + strcat(mode, "b"); + else if (out_crlf) + strcat(mode, "t"); + if (num_svs && tlen != 1) goto unknown_desr; if (*type == '&') { @@ -308,7 +333,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (!(fp = PerlIO_fdopen(fd,mode))) { if (dodup) PerlLIO_close(fd); - } + } } } else { @@ -329,6 +354,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); + if (*type == '&') { name = type; goto duplicity; @@ -363,7 +393,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - fp = PerlProc_popen(name,"r"); + { + char *mode; + if (in_raw) + mode = "rb"; + else if (in_crlf) + mode = "rt"; + else + mode = "r"; + fp = PerlProc_popen(name,mode); + } IoTYPE(io) = '|'; } else { @@ -377,8 +416,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlIO_stdin(); IoTYPE(io) = '-'; } - else - fp = PerlIO_open(name,"r"); + else { + char *mode; + if (in_raw) + mode = "rb"; + else if (in_crlf) + mode = "rt"; + else + mode = "r"; + fp = PerlIO_open(name,mode); + } } } if (!fp) { @@ -452,11 +499,21 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; + IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { dTHR; if (IoTYPE(io) == 's' - || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) { - if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) { + || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) + { + char *mode; + if (out_raw) + mode = "wb"; + else if (out_crlf) + mode = "wt"; + else + mode = "w"; + + if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; @@ -569,7 +626,7 @@ Perl_nextargv(pTHX_ register GV *gv) } #endif #ifdef HAS_RENAME -#if !defined(DOSISH) && !defined(CYGWIN) +#if !defined(DOSISH) && !defined(__CYGWIN__) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ WARN_INPLACE, @@ -657,13 +714,17 @@ Perl_nextargv(pTHX_ register GV *gv) else { dTHR; if (ckWARN_d(WARN_INPLACE)) { - if (!S_ISREG(PL_statbuf.st_mode)) + int eno = errno; + if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 + && !S_ISREG(PL_statbuf.st_mode)) + { Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + PL_oldname); + } else - Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s\n", - PL_oldname, Strerror(errno)); + Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s", + PL_oldname, Strerror(eno)); } } } @@ -909,19 +970,72 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) } int -Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag) +Perl_mode_from_discipline(pTHX_ SV *discp) +{ + int mode = O_BINARY; + if (discp) { + STRLEN len; + char *s = SvPV(discp,len); + while (*s) { + if (*s == ':') { + switch (s[1]) { + case 'r': + if (len > 3 && strnEQ(s+1, "raw", 3) + && (!s[4] || s[4] == ':' || isSPACE(s[4]))) + { + mode = O_BINARY; + s += 4; + len -= 4; + break; + } + /* FALL THROUGH */ + case 'c': + if (len > 4 && strnEQ(s+1, "crlf", 4) + && (!s[5] || s[5] == ':' || isSPACE(s[5]))) + { + mode = O_TEXT; + s += 5; + len -= 5; + break; + } + /* FALL THROUGH */ + default: + goto fail_discipline; + } + } + else if (isSPACE(*s)) { + ++s; + --len; + } + else { + char *end; +fail_discipline: + end = strchr(s+1, ':'); + if (!end) + end = s+len; + Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); + } + } + } + return mode; +} + +int +Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) { - if (flag != TRUE) - Perl_croak(aTHX_ "panic: unsetting binmode"); /* Not implemented yet */ #ifdef DOSISH -#if defined(atarist) || defined(__MINT__) - if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) +# if defined(atarist) || defined(__MINT__) + if (!PerlIO_flush(fp)) { + if (mode & O_BINARY) + ((FILE*)fp)->_flag |= _IOBIN; + else + ((FILE*)fp)->_flag &= ~ _IOBIN; return 1; - else - return 0; -#else - if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { -#if defined(WIN32) && defined(__BORLANDC__) + } + return 0; +# else + if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { +# if defined(WIN32) && defined(__BORLANDC__) /* The translation mode of the stream is maintained independent * of the translation mode of the fd in the Borland RTL (heavy * digging through their runtime sources reveal). User has to @@ -929,22 +1043,25 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag) * document this anywhere). GSAR 97-5-24 */ PerlIO_seek(fp,0L,0); - ((FILE*)fp)->flags |= _F_BIN; -#endif + if (mode & O_BINARY) + ((FILE*)fp)->flags |= _F_BIN; + else + ((FILE*)fp)->flags &= ~ _F_BIN; +# endif return 1; } else return 0; -#endif +# endif #else -#if defined(USEMYBINMODE) - if (my_binmode(fp,iotype) != FALSE) +# if defined(USEMYBINMODE) + if (my_binmode(fp, iotype, mode) != FALSE) return 1; else return 0; -#else +# else return 1; -#endif +# endif #endif } @@ -1026,7 +1143,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return TRUE; case SVt_IV: @@ -1064,7 +1181,7 @@ Perl_my_stat(pTHX) if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - tmpgv = cGVOP; + tmpgv = cGVOP_gv; do_fstat: io = GvIO(tmpgv); if (io && IoIFP(io)) { @@ -1117,7 +1234,7 @@ Perl_my_lstat(pTHX) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - if (cGVOP == PL_defgv) { + if (cGVOP_gv == PL_defgv) { if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat"); return PL_laststatval; @@ -1253,7 +1370,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) goto doshell; - for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ + for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */ if (*s == '=') goto doshell; @@ -1677,8 +1794,11 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { struct semid_ds semds; union semun semun; - +#ifdef EXTRA_F_IN_SEMUN_BUF + semun.buff = &semds; +#else semun.buf = &semds; +#endif getinfo = (cmd == GETALL); if (Semctl(id, 0, IPC_STAT, semun) == -1) return -1; @@ -1733,7 +1853,11 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) #ifdef Semctl union semun unsemds; +#ifdef EXTRA_F_IN_SEMUN_BUF + unsemds.buff = (struct semid_ds *)a; +#else unsemds.buf = (struct semid_ds *)a; +#endif ret = Semctl(id, n, cmd, unsemds); #else Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); @@ -1802,6 +1926,10 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) if (ret >= 0) { SvCUR_set(mstr, sizeof(long)+ret); *SvEND(mstr) = '\0'; +#ifndef INCOMPLETE_TAINTS + /* who knows who has been playing with this message? */ + SvTAINTED_on(mstr); +#endif } return ret; #else @@ -1860,6 +1988,9 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) if (shm == (char *)-1) /* I hate System V IPC, I really do */ return -1; if (optype == OP_SHMREAD) { + /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ + if (! SvOK(mstr)) + sv_setpvn(mstr, "", 0); SvPV_force(mstr, len); mbuf = SvGROW(mstr, msize+1); @@ -1867,6 +1998,10 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) SvCUR_set(mstr, msize); *SvEND(mstr) = '\0'; SvSETMAGIC(mstr); +#ifndef INCOMPLETE_TAINTS + /* who knows who has been playing with this shared memory? */ + SvTAINTED_on(mstr); +#endif } else { I32 n;