X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=1d7e56fc40207e087cb7c4685264bf2c13be0aea;hb=f675c333aa2ffb38d0c396f20dded19915213ef6;hp=7e13f1f6d0b9ddfc4a31e05bc7d79f4d82f4a1d2;hpb=c797f2d8bff201dfca87c4500d2948210cedc10b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index 7e13f1f..1d7e56f 100644 --- a/doio.c +++ b/doio.c @@ -1,7 +1,7 @@ /* doio.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 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. @@ -15,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" @@ -48,6 +53,9 @@ # define OPEN_EXCL 0 #endif +#define PERL_MODE_MAX 8 +#define PERL_FLAGS_MAX 10 + #include bool @@ -63,6 +71,7 @@ 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) { + (void)num_svs; return do_openn(gv, name, len, as_raw, rawmode, rawperm, supplied_fp, &svs, 1); } @@ -72,6 +81,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num_svs) { + dVAR; register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; PerlIO *saveofp = Nullfp; @@ -84,7 +94,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); @@ -139,7 +149,7 @@ 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; - int appendtrunc = + const int appendtrunc = 0 #ifdef O_APPEND /* Not fully portable. */ |O_APPEND @@ -148,8 +158,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, |O_TRUNC #endif ; - int modifyingmode = - O_WRONLY|O_RDWR|O_CREAT|appendtrunc; + const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; int ismodifying; if (num_svs != 0) { @@ -211,7 +220,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs) { /* 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)) @@ -221,9 +229,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, goto say_false; } #endif /* USE_STDIO */ - name = SvOK(*svp) ? SvPV(*svp, l) : ""; - len = (I32)l; - name = savepvn(name, len); + name = SvOK(*svp) ? savesvpv (*svp) : savepvn ("", 0); SAVEFREEPV(name); } else { @@ -260,7 +266,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 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] == '|') { @@ -270,10 +276,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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); } @@ -301,11 +314,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; @@ -332,7 +351,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fd = atoi(type); } else { - IO* thatio; + const IO* thatio; if (num_svs) { thatio = sv_2io(*svp); } @@ -427,11 +446,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /*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; } @@ -478,14 +503,23 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 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); } @@ -510,11 +544,20 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /*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; } @@ -632,10 +675,10 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, sv = *av_fetch(PL_fdpid,fd,TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); - SvIVX(sv) = 0; + SvIV_set(sv, 0); sv = *av_fetch(PL_fdpid,savefd,TRUE); (void)SvUPGRADE(sv, SVt_IV); - SvIVX(sv) = pid; + SvIV_set(sv, pid); UNLOCK_FDPID_MUTEX; } #endif @@ -1014,11 +1057,14 @@ 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; } @@ -1136,7 +1182,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; @@ -1146,7 +1192,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; @@ -1172,6 +1218,7 @@ fail_discipline: #ifndef PERLIO_LAYERS Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); #else + len -= end-s; s = end; #endif } @@ -1186,7 +1233,7 @@ 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)) name = ":crlf"; @@ -1194,14 +1241,14 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) return PerlIO_binmode(aTHX_ fp, iotype, mode, name); } -#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) +I32 +my_chsize(int fd, Off_t length) +{ +#ifdef F_FREESP /* code courtesy of William Kucharski */ #define HAS_CHSIZE -I32 my_chsize(fd, length) -I32 fd; /* file descriptor */ -Off_t length; /* length to set file to */ -{ struct flock fl; Stat_t filebuf; @@ -1240,15 +1287,18 @@ Off_t length; /* length to set file to */ return -1; } - return 0; -} +#else + Perl_croak_nocontext("truncate not implemented"); #endif /* F_FREESP */ + return -1; +} +#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ bool Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { - register char *tmps; + register const char *tmps; STRLEN len; /* assuming fp is checked earlier */ @@ -1270,7 +1320,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)) { @@ -1367,7 +1417,7 @@ Perl_my_stat(pTHX) } } -static char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; +static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; I32 Perl_my_lstat(pTHX) @@ -1420,11 +1470,12 @@ bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, int fd, int do_report) { -#ifdef MACOS_TRADITIONAL + dVAR; +#if defined(MACOS_TRADITIONAL) || defined(SYMBIAN) 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) { @@ -1476,7 +1527,7 @@ Perl_do_execfree(pTHX) } } -#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(SYMBIAN) && !defined(MACOS_TRADITIONAL) bool Perl_do_exec(pTHX_ char *cmd) @@ -1487,6 +1538,7 @@ Perl_do_exec(pTHX_ char *cmd) bool Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) { + dVAR; register char **a; register char *s; @@ -1497,14 +1549,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++; @@ -1552,7 +1612,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && (!s[3] || isSPACE(s[3]))) { - char *t = s + 3; + const char *t = s + 3; while (*t && isSPACE(*t)) ++t; @@ -1590,12 +1650,11 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) goto doshell; } { - int e = errno; - if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(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); } @@ -1611,9 +1670,8 @@ I32 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; @@ -1654,6 +1712,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) what = "chown"; APPLY_TAINT_PROPER(); if (sp - mark > 2) { + register I32 val2; val = SvIVx(*++mark); val2 = SvIVx(*++mark); APPLY_TAINT_PROPER(); @@ -1772,16 +1831,17 @@ nothing in the core. if (sp - mark > 2) { #if defined(I_UTIME) || defined(VMS) struct utimbuf utbuf; + struct utimbuf *utbufp = &utbuf; #else struct { Time_t actime; Time_t modtime; } utbuf; + void *utbufp = &utbuf; #endif SV* accessed = *++mark; 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 @@ -1906,12 +1966,11 @@ Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) I32 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { - key_t key; - I32 n, flags; + key_t key = (key_t)SvNVx(*++mark); + const I32 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); + const I32 flags = SvIVx(*++mark); + (void)sp; - key = (key_t)SvNVx(*++mark); - n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); - flags = SvIVx(*++mark); SETERRNO(0,0); switch (optype) { @@ -1940,12 +1999,13 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { SV *astr; char *a; - I32 id, n, cmd, infosize, getinfo; + I32 infosize, getinfo; I32 ret = -1; + const I32 id = SvIVx(*++mark); + const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; + const I32 cmd = SvIVx(*++mark); + (void)sp; - id = SvIVx(*++mark); - n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; - cmd = SvIVx(*++mark); astr = *++mark; infosize = 0; getinfo = (cmd == IPC_STAT); @@ -2064,10 +2124,11 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) #ifdef HAS_MSG SV *mstr; char *mbuf; - I32 id, msize, flags; + I32 msize, flags; STRLEN len; + const I32 id = SvIVx(*++mark); + (void)sp; - id = SvIVx(*++mark); mstr = *++mark; flags = SvIVx(*++mark); mbuf = SvPV(mstr, len); @@ -2087,10 +2148,11 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) SV *mstr; char *mbuf; long mtype; - I32 id, msize, flags, ret; + I32 msize, flags, ret; STRLEN len; + const I32 id = SvIVx(*++mark); + (void)sp; - id = SvIVx(*++mark); mstr = *++mark; /* suppress warning when reading into undef var --jhi */ if (! SvOK(mstr)) @@ -2123,10 +2185,10 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) #ifdef HAS_SEM SV *opstr; char *opbuf; - I32 id; STRLEN opsize; + const I32 id = SvIVx(*++mark); + (void)sp; - id = SvIVx(*++mark); opstr = *++mark; opbuf = SvPV(opstr, opsize); if (opsize < 3 * SHORTSIZE @@ -2137,7 +2199,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) SETERRNO(0,0); /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ { - int nsops = opsize / (3 * sizeof (short)); + const int nsops = opsize / (3 * sizeof (short)); int i = nsops; short *ops = (short *) opbuf; short *o = ops; @@ -2176,11 +2238,12 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #ifdef HAS_SHM SV *mstr; char *mbuf, *shm; - I32 id, mpos, msize; + I32 mpos, msize; STRLEN len; struct shmid_ds shmds; + const I32 id = SvIVx(*++mark); + (void)sp; - id = SvIVx(*++mark); mstr = *++mark; mpos = SvIVx(*++mark); msize = SvIVx(*++mark); @@ -2244,6 +2307,7 @@ Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. PerlIO * Perl_start_glob (pTHX_ SV *tmpglob, IO *io) { + dVAR; SV *tmpcmd = NEWSV(55, 0); PerlIO *fp; ENTER;