/* doio.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, 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.
rawmode |= O_LARGEFILE; /* Transparently largefiley. */
#endif
-#ifndef O_ACCMODE
-#define O_ACCMODE 3 /* Assume traditional implementation */
-#endif
-
- switch (result = rawmode & O_ACCMODE) {
- case O_RDONLY:
- IoTYPE(io) = IoTYPE_RDONLY;
- break;
- case O_WRONLY:
- IoTYPE(io) = IoTYPE_WRONLY;
- break;
- case O_RDWR:
- default:
- IoTYPE(io) = IoTYPE_RDWR;
- break;
- }
- writing = (result != O_RDONLY);
-
- if (result == O_RDONLY) {
- mode[ix++] = 'r';
- }
-#ifdef O_APPEND
- else if (rawmode & O_APPEND) {
- mode[ix++] = 'a';
- if (result != O_WRONLY)
- mode[ix++] = '+';
- }
-#endif
- else {
- if (result == O_WRONLY)
- mode[ix++] = 'w';
- else {
- mode[ix++] = 'r';
- mode[ix++] = '+';
- }
- }
- if (rawmode & O_BINARY)
- mode[ix++] = 'b';
- mode[ix] = '\0';
+ IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
namesv = sv_2mortal(newSVpvn(name,strlen(name)));
num_svs = 1;
STRLEN olen = len;
char *tend;
int dodup = 0;
+ PerlIO *that_fp = NULL;
type = savepvn(name, len);
tend = type+len;
SAVEFREEPV(type);
- /* Loose trailing white space */
- while (tend > type && isSPACE(tend[-1]))
- *tend-- = '\0';
+
+ /* Lose leading and trailing white space */
+ /*SUPPRESS 530*/
+ for (; isSPACE(*type); type++) ;
+ while (tend > type && isSPACE(tend[-1]))
+ *--tend = '\0';
+
if (num_svs) {
/* New style explict name, type is just mode and discipline/layer info */
STRLEN l = 0;
len = (I32)l;
name = savepvn(name, len);
SAVEFREEPV(name);
- /*SUPPRESS 530*/
- for (; isSPACE(*type); type++) ;
}
else {
name = type;
if (*type == '&') {
duplicity:
- dodup = 1;
+ dodup = PERLIO_DUP_FD;
type++;
if (*type == '=') {
dodup = 0;
}
if (!thatio) {
#ifdef EINVAL
- SETERRNO(EINVAL,VMS_SS_IVCHAN);
+ SETERRNO(EINVAL,SS$_IVCHAN);
#endif
goto say_false;
}
- if (IoIFP(thatio)) {
- PerlIO *fp = IoIFP(thatio);
+ if ((that_fp = IoIFP(thatio))) {
/* Flush stdio buffer before dup. --mjd
* Unfortunately SEEK_CURing 0 seems to
* be optimized away on most platforms;
/* sfio fails to clear error on next
sfwrite, contrary to documentation.
-- Nick Clark */
- if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
- PerlIO_clearerr(fp);
+ if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
+ PerlIO_clearerr(that_fp);
#endif
/* On the other hand, do all platforms
* take gracefully to flushing a read-only
* filehandle? Perhaps we should do
* fsetpos(src)+fgetpos(dst)? --nik */
- PerlIO_flush(fp);
- fd = PerlIO_fileno(fp);
+ PerlIO_flush(that_fp);
+ fd = PerlIO_fileno(that_fp);
/* When dup()ing STDIN, STDOUT or STDERR
* explicitly set appropriate access mode */
- if (IoIFP(thatio) == PerlIO_stdout()
- || IoIFP(thatio) == PerlIO_stderr())
+ if (that_fp == PerlIO_stdout()
+ || that_fp == PerlIO_stderr())
IoTYPE(io) = IoTYPE_WRONLY;
- else if (IoIFP(thatio) == PerlIO_stdin())
+ else if (that_fp == PerlIO_stdin())
IoTYPE(io) = IoTYPE_RDONLY;
/* When dup()ing a socket, say result is
* one as well */
else
fd = -1;
}
- if (dodup)
- fd = PerlLIO_dup(fd);
- else
- was_fdopen = TRUE;
if (!num_svs)
type = Nullch;
- if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+ if (that_fp) {
+ fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
+ }
+ else {
if (dodup)
- PerlLIO_close(fd);
+ fd = PerlLIO_dup(fd);
+ else
+ was_fdopen = TRUE;
+ 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] == ':')) {
type++;
fp = PerlIO_stdout();
IoTYPE(io) = IoTYPE_STD;
+ if (num_svs > 1) {
+ Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
+ }
}
else {
if (!num_svs) {
} /* !& */
}
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';
type++;
fp = PerlIO_stdin();
IoTYPE(io) = IoTYPE_STD;
+ if (num_svs > 1) {
+ Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
+ }
}
else {
if (!num_svs) {
}
}
- 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);
+ 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
+ * type probe for socket-ness.
+ */
+ if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
+ if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
+ /* If PerlIO claims to have fd we had better be able to fstat() it. */
+ (void) PerlIO_close(fp);
goto say_false;
}
+#ifndef PERL_MICRO
if (S_ISSOCK(PL_statbuf.st_mode))
IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
&& IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
&& IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
) { /* on OS's that return 0 on fstat()ed pipe */
- char tmpbuf[256];
- Sock_size_t buflen = sizeof tmpbuf;
- if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
- &buflen) >= 0
- || errno != ENOTSOCK)
- IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
- /* but some return 0 for streams too, sigh */
- }
-#endif
+ char tmpbuf[256];
+ Sock_size_t buflen = sizeof tmpbuf;
+ if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
+ || errno != ENOTSOCK)
+ IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
+ /* but some return 0 for streams too, sigh */
+ }
+#endif /* HAS_SOCKET */
+#endif /* !PERL_MICRO */
}
+
+ /* Eeek - FIXME !!!
+ * If this is a standard handle we discard all the layer stuff
+ * and just dup the fd into whatever was on the handle before !
+ */
+
if (saveifp) { /* must use old fp? */
/* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
then dup the new fileno down
*/
- fd = PerlIO_fileno(fp);
if (saveofp) {
PerlIO_flush(saveofp); /* emulate PerlIO_close() */
if (saveofp != saveifp) { /* was a socket? */
if (savefd != fd) {
Pid_t pid;
SV *sv;
+ /* 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
+ */
if (PerlLIO_dup2(fd, savefd) < 0) {
(void)PerlIO_close(fp);
goto say_false;
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);
+ 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
UNLOCK_FDPID_MUTEX;
(void)SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
- if (!was_fdopen)
+ if (!was_fdopen) {
PerlIO_close(fp);
+ }
}
fp = saveifp;
PerlIO_clearerr(fp);
+ fd = PerlIO_fileno(fp);
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- {
+ if (fd >= 0) {
int save_errno = errno;
- fd = PerlIO_fileno(fp);
fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
errno = save_errno;
}
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 && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
mode[0] = 'w';
- if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,PerlIO_fileno(fp),0,0,NULL,num_svs,svp))) {
+ if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
PerlIO_close(fp);
IoIFP(io) = Nullfp;
goto say_false;
sv_catpv(sv,PL_inplace);
}
#ifndef FLEXFILENAMES
- if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
- && PL_statbuf.st_dev == filedev
- && PL_statbuf.st_ino == fileino
+ if ((PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
+ && PL_statbuf.st_dev == filedev
+ && PL_statbuf.st_ino == fileino)
#ifdef DJGPP
- || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
+ || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
#endif
)
{
gv = PL_argvgv;
if (!gv || SvTYPE(gv) != SVt_PVGV) {
if (not_implicit)
- SETERRNO(EBADF,VMS_SS_IVCHAN);
+ SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
io = GvIO(gv);
if (not_implicit) {
if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,VMS_SS_IVCHAN);
+ SETERRNO(EBADF,SS$_IVCHAN);
}
return FALSE;
}
IoOFP(io) = IoIFP(io) = Nullfp;
}
else if (not_implicit) {
- SETERRNO(EBADF,VMS_SS_IVCHAN);
+ SETERRNO(EBADF,SS$_IVCHAN);
}
return retval;
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)) {
}
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,VMS_RMS_IFI);
+ SETERRNO(EBADF,RMS$_IFI);
return (Off_t)-1;
}
}
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,VMS_RMS_IFI);
+ SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
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,VMS_RMS_IFI);
+ SETERRNO(EBADF,RMS$_IFI);
return (Off_t)-1;
}
/* 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 = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw";
+ char *name = ":raw";
+#ifdef PERLIO_USING_CRLF
+ if (!(mode & O_BINARY))
+ name = ":crlf";
+#endif
return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
}
if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
utbufp = NULL;
-
+
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */
opbuf = SvPV(opstr, opsize);
if (opsize < 3 * SHORTSIZE
|| (opsize % (3 * SHORTSIZE))) {
- SETERRNO(EINVAL,VMS_LIB_INVARG);
+ SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
SETERRNO(0,0);
if (shmctl(id, IPC_STAT, &shmds) == -1)
return -1;
if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
- SETERRNO(EFAULT,VMS_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);
#endif /* SYSV IPC */
/*
+=head1 IO Functions
+
=for apidoc start_glob
Function called by C<do_readline> to spawn a glob (or do the glob inside
perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build proccess.
+this glob starter is only used by miniperl during the build process.
Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff