X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/411caa507cab4ba311ec4000c486ad2592d51146..739f7a2afa6eb3ef5d427c2f86a7c5c89c94576e:/doio.c diff --git a/doio.c b/doio.c index 901ca71..0309e2a 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,6 @@ /* doio.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, 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. @@ -55,8 +55,8 @@ bool 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); + return do_openn(gv, name, len, as_raw, rawmode, rawperm, + supplied_fp, (SV **) NULL, 0); } bool @@ -64,9 +64,19 @@ 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) { + return do_openn(gv, name, len, as_raw, rawmode, rawperm, + supplied_fp, &svs, 1); +} + +bool +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) +{ register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; PerlIO *saveofp = Nullfp; + int savefd = -1; char savetype = IoTYPE_CLOSED; int writing = 0; PerlIO *fp; @@ -75,8 +85,8 @@ Perl_do_open9(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 *deftype = NULL; - char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + char mode[8]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + SV *namesv; Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ @@ -94,13 +104,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* If currently open - close before we re-open */ if (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); - if (IoTYPE(io) == IoTYPE_STD) + if (IoTYPE(io) == IoTYPE_STD) { + /* This is a clone of one of STD* handles */ result = 0; - else if (fd <= PL_maxsysfd) { - saveifp = IoIFP(io); - saveofp = IoOFP(io); + } + else if (fd >= 0 && fd <= PL_maxsysfd) { + /* This is one of the original STD* handles */ + saveifp = IoIFP(io); + saveofp = IoOFP(io); savetype = IoTYPE(io); - result = 0; + savefd = fd; + result = 0; } else if (IoTYPE(io) == IoTYPE_PIPE) result = PerlProc_pclose(IoIFP(io)); @@ -114,18 +128,34 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } else result = PerlIO_close(IoIFP(io)); - if (result == EOF && fd > PL_maxsysfd) + if (result == EOF && fd > PL_maxsysfd) { + /* Why is this not Perl_warn*() call ? */ PerlIO_printf(Perl_error_log, "Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); + } IoOFP(io) = IoIFP(io) = Nullfp; } 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 +#ifdef O_APPEND /* Not fully portable. */ + |O_APPEND +#endif +#ifdef O_TRUNC /* Not fully portable. */ + |O_TRUNC +#endif + )) + TAINT_PROPER("sysopen"); + mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) - rawmode |= O_LARGEFILE; + rawmode |= O_LARGEFILE; /* Transparently largefiley. */ #endif #ifndef O_ACCMODE @@ -144,39 +174,35 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_RDWR; break; } + writing = (result != O_RDONLY); - writing = (result > 0); - fd = PerlLIO_open3(name, rawmode, rawperm); - - if (fd == -1) - fp = NULL; - else { - STRLEN ix = 0; - if (result == O_RDONLY) { - mode[ix++] = 'r'; - } + if (result == O_RDONLY) { + mode[ix++] = 'r'; + } #ifdef O_APPEND - else if (rawmode & O_APPEND) { - mode[ix++] = 'a'; - if (result != O_WRONLY) - mode[ix++] = '+'; - } + else if (rawmode & O_APPEND) { + mode[ix++] = 'a'; + if (result != O_WRONLY) + mode[ix++] = '+'; + } #endif + else { + if (result == O_WRONLY) + mode[ix++] = 'w'; else { - if (result == O_WRONLY) - mode[ix++] = 'w'; - else { - mode[ix++] = 'r'; - mode[ix++] = '+'; - } + mode[ix++] = 'r'; + mode[ix++] = '+'; } - if (rawmode & O_BINARY) - mode[ix++] = 'b'; - mode[ix] = '\0'; - fp = PerlIO_fdopen(fd, mode); - if (!fp) - PerlLIO_close(fd); } + if (rawmode & O_BINARY) + mode[ix++] = 'b'; + mode[ix] = '\0'; + + namesv = sv_2mortal(newSVpvn(name,strlen(name))); + num_svs = 1; + svp = &namesv; + type = Nullch; + fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp); } else { /* Regular (non-sys) open */ @@ -193,8 +219,8 @@ Perl_do_open9(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 */ - STRLEN l; - name = SvPV(svs, l) ; + STRLEN l = 0; + name = SvOK(*svp) ? SvPV(*svp, l) : ""; len = (I32)l; name = savepvn(name, len); SAVEFREEPV(name); @@ -206,7 +232,10 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, len = tend-type; } IoTYPE(io) = *type; - if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */ + 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"); mode[1] = *type++; writing = 1; } @@ -225,7 +254,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = type; len = tend-type; } - if (*name == '\0') { /* command is missing 19990114 */ + if (*name == '\0') { + /* command is missing 19990114 */ if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -245,7 +275,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, strcat(mode, "b"); else if (out_crlf) strcat(mode, "t"); - fp = PerlProc_popen(name,mode); + if (num_svs > 1) { + fp = PerlProc_popen_list(mode, num_svs, svp); + } + else { + fp = PerlProc_popen(name,mode); + } } else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); @@ -255,8 +290,9 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, mode[0] = IoTYPE(io) = IoTYPE_APPEND; type++; } - else + else { mode[0] = 'w'; + } writing = 1; if (out_raw) @@ -265,27 +301,41 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, strcat(mode, "t"); if (*type == '&') { - name = type; duplicity: - if (num_svs) - goto unknown_desr; dodup = 1; - name++; - if (*name == '=') { + type++; + if (*type == '=') { dodup = 0; - name++; + type++; } - if (!*name && supplied_fp) + if (!num_svs && !*type && supplied_fp) { + /* "<+&" etc. is used by typemaps */ fp = supplied_fp; + } else { - /*SUPPRESS 530*/ - for (; isSPACE(*name); name++) ; - if (isDIGIT(*name)) - fd = atoi(name); + if (num_svs > 1) { + Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); + } + if (num_svs && SvIOK(*svp)) { + fd = SvUV(*svp); + } + else if (isDIGIT(*type)) { + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; + fd = atoi(type); + } else { IO* thatio; - gv = gv_fetchpv(name,FALSE,SVt_PVIO); - thatio = GvIO(gv); + 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); @@ -331,13 +381,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fd = PerlLIO_dup(fd); else was_fdopen = TRUE; - if (!(fp = PerlIO_fdopen(fd,mode))) { + if (!num_svs) + type = Nullch; + if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { if (dodup) PerlLIO_close(fd); } } - } + } /* & */ else { + if (num_svs > 1) { + Perl_croak(aTHX_ "More than one argument to '>' open"); + } /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { @@ -347,11 +402,20 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_STD; } else { - fp = PerlIO_open((num_svs ? name : type), mode); + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = Nullch; + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } - } + } /* !& */ } else if (*type == IoTYPE_RDONLY) { + if (num_svs > 1) { + Perl_croak(aTHX_ "More than one argument to '<' open"); + } /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; @@ -361,7 +425,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, strcat(mode, "t"); if (*type == '&') { - name = type; goto duplicity; } if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { @@ -370,8 +433,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } - else - fp = PerlIO_open((num_svs ? name : type), mode); + else { + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = Nullch; + } + 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) || (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { @@ -387,7 +457,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = type; len = tend-type; } - if (*name == '\0') { /* command is missing 19990114 */ + if (*name == '\0') { + /* command is missing 19990114 */ if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -401,7 +472,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, strcat(mode, "b"); else if (in_crlf) strcat(mode, "t"); - fp = PerlProc_popen(name,mode); + if (num_svs > 1) { + fp = PerlProc_popen_list(mode,num_svs,svp); + } + else { + fp = PerlProc_popen(name,mode); + } IoTYPE(io) = IoTYPE_PIPE; } else { @@ -421,7 +497,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_STD; } else { - fp = PerlIO_open(name,mode); + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = Nullch; + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } } @@ -430,7 +512,23 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); goto say_false; } - if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { + + 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"); + } + else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { + Perl_warner(aTHX_ WARN_IO, + "Filehandle STDIN opened only for output"); + } + } + + if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && + /* FIXME: This next term is a hack to avoid fileno on PerlIO::Scalar */ + !(num_svs && SvROK(*svp))) { if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { (void)PerlIO_close(fp); goto say_false; @@ -461,33 +559,40 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR then dup the new fileno down */ - fd = PerlIO_fileno(saveifp); + fd = PerlIO_fileno(fp); if (saveofp) { PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ PerlIO_close(saveofp); - /* This looks very suspect - NI-S 24 Nov 2000 */ - if (fd > 2) - Safefree(saveofp); /* ??? */ } } - if (fd != PerlIO_fileno(fp)) { + if (savefd != fd) { Pid_t pid; SV *sv; - - PerlLIO_dup2(PerlIO_fileno(fp), fd); + if (PerlLIO_dup2(fd, savefd) < 0) { + (void)PerlIO_close(fp); + goto say_false; + } +#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); + } + } +#endif LOCK_FDPID_MUTEX; - sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); + sv = *av_fetch(PL_fdpid,fd,TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; - sv = *av_fetch(PL_fdpid,fd,TRUE); + sv = *av_fetch(PL_fdpid,savefd,TRUE); UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) PerlIO_close(fp); - } fp = saveifp; PerlIO_clearerr(fp); @@ -501,51 +606,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; - if (!num_svs) { - /* Need to supply default type info from open.pm */ - SV *layers = PL_curcop->cop_io; - type = NULL; - if (layers) { - STRLEN len; - type = SvPV(layers,len); - if (type && mode[0] != 'r') { - /* Skip to write part */ - char *s = strchr(type,0); - if (s && (s-type) < len) { - type = s+1; - } - } - } - } - if (type) { - while (isSPACE(*type)) type++; - if (*type) { - if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) { - goto say_false; - } - } - } IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { if (IoTYPE(io) == IoTYPE_SOCKET - || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) - { + || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { mode[0] = 'w'; - if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,PerlIO_fileno(fp),0,0,NULL,num_svs,svp))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } - if (type && *type) { - if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) { - PerlIO_close(IoOFP(io)); - PerlIO_close(fp); - IoIFP(io) = Nullfp; - IoOFP(io) = Nullfp; - goto say_false; - } - } } else IoOFP(io) = fp; @@ -895,9 +966,7 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; - else if (ckWARN(WARN_IO) - && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout() - || IoIFP(io) == PerlIO_stderr())) + else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY)) { /* integrate to report_evil_fh()? */ char *name = NULL; @@ -944,7 +1013,7 @@ Perl_do_eof(pTHX_ GV *gv) Off_t Perl_do_tell(pTHX_ GV *gv) { - register IO *io; + register IO *io = 0; register PerlIO *fp; if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { @@ -963,7 +1032,7 @@ Perl_do_tell(pTHX_ GV *gv) bool Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) { - register IO *io; + register IO *io = 0; register PerlIO *fp; if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { @@ -982,7 +1051,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) Off_t Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) { - register IO *io; + register IO *io = 0; register PerlIO *fp; if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) @@ -1148,11 +1217,17 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } /* FALL THROUGH */ default: -#if 0 - /* XXX Fix this when the I/O disciplines arrive. XXX */ - if (DO_UTF8(sv)) - sv_utf8_downgrade(sv, FALSE); -#endif + if (PerlIO_isutf8(fp)) { + if (!SvUTF8(sv)) + sv_utf8_upgrade(sv = sv_mortalcopy(sv)); + } + else if (DO_UTF8(sv)) { + if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE) + && ckWARN(WARN_UTF8)) + { + Perl_warner(aTHX_ WARN_UTF8, "Wide character in print"); + } + } tmps = SvPV(sv, len); break; } @@ -1170,7 +1245,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) I32 Perl_my_stat(pTHX) { - djSP; + dSP; IO *io; GV* gv; @@ -1223,7 +1298,7 @@ Perl_my_stat(pTHX) I32 Perl_my_lstat(pTHX) { - djSP; + dSP; SV *sv; STRLEN n_a; if (PL_op->op_flags & OPf_REF) { @@ -1261,7 +1336,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; + char *tmps = Nullch; STRLEN n_a; if (sp > mark) { @@ -1274,15 +1349,18 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, *a++ = ""; } *a = Nullch; - if (*PL_Argv[0] != '/') /* will execvp use PATH? */ + if (really) + tmps = SvPV(really, n_a); + if ((!really && *PL_Argv[0] != '/') || + (really && *tmps != '/')) /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ - if (really && *(tmps = SvPV(really, n_a))) + if (really && *tmps) PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); else PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", - PL_Argv[0], Strerror(errno)); + (really ? tmps : PL_Argv[0]), Strerror(errno)); if (do_report) { int e = errno; @@ -1321,7 +1399,6 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) { register char **a; register char *s; - char flags[10]; while (*cmd && isSPACE(*cmd)) cmd++; @@ -1329,28 +1406,32 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) /* save an extra exec if possible */ #ifdef CSH - if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) { - strcpy(flags,"-c"); - s = cmd+PL_cshlen+3; - if (*s == 'f') { - s++; - strcat(flags,"f"); - } - if (*s == ' ') - s++; - if (*s++ == '\'') { - char *ncmd = s; - - while (*s) - s++; - if (s[-1] == '\n') - *--s = '\0'; - if (s[-1] == '\'') { - *--s = '\0'; - PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0); - *s = '\''; - return FALSE; - } + { + char flags[10]; + if (strnEQ(cmd,PL_cshname,PL_cshlen) && + strnEQ(cmd+PL_cshlen," -c",3)) { + strcpy(flags,"-c"); + s = cmd+PL_cshlen+3; + if (*s == 'f') { + s++; + strcat(flags,"f"); + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char *ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0); + *s = '\''; + return FALSE; + } + } } } #endif /* CSH */ @@ -1368,7 +1449,8 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) goto doshell; for (s = cmd; *s; s++) { - if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s != ' ' && !isALPHA(*s) && + strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { if (*s == '\n' && !s[1]) { *s = '\0'; break; @@ -1601,20 +1683,31 @@ nothing in the core. } 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 + "current time" */ + + if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) + utbufp = NULL; + Zero(&utbuf, sizeof utbuf, char); #ifdef BIG_TIME - utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */ - utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */ + utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */ #else - utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */ - utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */ + utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */ #endif APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); - if (PerlLIO_utime(name, &utbuf)) + if (PerlLIO_utime(name, utbufp)) tot--; } } @@ -1939,13 +2032,42 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) id = SvIVx(*++mark); opstr = *++mark; opbuf = SvPV(opstr, opsize); - if (opsize < sizeof(struct sembuf) - || (opsize % sizeof(struct sembuf)) != 0) { + if (opsize < 3 * SHORTSIZE + || (opsize % (3 * SHORTSIZE))) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } SETERRNO(0,0); - return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf)); + /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ + { + int nsops = opsize / (3 * sizeof (short)); + int i = nsops; + short *ops = (short *) opbuf; + short *o = ops; + struct sembuf *temps, *t; + I32 result; + + New (0, temps, nsops, struct sembuf); + t = temps; + while (i--) { + t->sem_num = *o++; + t->sem_op = *o++; + t->sem_flg = *o++; + t++; + } + result = semop(id, temps, nsops); + t = temps; + o = ops; + i = nsops; + while (i--) { + *o++ = t->sem_num; + *o++ = t->sem_op; + *o++ = t->sem_flg; + t++; + } + Safefree(temps); + return result; + } #else Perl_croak(aTHX_ "semop not implemented"); #endif @@ -2009,4 +2131,147 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #endif /* SYSV IPC */ +/* +=for apidoc start_glob + +Function called by C to spawn a glob (or do the glob inside +perl on VMS). This code used to be inline, but now perl uses C +this glob starter is only used by miniperl during the build proccess. +Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. +=cut +*/ + +PerlIO * +Perl_start_glob (pTHX_ SV *tmpglob, IO *io) +{ + SV *tmpcmd = NEWSV(55, 0); + PerlIO *fp; + ENTER; + SAVEFREESV(tmpcmd); +#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ + /* since spawning off a process is a real performance hit */ + { +#include +#include +#include +#include + char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; + char vmsspec[NAM$C_MAXRSS+1]; + char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; + $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); + PerlIO *tmpfp; + STRLEN i; + struct dsc$descriptor_s wilddsc + = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct dsc$descriptor_vs rsdsc + = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; + unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; + + /* We could find out if there's an explicit dev/dir or version + by peeking into lib$find_file's internal context at + ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb + but that's unsupported, so I don't want to do it now and + have it bite someone in the future. */ + cp = SvPV(tmpglob,i); + for (; i; i--) { + if (cp[i] == ';') hasver = 1; + if (cp[i] == '.') { + if (sts) hasver = 1; + else sts = 1; + } + if (cp[i] == '/') { + hasdir = isunix = 1; + break; + } + if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { + hasdir = 1; + break; + } + } + if ((tmpfp = PerlIO_tmpfile()) != NULL) { + Stat_t st; + if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) + ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); + else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); + if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); + 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--; + *(end++) = '\n'; *end = '\0'; + for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); + if (hasdir) { + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); + begin = rstr; + } + else { + begin = end; + while (*(--begin) != ']' && *begin != '>') ; + ++begin; + } + ok = (PerlIO_puts(tmpfp,begin) != EOF); + } + if (cxt) (void)lib$find_file_end(&cxt); + if (ok && sts != RMS$_NMF && + sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; + if (!ok) { + if (!(sts & 1)) { + SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); + } + PerlIO_close(tmpfp); + fp = NULL; + } + else { + PerlIO_rewind(tmpfp); + IoTYPE(io) = IoTYPE_RDONLY; + IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ + } + } + } +#else /* !VMS */ +#ifdef MACOS_TRADITIONAL + sv_setpv(tmpcmd, "glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#else +#ifdef DOSISH +#ifdef OS2 + sv_setpv(tmpcmd, "for a in "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); +#else +#ifdef DJGPP + sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ + sv_catsv(tmpcmd, tmpglob); +#else + sv_setpv(tmpcmd, "perlglob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#endif /* !DJGPP */ +#endif /* !OS2 */ +#else /* !DOSISH */ +#if defined(CSH) + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); + sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "' 2>/dev/null |"); +#else + sv_setpv(tmpcmd, "echo "); + sv_catsv(tmpcmd, tmpglob); +#if 'z' - 'a' == 25 + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); +#else + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); +#endif +#endif /* !CSH */ +#endif /* !DOSISH */ +#endif /* MACOS_TRADITIONAL */ + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); + fp = IoIFP(io); +#endif /* !VMS */ + LEAVE; + return fp; +}