X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=5ac31047ae5751e603aa58786a32e774a5cd4896;hb=5460b889677b9f352c882dbcd4ad4470b8281664;hp=d68d13c4c9270eafc01eaeb58421d62a0419c0cd;hpb=9014280dc8264580f076d4325a59f22a11592058;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index d68d13c..5ac3104 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,6 @@ /* doio.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (c) 1991-2003, 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. @@ -213,6 +213,15 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs) { /* New style explict name, type is just mode and discipline/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); @@ -272,6 +281,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else { fp = PerlProc_popen(name,mode); } + if (num_svs) { + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + goto say_false; + } + } + } } else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); @@ -307,12 +323,13 @@ 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 { @@ -322,14 +339,12 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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; } @@ -474,6 +489,14 @@ 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 { if (num_svs) @@ -512,18 +535,20 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if ((IoTYPE(io) == IoTYPE_RDONLY) && (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle STD%s opened only for input", - (fp == PerlIO_stdout()) ? "OUT" : "ERR"); + "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_ packWARN(WARN_IO), - "Filehandle STDIN opened only for output"); + "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) { @@ -572,7 +597,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } if (savefd != fd) { - /* 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 */ @@ -639,8 +664,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 == 'I' || *s == '#') + 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; @@ -745,19 +773,19 @@ Perl_nextargv(pTHX_ register GV *gv) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s would not be unique", - SvPVX(sv)); + "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_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -772,8 +800,8 @@ Perl_nextargv(pTHX_ register GV *gv) if (link(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -893,8 +921,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"PIPESOCK_MODE); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE); + IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; IoTYPE(wstio) = IoTYPE_WRONLY; @@ -926,7 +955,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); @@ -934,7 +963,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; } @@ -978,7 +1007,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) IoOFP(io) = IoIFP(io) = Nullfp; } else if (not_implicit) { - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); } return retval; @@ -1039,7 +1068,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; } @@ -1058,7 +1087,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; } @@ -1072,7 +1101,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; } @@ -1154,7 +1183,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; @@ -1237,7 +1266,8 @@ 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) @@ -1714,22 +1744,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); @@ -2061,7 +2092,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); @@ -2118,7 +2149,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); @@ -2245,7 +2276,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);