doio.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* doio.c
*
* 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.
*
*/
/*
* "Far below them they saw the white waters pour into a foaming bowl, and
* then swirl darkly about a deep oval basin in the rocks, until they found
* their way out again through a narrow gate, and flowed away, fuming and
* chattering, into calmer and more level reaches."
*/
#include "EXTERN.h"
#define PERL_IN_DOIO_C
#include "perl.h"
#ifndef HAS_SEM
#endif
#ifdef HAS_MSG
#endif
#ifdef HAS_SHM
# ifndef HAS_SHMAT_PROTOTYPE
# endif
#endif
#endif
#ifdef I_UTIME
# if defined(_MSC_VER) || defined(__MINGW32__)
# else
# include <utime.h>
# endif
#endif
#ifdef O_EXCL
#else
# define OPEN_EXCL 0
#endif
#include <signal.h>
#endif
bool
{
supplied_fp, Nullsv, 0);
}
bool
{
char savetype = IoTYPE_CLOSED;
int writing = 0;
int fd;
int result;
bool was_fdopen = FALSE;
/* set up disciplines */
}
result = 0;
else if (fd <= PL_maxsysfd) {
result = 0;
}
}
else
}
else
"Warning: unable to close filehandle %s properly.\n",
}
if (as_raw) {
#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
rawmode |= O_LARGEFILE;
#endif
#ifndef O_ACCMODE
#endif
case O_RDONLY:
break;
case O_WRONLY:
break;
case O_RDWR:
default:
break;
}
if (fd == -1)
else {
char fpmode[4];
#ifdef O_APPEND
}
#endif
else {
else {
}
}
if (!fp)
}
}
else {
char *type;
int dodup;
if (num_svs) {
STRLEN l;
}
else {
}
--tlen;
writing = 1;
}
if (*type == IoTYPE_PIPE) {
}
/*SUPPRESS 530*/
if (!num_svs) {
}
goto say_false;
}
TAINT_ENV();
TAINT_PROPER("piped open");
}
{
char *mode;
if (out_raw)
mode = "wb";
else if (out_crlf)
mode = "wt";
else
mode = "w";
}
writing = 1;
}
else if (*type == IoTYPE_WRONLY) {
TAINT_PROPER("open");
type++;
if (*type == IoTYPE_WRONLY) {
/* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
type++;
tlen--;
}
else
mode[0] = 'w';
writing = 1;
if (out_raw)
else if (out_crlf)
goto unknown_desr;
if (*type == '&') {
dodup = 1;
name++;
if (*name == '=') {
dodup = 0;
name++;
}
if (!*name && supplied_fp)
fp = supplied_fp;
else {
/*SUPPRESS 530*/
else {
if (!thatio) {
#ifdef EINVAL
#endif
goto say_false;
}
/* Flush stdio buffer before dup. --mjd
* Unfortunately SEEK_CURing 0 seems to
* be optimized away on most platforms;
* only Solaris and Linux seem to flush
* on that. --jhi */
#ifdef USE_SFIO
/* sfio fails to clear error on next
sfwrite, contrary to documentation.
-- Nick Clark */
#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 */
/* When dup()ing STDIN, STDOUT or STDERR
* explicitly set appropriate access mode */
/* When dup()ing a socket, say result is
* one as well */
}
else
fd = -1;
}
if (dodup)
else
was_fdopen = TRUE;
if (dodup)
}
}
}
else {
/*SUPPRESS 530*/
fp = PerlIO_stdout();
}
else {
}
}
}
else if (*type == IoTYPE_RDONLY) {
goto unknown_desr;
/*SUPPRESS 530*/
mode[0] = 'r';
if (in_raw)
else if (in_crlf)
if (*type == '&') {
goto duplicity;
}
fp = PerlIO_stdin();
}
else
}
if (num_svs) {
goto unknown_desr;
}
else {
/*SUPPRESS 530*/
}
goto say_false;
}
TAINT_ENV();
TAINT_PROPER("piped open");
{
char *mode;
if (in_raw)
mode = "rb";
else if (in_crlf)
mode = "rt";
else
mode = "r";
}
}
else {
if (num_svs)
goto unknown_desr;
/*SUPPRESS 530*/
fp = PerlIO_stdin();
}
else {
char *mode;
if (in_raw)
mode = "rb";
else if (in_crlf)
mode = "rt";
else
mode = "r";
}
}
}
if (!fp) {
goto say_false;
}
(void)PerlIO_close(fp);
goto say_false;
}
#ifdef HAS_SOCKET
else if (
#ifdef S_IFMT
#else
#endif
) { /* on OS's that return 0 on fstat()ed pipe */
char tmpbuf[256];
&buflen) >= 0
/* but some return 0 for streams too, sigh */
}
#endif
}
if (saveifp) { /* must use old fp? */
if (saveofp) {
if (fd > 2)
}
}
#ifdef VMS
}
}
#endif
if (!was_fdopen)
}
}
{
int save_errno = errno;
errno = save_errno;
}
#endif
if (writing) {
{
char *mode;
if (out_raw)
mode = "wb";
else if (out_crlf)
mode = "wt";
else
mode = "w";
goto say_false;
}
}
else
}
return TRUE;
return FALSE;
}
PerlIO *
{
#ifndef FLEXFILENAMES
int filedev;
int fileino;
#endif
if (!PL_argvoutgv)
if (PL_inplace) {
if (!PL_argvout_stack)
PL_argvout_stack = newAV();
}
}
#ifdef HAS_FCHMOD
#else
#endif
}
PL_filemode = 0;
SAVEFREESV(sv);
if (PL_inplace) {
TAINT_PROPER("inplace open");
}
#ifndef FLEXFILENAMES
#endif
if (!S_ISREG(PL_filemode)) {
if (ckWARN_d(WARN_INPLACE))
"Can't do inplace edit: %s is not a regular file",
PL_oldname );
continue;
}
if (*PL_inplace) {
if (star) {
char *begin = PL_inplace;
do {
if (*begin)
}
else {
}
#ifndef FLEXFILENAMES
#ifdef DJGPP
|| (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
#endif
)
{
if (ckWARN_d(WARN_INPLACE))
"Can't do inplace edit: %s would not be unique",
continue;
}
#endif
#ifdef HAS_RENAME
#if !defined(DOSISH) && !defined(__CYGWIN__)
if (ckWARN_d(WARN_INPLACE))
"Can't rename %s to %s: %s, skipping file",
continue;
}
#else
#endif /* DOSISH */
#else
if (ckWARN_d(WARN_INPLACE))
"Can't rename %s to %s: %s, skipping file",
continue;
}
(void)UNLINK(PL_oldname);
#endif
}
else {
# ifndef VMS /* Don't delete; use automatic file versioning */
if (UNLINK(PL_oldname) < 0) {
if (ckWARN_d(WARN_INPLACE))
"Can't remove %s: %s, skipping file",
continue;
}
# endif
#else
#endif
}
SETERRNO(0,0); /* in case sprintf set errno */
#ifdef VMS
#else
#endif
{
if (ckWARN_d(WARN_INPLACE))
continue;
}
#ifdef HAS_FCHMOD
#else
# if !(defined(WIN32) && defined(__BORLANDC__))
/* Borland runtime creates a readonly file! */
# endif
#endif
#ifdef HAS_FCHOWN
#else
#ifdef HAS_CHOWN
#endif
#endif
}
}
}
else {
if (ckWARN_d(WARN_INPLACE)) {
{
"Can't do inplace edit: %s is not a regular file",
}
else
}
}
}
if (PL_inplace) {
{
return Nullfp;
}
}
return Nullfp;
}
#ifdef HAS_PIPE
void
{
int fd[2];
if (!rgv)
goto badexit;
if (!wgv)
goto badexit;
if (PerlProc_pipe(fd) < 0)
goto badexit;
else PerlLIO_close(fd[0]);
goto badexit;
}
return;
return;
}
#endif
/* explicit renamed to avoid C++ conflict -- kja */
bool
{
bool retval;
if (!gv)
if (not_implicit)
return FALSE;
}
if (!io) { /* never opened */
if (not_implicit) {
}
return FALSE;
}
if (not_implicit) {
}
return retval;
}
bool
{
int status;
if (not_implicit) {
retval = (STATUS_POSIX == 0);
}
else {
}
}
else {
}
else
}
}
else if (not_implicit) {
}
return retval;
}
bool
{
int ch;
if (!io)
return TRUE;
{
/* integrate to report_evil_fh()? */
}
"Filehandle %s opened only for output", name);
else
"Filehandle opened only for output");
}
return FALSE; /* this is the most usual case */
}
return FALSE;
}
}
return TRUE;
}
else
return TRUE; /* normal fp, definitely end of file */
}
return TRUE;
}
{
#ifdef ULTRIX_STDIO_BOTCH
if (PerlIO_eof(fp))
#endif
return PerlIO_tell(fp);
}
return (Off_t)-1;
}
bool
{
#ifdef ULTRIX_STDIO_BOTCH
if (PerlIO_eof(fp))
#endif
}
return FALSE;
}
{
return (Off_t)-1;
}
int
{
if (discp) {
while (*s) {
if (*s == ':') {
switch (s[1]) {
case 'r':
{
s += 4;
len -= 4;
break;
}
/* FALL THROUGH */
case 'c':
{
s += 5;
len -= 5;
break;
}
/* FALL THROUGH */
default:
goto fail_discipline;
}
}
else if (isSPACE(*s)) {
++s;
--len;
}
else {
char *end;
if (!end)
}
}
}
return mode;
}
int
{
#ifdef DOSISH
if (!PerlIO_flush(fp)) {
else
return 1;
}
return 0;
# else
# 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
* set the mode explicitly for the stream (though they don't
* document this anywhere). GSAR 97-5-24
*/
PerlIO_seek(fp,0L,0);
else
# endif
return 1;
}
else
return 0;
# endif
#else
# if defined(USEMYBINMODE)
return 1;
else
return 0;
# else
return 1;
# endif
#endif
}
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
{
return -1;
/* extend file length */
return -1;
/* write a "0" byte */
return -1;
}
else {
/* truncate length */
/*
* This relies on the UNDOCUMENTED F_FREESP argument to
* fcntl(2), which truncates the file so that it ends at the
* position indicated by fl.l_start.
*
* Will minor miracles never cease?
*/
return -1;
}
return 0;
}
#endif /* F_FREESP */
bool
{
register char *tmps;
/* assuming fp is checked earlier */
if (!sv)
return TRUE;
if (PL_ofmt) {
if (SvGMAGICAL(sv))
return !PerlIO_error(fp);
}
return !PerlIO_error(fp);
}
}
case SVt_NULL:
if (ckWARN(WARN_UNINITIALIZED))
return TRUE;
case SVt_IV:
if (SvGMAGICAL(sv))
else
return !PerlIO_error(fp);
}
/* FALL THROUGH */
default:
break;
}
/* To detect whether the process is about to overstep its
* filesize limit we would need getrlimit(). We could then
* also transparently raise the limit with setrlimit() --
* at which we would get EPERM. Note that when using buffered
return FALSE;
return !PerlIO_error(fp);
}
{
dSP;
}
else {
return PL_laststatval;
return (PL_laststatval = -1);
}
}
else {
char *s;
goto do_fstat;
}
goto do_fstat;
}
sv_setpv(PL_statname, s);
return PL_laststatval;
}
}
{
dSP;
if (PL_laststype != OP_LSTAT)
return PL_laststatval;
}
}
return PL_laststatval;
}
bool
{
}
bool
{
#ifdef MACOS_TRADITIONAL
#else
register char **a;
char *tmps;
a = PL_Argv;
if (*mark)
else
*a++ = "";
}
*a = Nullch;
if (really)
TAINT_ENV(); /* testing IFS here is overkill, probably */
else
if (do_report) {
int e = errno;
PerlLIO_write(fd, (void*)&e, sizeof(int));
}
}
do_execfree();
#endif
return FALSE;
}
void
{
if (PL_Argv) {
}
if (PL_Cmd) {
}
}
#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
bool
{
}
bool
{
register char **a;
register char *s;
char flags[10];
cmd++;
/* save an extra exec if possible */
#ifdef CSH
if (*s == 'f') {
s++;
}
if (*s == ' ')
s++;
if (*s++ == '\'') {
char *ncmd = s;
while (*s)
s++;
if (s[-1] == '\n')
*--s = '\0';
if (s[-1] == '\'') {
*--s = '\0';
*s = '\'';
return FALSE;
}
}
}
#endif /* CSH */
/* see if there are shell metacharacters in it */
goto doshell;
goto doshell;
if (*s == '=')
goto doshell;
for (s = cmd; *s; s++) {
if (*s == '\n' && !s[1]) {
*s = '\0';
break;
}
/* handle the 2>&1 construct at the end */
if (*s == '>' && s[1] == '&' && s[2] == '1'
{
char *t = s + 3;
while (*t && isSPACE(*t))
++t;
s[-2] = '\0';
break;
}
}
return FALSE;
}
}
a = PL_Argv;
for (s = PL_Cmd; *s;) {
while (*s && isSPACE(*s)) s++;
if (*s)
*(a++) = s;
while (*s && !isSPACE(*s)) s++;
if (*s)
*s++ = '\0';
}
*a = Nullch;
if (PL_Argv[0]) {
do_execfree();
goto doshell;
}
{
int e = errno;
if (do_report) {
PerlLIO_write(fd, (void*)&e, sizeof(int));
}
}
}
do_execfree();
return FALSE;
}
#endif /* OS2 || WIN32 */
{
char *what;
char *s;
#define APPLY_TAINT_PROPER() \
STMT_START { \
} STMT_END
/* This is a first heuristic; it doesn't catch tainting magic. */
if (PL_tainting) {
break;
}
}
}
switch (type) {
case OP_CHMOD:
what = "chmod";
tot--;
}
}
break;
#ifdef HAS_CHOWN
case OP_CHOWN:
what = "chown";
tot--;
}
}
break;
#endif
/*
XXX Should we make lchown() directly available from perl?
For now, we'll let Configure test for HAS_LCHOWN, but do
nothing in the core.
--AD 5/1998
*/
#ifdef HAS_KILL
case OP_KILL:
what = "kill";
break;
if (isUPPER(*s)) {
if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
s += 3;
}
else
#ifdef VMS
/* kill() doesn't do process groups (job trees?) under VMS */
# include <starlet.h>
/* Use native sys$delprc() to insure that target process is
* deleted; supervisor-mode images don't pay attention to
* CRTL's emulation of Unix-style signals and kill()
*/
register unsigned long int __vmssts;
tot--;
switch (__vmssts) {
case SS$_NOSUCHNODE:
break;
break;
default:
}
}
}
break;
}
#endif
if (val < 0) {
#ifdef HAS_KILLPG
#else
#endif
tot--;
}
}
else {
tot--;
}
}
break;
#endif
case OP_UNLINK:
what = "unlink";
if (UNLINK(s))
tot--;
}
else { /* don't let root wipe out directories without -U */
tot--;
else {
if (UNLINK(s))
tot--;
}
}
}
break;
#ifdef HAS_UTIME
case OP_UTIME:
what = "utime";
#else
struct {
} utbuf;
#endif
#ifdef BIG_TIME
#else
#endif
tot--;
}
}
else
tot = 0;
break;
#endif
}
return tot;
}
/* Do the permissions allow some operation? Assumes statcache already set. */
bool
/* Note: we use `effective' both for uids and gids.
* Here we are betting on Uid_t being equal or wider than Gid_t. */
{
#ifdef DOSISH
/* [Comments and code from Len Reed]
* MS-DOS "user" is similar to UNIX's "superuser," but can't write
* to write-protected files. The execute permission bit is set
* by the Miscrosoft C library stat() function for the following:
* .exe files
* .com files
* .bat files
* directories
* All files and directories are readable.
* Directories and special files, e.g. "CON", cannot be
* write-protected.
* [Comment by Tom Dinger -- a directory can have the write-protect
* bit set in the file system, but DOS permits changes to
* the directory anyway. In addition, all bets are off
* here for networked software, such as Novell and
* Sun's PC-NFS.]
*/
/* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
* too so it will actually look into the files for magic numbers
*/
#else /* ! DOSISH */
return TRUE;
}
else
return TRUE; /* root reads and writes anything */
return FALSE;
}
return TRUE; /* ok as "user" */
}
return TRUE; /* ok as "group" */
}
return TRUE; /* ok as "other" */
return FALSE;
#endif /* ! DOSISH */
}
#endif /* ! VMS */
bool
{
#ifdef MACOS_TRADITIONAL
/* This is simply not correct for AppleShare, but fix it yerself. */
return TRUE;
#else
return TRUE;
#ifdef HAS_GETGROUPS
#ifndef NGROUPS
#define NGROUPS 32
#endif
{
while (--anum >= 0)
return TRUE;
}
#endif
return FALSE;
#endif
}
{
SETERRNO(0,0);
switch (optype)
{
#ifdef HAS_MSG
case OP_MSGGET:
#endif
#ifdef HAS_SEM
case OP_SEMGET:
#endif
#ifdef HAS_SHM
case OP_SHMGET:
#endif
default:
#endif
}
return -1; /* should never happen */
}
{
char *a;
infosize = 0;
switch (optype)
{
#ifdef HAS_MSG
case OP_MSGCTL:
break;
#endif
#ifdef HAS_SHM
case OP_SHMCTL:
break;
#endif
#ifdef HAS_SEM
case OP_SEMCTL:
#ifdef Semctl
{
#ifdef EXTRA_F_IN_SEMUN_BUF
#else
#endif
return -1;
/* "short" is technically wrong but much more portable
than guessing about u_?short(_t)? */
}
#else
#endif
break;
#endif
default:
#endif
}
if (infosize)
{
if (getinfo)
{
}
else
{
(unsigned long)len,
(long)infosize);
}
}
else
{
a = INT2PTR(char *,i); /* ouch */
}
SETERRNO(0,0);
switch (optype)
{
#ifdef HAS_MSG
case OP_MSGCTL:
break;
#endif
#ifdef HAS_SEM
case OP_SEMCTL: {
#ifdef Semctl
#ifdef EXTRA_F_IN_SEMUN_BUF
#else
#endif
#else
#endif
}
break;
#endif
#ifdef HAS_SHM
case OP_SHMCTL:
break;
#endif
}
}
return ret;
}
{
#ifdef HAS_MSG
char *mbuf;
SETERRNO(0,0);
#else
#endif
}
{
#ifdef HAS_MSG
char *mbuf;
long mtype;
/* suppress warning when reading into undef var --jhi */
SETERRNO(0,0);
if (ret >= 0) {
#ifndef INCOMPLETE_TAINTS
/* who knows who has been playing with this message? */
#endif
}
return ret;
#else
#endif
}
{
#ifdef HAS_SEM
char *opbuf;
return -1;
}
SETERRNO(0,0);
#else
#endif
}
{
#ifdef HAS_SHM
SETERRNO(0,0);
return -1;
return -1;
}
return -1;
if (optype == OP_SHMREAD) {
/* suppress warning when reading into undef var (tchrist 3/Mar/00) */
#ifndef INCOMPLETE_TAINTS
/* who knows who has been playing with this shared memory? */
#endif
}
else {
I32 n;
n = msize;
if (n < msize)
}
#else
#endif
}
#endif /* SYSV IPC */