/*    doio.c
 *
 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
 *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
 *
 */

/*
 * "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."
 */

/* 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"

#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#ifndef HAS_SEM
#include <sys/ipc.h>
#endif
#ifdef HAS_MSG
#include <sys/msg.h>
#endif
#ifdef HAS_SHM
#include <sys/shm.h>
# ifndef HAS_SHMAT_PROTOTYPE
    extern Shmat_t shmat (int, char *, int);
# endif
#endif
#endif

#ifdef I_UTIME
#  if defined(_MSC_VER) || defined(__MINGW32__)
#    include <sys/utime.h>
#  else
#    include <utime.h>
#  endif
#endif

#ifdef O_EXCL
#  define OPEN_EXCL O_EXCL
#else
#  define OPEN_EXCL 0
#endif

#define PERL_MODE_MAX 8
#define PERL_FLAGS_MAX 10

#include <signal.h>

bool
Perl_do_openn(pTHX_ GV *gv, register char *oname, I32 len, int as_raw,
	      int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
	      I32 num_svs)
{
    register IO * const io = GvIOn(gv);
    PerlIO *saveifp = NULL;
    PerlIO *saveofp = NULL;
    int savefd = -1;
    char savetype = IoTYPE_CLOSED;
    int writing = 0;
    PerlIO *fp;
    int fd;
    int result;
    bool was_fdopen = FALSE;
    bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
    char *type  = NULL;
    char mode[PERL_MODE_MAX];	/* file mode ("r\0", "rb\0", "ab\0" etc.) */
    SV *namesv;

    Zero(mode,sizeof(mode),char);
    PL_forkprocess = 1;		/* assume true if no fork */

    /* Collect default raw/crlf info from the op */
    if (PL_op && PL_op->op_type == OP_OPEN) {
	/* set up IO layers */
	const U8 flags = PL_op->op_private;
	in_raw = (flags & OPpOPEN_IN_RAW);
	in_crlf = (flags & OPpOPEN_IN_CRLF);
	out_raw = (flags & OPpOPEN_OUT_RAW);
	out_crlf = (flags & OPpOPEN_OUT_CRLF);
    }

    /* If currently open - close before we re-open */
    if (IoIFP(io)) {
	fd = PerlIO_fileno(IoIFP(io));
	if (IoTYPE(io) == IoTYPE_STD) {
	    /* This is a clone of one of STD* handles */
	    result = 0;
	}
	else if (fd >= 0 && fd <= PL_maxsysfd) {
	    /* This is one of the original STD* handles */
	    saveifp  = IoIFP(io);
	    saveofp  = IoOFP(io);
	    savetype = IoTYPE(io);
	    savefd   = fd;
	    result   = 0;
	}
	else if (IoTYPE(io) == IoTYPE_PIPE)
	    result = PerlProc_pclose(IoIFP(io));
	else if (IoIFP(io) != IoOFP(io)) {
	    if (IoOFP(io)) {
		result = PerlIO_close(IoOFP(io));
		PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
	    }
	    else
		result = PerlIO_close(IoIFP(io));
	}
	else
	    result = PerlIO_close(IoIFP(io));
	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) = NULL;
    }

    if (as_raw) {
        /* sysopen style args, i.e. integer mode and permissions */
	STRLEN ix = 0;
	const int appendtrunc =
	     0
#ifdef O_APPEND	/* Not fully portable. */
	     |O_APPEND
#endif
#ifdef O_TRUNC	/* Not fully portable. */
	     |O_TRUNC
#endif
	     ;
	const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
	int ismodifying;

	if (num_svs != 0) {
	     Perl_croak(aTHX_ "panic: sysopen with multiple args");
	}
	/* It's not always

	   O_RDONLY 0
	   O_WRONLY 1
	   O_RDWR   2

	   It might be (in OS/390 and Mac OS Classic it is)

	   O_WRONLY 1
	   O_RDONLY 2
	   O_RDWR   3

	   This means that simple & with O_RDWR would look
	   like O_RDONLY is present.  Therefore we have to
	   be more careful.
	*/
	if ((ismodifying = (rawmode & modifyingmode))) {
	     if ((ismodifying & O_WRONLY) == O_WRONLY ||
		 (ismodifying & O_RDWR)   == O_RDWR   ||
		 (ismodifying & (O_CREAT|appendtrunc)))
		  TAINT_PROPER("sysopen");
	}
	mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */

#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
	rawmode |= O_LARGEFILE;	/* Transparently largefiley. */
#endif

        IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);

	namesv = newSVpvn_flags(oname, len, SVs_TEMP);
	num_svs = 1;
	svp = &namesv;
	type = NULL;
	fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp);
    }
    else {
	/* Regular (non-sys) open */
	char *name;
	STRLEN olen = len;
	char *tend;
	int dodup = 0;

	type = savepvn(oname, len);
	tend = type+len;
	SAVEFREEPV(type);

        /* Lose leading and trailing white space */
	while (isSPACE(*type))
	    type++;
        while (tend > type && isSPACE(tend[-1]))
	    *--tend = '\0';

	if (num_svs) {
	    /* New style explicit name, type is just mode and layer info */
#ifdef USE_STDIO
	    if (SvROK(*svp) && !strchr(oname,'&')) {
		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) ? savesvpv (*svp) : savepvn ("", 0);
	    SAVEFREEPV(name);
	}
	else {
	    name = type;
	    len  = tend-type;
	}
	IoTYPE(io) = *type;
	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;
	}

	if (*type == IoTYPE_PIPE) {
	    if (num_svs) {
		if (type[1] != IoTYPE_STD) {
	          unknown_open_mode:
		    Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
		}
		type++;
	    }
	    do {
		type++;
	    } while (isSPACE(*type));
	    if (!num_svs) {
		name = type;
		len = tend-type;
	    }
	    if (*name == '\0') {
		/* command is missing 19990114 */
		if (ckWARN(WARN_PIPE))
		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
		errno = EPIPE;
		goto say_false;
	    }
	    if (!(*name == '-' && name[1] == '\0') || num_svs)
		TAINT_ENV();
	    TAINT_PROPER("piped open");
	    if (!num_svs && name[len-1] == '|') {
		name[--len] = '\0' ;
		if (ckWARN(WARN_PIPE))
		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
	    }
	    mode[0] = 'w';
	    writing = 1;
            if (out_raw)
		mode[1] = 'b';
            else if (out_crlf)
		mode[1] = 't';
	    if (num_svs > 1) {
		fp = PerlProc_popen_list(mode, num_svs, svp);
	    }
	    else {
		fp = PerlProc_popen(name,mode);
	    }
	    if (num_svs) {
		if (*type) {
		    if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
			goto say_false;
		    }
		}
	    }
	} /* IoTYPE_PIPE */
	else if (*type == IoTYPE_WRONLY) {
	    TAINT_PROPER("open");
	    type++;
	    if (*type == IoTYPE_WRONLY) {
		/* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
		mode[0] = IoTYPE(io) = IoTYPE_APPEND;
		type++;
	    }
	    else {
		mode[0] = 'w';
	    }
	    writing = 1;

            if (out_raw)
		mode[1] = 'b';
            else if (out_crlf)
		mode[1] = 't';
	    if (*type == '&') {
	      duplicity:
		dodup = PERLIO_DUP_FD;
		type++;
		if (*type == '=') {
		    dodup = 0;
		    type++;
		}
		if (!num_svs && !*type && supplied_fp) {
		    /* "<+&" etc. is used by typemaps */
		    fp = supplied_fp;
		}
		else {
		    PerlIO *that_fp = NULL;
		    if (num_svs > 1) {
			Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
		    }
		    while (isSPACE(*type))
			type++;
		    if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
			fd = SvUV(*svp);
			num_svs = 0;
		    }
		    else if (isDIGIT(*type)) {
			fd = atoi(type);
		    }
		    else {
			const IO* thatio;
			if (num_svs) {
			    thatio = sv_2io(*svp);
			}
			else {
			    GV * const thatgv = gv_fetchpvn_flags(type, tend - type,
						       0, SVt_PVIO);
			    thatio = GvIO(thatgv);
			}
			if (!thatio) {
#ifdef EINVAL
			    SETERRNO(EINVAL,SS_IVCHAN);
#endif
			    goto say_false;
			}
			if ((that_fp = IoIFP(thatio))) {
			    /* 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.
			       -- Nicholas Clark */
			    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(that_fp);
			    fd = PerlIO_fileno(that_fp);
			    /* When dup()ing STDIN, STDOUT or STDERR
			     * explicitly set appropriate access mode */
			    if (that_fp == PerlIO_stdout()
				|| that_fp == PerlIO_stderr())
			        IoTYPE(io) = IoTYPE_WRONLY;
			    else if (that_fp == PerlIO_stdin())
                                IoTYPE(io) = IoTYPE_RDONLY;
			    /* When dup()ing a socket, say result is
			     * one as well */
			    else if (IoTYPE(thatio) == IoTYPE_SOCKET)
				IoTYPE(io) = IoTYPE_SOCKET;
			}
			else
			    fd = -1;
		    }
		    if (!num_svs)
			type = NULL;
		    if (that_fp) {
			fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
		    }
		    else {
			if (dodup)
			    fd = PerlLIO_dup(fd);
			else
			    was_fdopen = TRUE;
			if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
			    if (dodup && fd >= 0)
				PerlLIO_close(fd);
			}
		    }
		}
	    } /* & */
	    else {
		while (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) {
			namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
			num_svs = 1;
			svp = &namesv;
		        type = NULL;
		    }
		    fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
		}
	    } /* !& */
	    if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
	       goto unknown_open_mode;
	} /* IoTYPE_WRONLY */
	else if (*type == IoTYPE_RDONLY) {
	    do {
		type++;
	    } while (isSPACE(*type));
	    mode[0] = 'r';
            if (in_raw)
		mode[1] = 'b';
            else if (in_crlf)
		mode[1] = 't';
	    if (*type == '&') {
		goto duplicity;
	    }
	    if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
		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) {
		    namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
		    num_svs = 1;
		    svp = &namesv;
		    type = NULL;
		}
		fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
	    }
	    if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
	       goto unknown_open_mode;
	} /* IoTYPE_RDONLY */
	else if ((num_svs && /* '-|...' or '...|' */
		  type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
	         (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
	    if (num_svs) {
		type += 2;   /* skip over '-|' */
	    }
	    else {
		*--tend = '\0';
		while (tend > type && isSPACE(tend[-1]))
		    *--tend = '\0';
		for (; isSPACE(*type); type++)
		    ;
		name = type;
	        len  = tend-type;
	    }
	    if (*name == '\0') {
		/* command is missing 19990114 */
		if (ckWARN(WARN_PIPE))
		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
		errno = EPIPE;
		goto say_false;
	    }
	    if (!(*name == '-' && name[1] == '\0') || num_svs)
		TAINT_ENV();
	    TAINT_PROPER("piped open");
	    mode[0] = 'r';

            if (in_raw)
		mode[1] = 'b';
            else if (in_crlf)
		mode[1] = 't';

	    if (num_svs > 1) {
		fp = PerlProc_popen_list(mode,num_svs,svp);
	    }
	    else {
		fp = PerlProc_popen(name,mode);
	    }
	    IoTYPE(io) = IoTYPE_PIPE;
	    if (num_svs) {
		while (isSPACE(*type))
		    type++;
		if (*type) {
		    if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
			goto say_false;
		    }
		}
	    }
	}
	else { /* layer(Args) */
	    if (num_svs)
		goto unknown_open_mode;
	    name = type;
	    IoTYPE(io) = IoTYPE_RDONLY;
	    for (; isSPACE(*name); name++)
		;
	    mode[0] = 'r';

            if (in_raw)
		mode[1] = 'b';
            else if (in_crlf)
		mode[1] = 't';

	    if (*name == '-' && name[1] == '\0') {
		fp = PerlIO_stdin();
		IoTYPE(io) = IoTYPE_STD;
	    }
	    else {
		if (!num_svs) {
		    namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
		    num_svs = 1;
		    svp = &namesv;
		    type = NULL;
		}
		fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
	    }
	}
    }
    if (!fp) {
	if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
	    && strchr(oname, '\n')
	    
	)
	    Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
	goto say_false;
    }

    if (ckWARN(WARN_IO)) {
	if ((IoTYPE(io) == IoTYPE_RDONLY) &&
	    (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
		Perl_warner(aTHX_ packWARN(WARN_IO),
			    "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 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
     * 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
	else if (
#ifdef S_IFMT
	    !(PL_statbuf.st_mode & S_IFMT)
#else
	    !PL_statbuf.st_mode
#endif
	    && 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(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
         */
	if (saveofp) {
	    PerlIO_flush(saveofp);	/* emulate PerlIO_close() */
	    if (saveofp != saveifp) {	/* was a socket? */
		PerlIO_close(saveofp);
	    }
	}
	if (savefd != fd) {
	    /* 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;
	    }
#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

#if !defined(WIN32)
           /* PL_fdpid isn't used on Windows, so avoid this useless work.
            * XXX Probably the same for a lot of other places. */
            {
                Pid_t pid;
                SV *sv;

                LOCK_FDPID_MUTEX;
                sv = *av_fetch(PL_fdpid,fd,TRUE);
                (void)SvUPGRADE(sv, SVt_IV);
                pid = SvIVX(sv);
                SvIV_set(sv, 0);
                sv = *av_fetch(PL_fdpid,savefd,TRUE);
                (void)SvUPGRADE(sv, SVt_IV);
                SvIV_set(sv, pid);
                UNLOCK_FDPID_MUTEX;
            }
#endif

	    if (was_fdopen) {
                /* need to close fp without closing underlying fd */
                int ofd = PerlIO_fileno(fp);
                int dupfd = PerlLIO_dup(ofd);
#if defined(HAS_FCNTL) && defined(F_SETFD)
		/* Assume if we have F_SETFD we have F_GETFD */
                int coe = fcntl(ofd,F_GETFD);
#endif
                PerlIO_close(fp);
                PerlLIO_dup2(dupfd,ofd);
#if defined(HAS_FCNTL) && defined(F_SETFD)
		/* The dup trick has lost close-on-exec on ofd */
		fcntl(ofd,F_SETFD, coe);
#endif
                PerlLIO_close(dupfd);
	    }
            else
		PerlIO_close(fp);
	}
	fp = saveifp;
	PerlIO_clearerr(fp);
	fd = PerlIO_fileno(fp);
    }
#if defined(HAS_FCNTL) && defined(F_SETFD)
    if (fd >= 0) {
	const int save_errno = errno;
	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
	errno = save_errno;
    }
#endif
    IoIFP(io) = fp;

    IoFLAGS(io) &= ~IOf_NOLINE;
    if (writing) {
	if (IoTYPE(io) == IoTYPE_SOCKET
	    || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
	    char *s = mode;
	    if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
	      s++;
	    *s = 'w';
	    if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
		PerlIO_close(fp);
		IoIFP(io) = NULL;
		goto say_false;
	    }
	}
	else
	    IoOFP(io) = fp;
    }
    return TRUE;

say_false:
    IoIFP(io) = saveifp;
    IoOFP(io) = saveofp;
    IoTYPE(io) = savetype;
    return FALSE;
}

PerlIO *
Perl_nextargv(pTHX_ register GV *gv)
{
    register SV *sv;
#ifndef FLEXFILENAMES
    int filedev;
    int fileino;
#endif
    Uid_t fileuid;
    Gid_t filegid;
    IO * const io = GvIOp(gv);

    if (!PL_argvoutgv)
	PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
    if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
	IoFLAGS(io) &= ~IOf_START;
	if (PL_inplace) {
	    assert(PL_defoutgv);
	    Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
				    SvREFCNT_inc_simple_NN(PL_defoutgv));
	}
    }
    if (PL_filemode & (S_ISUID|S_ISGID)) {
	PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
#ifdef HAS_FCHMOD
	if (PL_lastfd != -1)
	    (void)fchmod(PL_lastfd,PL_filemode);
#else
	(void)PerlLIO_chmod(PL_oldname,PL_filemode);
#endif
    }
    PL_lastfd = -1;
    PL_filemode = 0;
    if (!GvAV(gv))
	return NULL;
    while (av_len(GvAV(gv)) >= 0) {
	STRLEN oldlen;
	sv = av_shift(GvAV(gv));
	SAVEFREESV(sv);
	sv_setsv(GvSVn(gv),sv);
	SvSETMAGIC(GvSV(gv));
	PL_oldname = SvPVx(GvSV(gv), oldlen);
	if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,NULL)) {
	    if (PL_inplace) {
		TAINT_PROPER("inplace open");
		if (oldlen == 1 && *PL_oldname == '-') {
		    setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
					  SVt_PVIO));
		    return IoIFP(GvIOp(gv));
		}
#ifndef FLEXFILENAMES
		filedev = PL_statbuf.st_dev;
		fileino = PL_statbuf.st_ino;
#endif
		PL_filemode = PL_statbuf.st_mode;
		fileuid = PL_statbuf.st_uid;
		filegid = PL_statbuf.st_gid;
		if (!S_ISREG(PL_filemode)) {
		    if (ckWARN_d(WARN_INPLACE))	
		        Perl_warner(aTHX_ packWARN(WARN_INPLACE),
			    "Can't do inplace edit: %s is not a regular file",
		            PL_oldname );
		    do_close(gv,FALSE);
		    continue;
		}
		if (*PL_inplace) {
		    const char *star = strchr(PL_inplace, '*');
		    if (star) {
			const char *begin = PL_inplace;
			sv_setpvn(sv, "", 0);
			do {
			    sv_catpvn(sv, begin, star - begin);
			    sv_catpvn(sv, PL_oldname, oldlen);
			    begin = ++star;
			} while ((star = strchr(begin, '*')));
			if (*begin)
			    sv_catpv(sv,begin);
		    }
		    else {
			sv_catpv(sv,PL_inplace);
		    }
#ifndef FLEXFILENAMES
		    if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
			 && PL_statbuf.st_dev == filedev
			 && PL_statbuf.st_ino == fileino)
#ifdef DJGPP
			|| ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
#endif
                      )
		    {
			if (ckWARN_d(WARN_INPLACE))	
			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
			      "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__) && !defined(EPOC)
		    if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
		        if (ckWARN_d(WARN_INPLACE))	
			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
			      "Can't rename %s to %"SVf": %s, skipping file",
			      PL_oldname, (void*)sv, Strerror(errno));
			do_close(gv,FALSE);
			continue;
		    }
#else
		    do_close(gv,FALSE);
		    (void)PerlLIO_unlink(SvPVX_const(sv));
		    (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
		    do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),PL_inplace!=0,
			    O_RDONLY,0,NULL);
#endif /* DOSISH */
#else
		    (void)UNLINK(SvPVX_const(sv));
		    if (link(PL_oldname,SvPVX_const(sv)) < 0) {
		        if (ckWARN_d(WARN_INPLACE))	
			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
			      "Can't rename %s to %"SVf": %s, skipping file",
			      PL_oldname, sv, Strerror(errno) );
			do_close(gv,FALSE);
			continue;
		    }
		    (void)UNLINK(PL_oldname);
#endif
		}
		else {
#if !defined(DOSISH) && !defined(AMIGAOS)
#  ifndef VMS  /* Don't delete; use automatic file versioning */
		    if (UNLINK(PL_oldname) < 0) {
		        if (ckWARN_d(WARN_INPLACE))	
			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
			      "Can't remove %s: %s, skipping file",
			      PL_oldname, Strerror(errno) );
			do_close(gv,FALSE);
			continue;
		    }
#  endif
#else
		    Perl_croak(aTHX_ "Can't do inplace edit without backup");
#endif
		}

		sv_setpvn(sv,">",!PL_inplace);
		sv_catpvn(sv,PL_oldname,oldlen);
		SETERRNO(0,0);		/* in case sprintf set errno */
#ifdef VMS
		if (!do_open(PL_argvoutgv,(char*)SvPVX_const(sv),SvCUR(sv),
			     PL_inplace!=0,O_WRONLY|O_CREAT|O_TRUNC,0,NULL))
#else
		    if (!do_open(PL_argvoutgv,(char*)SvPVX_const(sv),SvCUR(sv),
			     PL_inplace!=0,O_WRONLY|O_CREAT|OPEN_EXCL,0666,
			     NULL))
#endif
		{
		    if (ckWARN_d(WARN_INPLACE))	
		        Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
		          PL_oldname, Strerror(errno) );
		    do_close(gv,FALSE);
		    continue;
		}
		setdefout(PL_argvoutgv);
		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
#ifdef HAS_FCHMOD
		(void)fchmod(PL_lastfd,PL_filemode);
#else
#  if !(defined(WIN32) && defined(__BORLANDC__))
		/* Borland runtime creates a readonly file! */
		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
#  endif
#endif
		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
#ifdef HAS_FCHOWN
		    (void)fchown(PL_lastfd,fileuid,filegid);
#else
#ifdef HAS_CHOWN
		    (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
#endif
#endif
		}
	    }
	    return IoIFP(GvIOp(gv));
	}
	else {
	    if (ckWARN_d(WARN_INPLACE)) {
		const int eno = errno;
		if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
		    && !S_ISREG(PL_statbuf.st_mode))	
		{
		    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
				"Can't do inplace edit: %s is not a regular file",
				PL_oldname);
		}
		else
		    Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
				PL_oldname, Strerror(eno));
	    }
	}
    }
    if (io && (IoFLAGS(io) & IOf_ARGV))
	IoFLAGS(io) |= IOf_START;
    if (PL_inplace) {
	(void)do_close(PL_argvoutgv,FALSE);
	if (io && (IoFLAGS(io) & IOf_ARGV)
	    && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
	{
	    GV * const oldout = (GV*)av_pop(PL_argvout_stack);
	    setdefout(oldout);
	    SvREFCNT_dec(oldout);
	    return NULL;
	}
	setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
    }
    return NULL;
}

/* explicit renamed to avoid C++ conflict    -- kja */
bool
Perl_do_close(pTHX_ GV *gv, bool not_implicit)
{
    bool retval;
    IO *io;

    if (!gv)
	gv = PL_argvgv;
    if (!gv || !isGV_with_GP(gv)) {
	if (not_implicit)
	    SETERRNO(EBADF,SS_IVCHAN);
	return FALSE;
    }
    io = GvIO(gv);
    if (!io) {		/* never opened */
	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);
	}
	return FALSE;
    }
    retval = io_close(io, not_implicit);
    if (not_implicit) {
	IoLINES(io) = 0;
	IoPAGE(io) = 0;
	IoLINES_LEFT(io) = IoPAGE_LEN(io);
    }
    IoTYPE(io) = IoTYPE_CLOSED;
    return retval;
}

bool
Perl_io_close(pTHX_ IO *io, bool not_implicit)
{
    bool retval = FALSE;

    if (IoIFP(io)) {
	if (IoTYPE(io) == IoTYPE_PIPE) {
	    const int status = PerlProc_pclose(IoIFP(io));
	    if (not_implicit) {
		STATUS_NATIVE_CHILD_SET(status);
		retval = (STATUS_UNIX == 0);
	    }
	    else {
		retval = (status != -1);
	    }
	}
	else if (IoTYPE(io) == IoTYPE_STD)
	    retval = TRUE;
	else {
	    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {		/* a socket */
		const 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 {
		const bool prev_err = PerlIO_error(IoIFP(io));
		retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
	    }
	}
	IoOFP(io) = IoIFP(io) = NULL;
    }
    else if (not_implicit) {
	SETERRNO(EBADF,SS_IVCHAN);
    }

    return retval;
}

bool
Perl_do_eof(pTHX_ GV *gv)
{
    register IO * const io = GvIO(gv);

    if (!io)
	return TRUE;
    else if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
	report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);

    while (IoIFP(io)) {
        if (PerlIO_has_cntptr(IoIFP(io))) {	/* (the code works without this) */
	    if (PerlIO_get_cnt(IoIFP(io)) > 0)	/* cheat a little, since */
		return FALSE;			/* this is the most usual case */
        }

	{
	     /* getc and ungetc can stomp on errno */
	    const int saverrno = errno;
	    const int ch = PerlIO_getc(IoIFP(io));
	    if (ch != EOF) {
		(void)PerlIO_ungetc(IoIFP(io),ch);
		errno = saverrno;
		return FALSE;
	    }
	    errno = saverrno;
	}

        if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
	    if (PerlIO_get_cnt(IoIFP(io)) < -1)
		PerlIO_set_cnt(IoIFP(io),-1);
	}
	if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
	    if (gv != PL_argvgv || !nextargv(gv))	/* get another fp handy */
		return TRUE;
	}
	else
	    return TRUE;		/* normal fp, definitely end of file */
    }
    return TRUE;
}

Off_t
Perl_do_tell(pTHX_ GV *gv)
{
    register IO *io = NULL;
    register PerlIO *fp;

    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
	if (PerlIO_eof(fp))
	    (void)PerlIO_seek(fp, 0L, 2);	/* ultrix 1.2 workaround */
#endif
	return PerlIO_tell(fp);
    }
    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	report_evil_fh(gv, io, PL_op->op_type);
    SETERRNO(EBADF,RMS_IFI);
    return (Off_t)-1;
}

bool
Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
{
    register IO *io = NULL;
    register PerlIO *fp;

    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
	if (PerlIO_eof(fp))
	    (void)PerlIO_seek(fp, 0L, 2);	/* ultrix 1.2 workaround */
#endif
	return PerlIO_seek(fp, pos, whence) >= 0;
    }
    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	report_evil_fh(gv, io, PL_op->op_type);
    SETERRNO(EBADF,RMS_IFI);
    return FALSE;
}

Off_t
Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
{
    register IO *io = NULL;
    register PerlIO *fp;

    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
	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);
    return (Off_t)-1;
}

int
Perl_mode_from_discipline(pTHX_ SV *discp)
{
    int mode = O_BINARY;
    if (discp) {
	STRLEN len;
	const char *s = SvPV_const(discp,len);
	while (*s) {
	    if (*s == ':') {
		switch (s[1]) {
		case 'r':
		    if (s[2] == 'a' && s[3] == 'w'
			&& (!s[4] || s[4] == ':' || isSPACE(s[4])))
		    {
			mode = O_BINARY;
			s += 4;
			len -= 4;
			break;
		    }
		    /* FALL THROUGH */
		case 'c':
		    if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
			&& (!s[5] || s[5] == ':' || isSPACE(s[5])))
		    {
			mode = O_TEXT;
			s += 5;
			len -= 5;
			break;
		    }
		    /* FALL THROUGH */
		default:
		    goto fail_discipline;
		}
	    }
	    else if (isSPACE(*s)) {
		++s;
		--len;
	    }
	    else {
		const char *end;
fail_discipline:
		end = strchr(s+1, ':');
		if (!end)
		    end = s+len;
#ifndef PERLIO_LAYERS
		Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
#else
		len -= end-s;
		s = end;
#endif
	    }
	}
    }
    return mode;
}

#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

    Stat_t filebuf;

    if (PerlLIO_fstat(fd, &filebuf) < 0)
	return -1;

    if (filebuf.st_size < length) {

	/* extend file length */

	if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
	    return -1;

	/* write a "0" byte */

	if ((PerlLIO_write(fd, "", 1)) != 1)
	    return -1;
    }
    else {
	/* truncate length */
	struct flock fl;
	fl.l_whence = 0;
	fl.l_len = 0;
	fl.l_start = length;
	fl.l_type = F_WRLCK;    /* write lock on file space */

	/*
	* 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?
	*/

	if (fcntl(fd, F_FREESP, &fl) < 0)
	    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)
{
    /* assuming fp is checked earlier */
    if (!sv)
	return TRUE;
    if (PL_ofmt) {
	if (SvGMAGICAL(sv))
	    mg_get(sv);
        if (SvIOK(sv) && SvIVX(sv) != 0) {
	    PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
	    return !PerlIO_error(fp);
	}
	if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
	   || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
	    PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
	    return !PerlIO_error(fp);
	}
    }
    if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
	assert(!SvGMAGICAL(sv));
	if (SvIsUV(sv))
	    PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
	else
	    PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
	return !PerlIO_error(fp);
    }
    else {
	STRLEN len;
	/* Do this first to trigger any overloading.  */
	const char *tmps = SvPV_const(sv, len);
	U8 *tmpbuf = NULL;
	bool happy = TRUE;

	if (PerlIO_isutf8(fp)) {
	    if (!SvUTF8(sv)) {
		/* We don't modify the original scalar.  */
		tmpbuf = bytes_to_utf8((U8*) tmps, &len);
		tmps = (char *) tmpbuf;
	    }
	}
	else if (DO_UTF8(sv)) {
	    STRLEN tmplen = len;
	    bool utf8 = TRUE;
	    U8 * const result = bytes_from_utf8((U8*) tmps, &tmplen, &utf8);
	    if (!utf8) {
		tmpbuf = result;
		tmps = (char *) tmpbuf;
		len = tmplen;
	    }
	    else {
		assert((char *)result == tmps);
		if (ckWARN_d(WARN_UTF8)) {
		    Perl_warner(aTHX_ packWARN(WARN_UTF8),
				"Wide character in print");
		}
	    }
	}
	/* 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() --
	 * but only until the system hard limit/the filesystem limit,
	 * at which we would get EPERM.  Note that when using buffered
	 * io the write failure can be delayed until the flush/close. --jhi */
	if (len && (PerlIO_write(fp,tmps,len) == 0))
	    happy = FALSE;
	Safefree(tmpbuf);
	return happy ? !PerlIO_error(fp) : FALSE;
    }
}

I32
Perl_my_stat(pTHX)
{
    dSP;
    IO *io;
    GV* gv;

    if (PL_op->op_flags & OPf_REF) {
	EXTEND(SP,1);
	gv = cGVOP_gv;
      do_fstat:
        if (gv == PL_defgv)
            return PL_laststatval;
	io = GvIO(gv);
        do_fstat_have_io:
        PL_laststype = OP_STAT;
        PL_statgv = gv;
        sv_setpvn(PL_statname, "", 0);
        if(io) {
	    if (IoIFP(io)) {
	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
            } else if (IoDIRP(io)) {
                return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
            } else {
                if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
                    report_evil_fh(gv, io, PL_op->op_type);
                return (PL_laststatval = -1);
            }
	} else {
            if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
                report_evil_fh(gv, io, PL_op->op_type);
            return (PL_laststatval = -1);
        }
    }
    else {
	SV* const sv = POPs;
	const char *s;
	STRLEN len;
	PUTBACK;
	if (isGV_with_GP(sv)) {
	    gv = (GV*)sv;
	    goto do_fstat;
	}
	else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
	    gv = (GV*)SvRV(sv);
	    goto do_fstat;
	}
        else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
            io = (IO*)SvRV(sv);
	    gv = NULL;
            goto do_fstat_have_io;
        }

	s = SvPV_const(sv, len);
	PL_statgv = NULL;
	sv_setpvn(PL_statname, s, len);
	s = SvPVX_const(PL_statname);		/* s now NUL-terminated */
	PL_laststype = OP_STAT;
	PL_laststatval = PerlLIO_stat(s, &PL_statcache);
	if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
	    Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
	return PL_laststatval;
    }
    /* Should we warn/croak here? Or do something smart/useful? */
    return (PL_laststatval = -1);
}


I32
Perl_my_lstat(pTHX)
{
    static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
    dSP;
    SV *sv;
    if (PL_op->op_flags & OPf_REF) {
	EXTEND(SP,1);
	if (cGVOP_gv == PL_defgv) {
	    if (PL_laststype != OP_LSTAT)
		Perl_croak(aTHX_ no_prev_lstat);
	    return PL_laststatval;
	}
	if (ckWARN(WARN_IO)) {
	    Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
		    GvENAME(cGVOP_gv));
	    return (PL_laststatval = -1);
	}
    }

    PL_laststype = OP_LSTAT;
    PL_statgv = NULL;
    sv = POPs;
    PUTBACK;
    if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) {
	Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
		GvENAME((GV*) SvRV(sv)));
	return (PL_laststatval = -1);
    }
    /* XXX Do really need to be calling SvPV() all these times? */
    sv_setpv(PL_statname,SvPV_nolen_const(sv));
    PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(sv),&PL_statcache);
    if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(sv), '\n'))
	Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
    return PL_laststatval;
}

static void
S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
{
    const int e = errno;
    if (ckWARN(WARN_EXEC))
	Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
		    cmd, Strerror(e));
    if (do_report) {
	PerlLIO_write(fd, (void*)&e, sizeof(int));
	PerlLIO_close(fd);
    }
}

bool
Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
	       int fd, int do_report)
{
#if defined(MACOS_TRADITIONAL) || defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
    Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
#else
    if (sp > mark) {
	char **a;
	const char *tmps = NULL;
	Newx(PL_Argv, sp - mark + 1, char*);
	a = PL_Argv;

	while (++mark <= sp) {
	    if (*mark)
		*a++ = (char*)SvPV_nolen_const(*mark);
	    else
		*a++ = "";
	}
	*a = NULL;
	if (really)
	    tmps = SvPV_nolen_const(really);
	if ((!really && *PL_Argv[0] != '/') ||
	    (really && *tmps != '/'))		/* will execvp use PATH? */
	    TAINT_ENV();		/* testing IFS here is overkill, probably */
	PERL_FPU_PRE_EXEC
	if (really && *tmps)
	    PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
	else
	    PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
	PERL_FPU_POST_EXEC
 	S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
    }
    do_execfree();
#endif
    return FALSE;
}

void
Perl_do_execfree(pTHX)
{
    Safefree(PL_Argv);
    PL_Argv = NULL;
    Safefree(PL_Cmd);
    PL_Cmd = NULL;
}

#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
bool
Perl_do_exec3(pTHX_ char *incmd, int fd, int do_report)
{
    register char **a;
    register char *s;
    char *buf;
    char *cmd;

    /* Make a copy so we can change it */
    const Size_t cmdlen = strlen(incmd) + 1;
    Newx(buf, cmdlen, char);
    cmd = buf;
    memcpy(cmd, incmd, cmdlen);

    while (*cmd && isSPACE(*cmd))
	cmd++;

    /* save an extra exec if possible */

#ifdef CSH
    {
        char flags[PERL_FLAGS_MAX];
	if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
	    strnEQ(cmd+PL_cshlen," -c",3)) {
          my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
	  s = cmd+PL_cshlen+3;
	  if (*s == 'f') {
	      s++;
              my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
	  }
	  if (*s == ' ')
	      s++;
	  if (*s++ == '\'') {
	      char * const ncmd = s;

	      while (*s)
		  s++;
	      if (s[-1] == '\n')
		  *--s = '\0';
	      if (s[-1] == '\'') {
		  *--s = '\0';
		  PERL_FPU_PRE_EXEC
		  PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
		  PERL_FPU_POST_EXEC
		  *s = '\'';
 		  S_exec_failed(aTHX_ PL_cshname, fd, do_report);
		  Safefree(buf);
		  return FALSE;
	      }
	  }
	}
    }
#endif /* CSH */

    /* see if there are shell metacharacters in it */

    if (*cmd == '.' && isSPACE(cmd[1]))
	goto doshell;

    if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
	goto doshell;

    s = cmd;
    while (isALNUM(*s))
	s++;	/* catch VAR=val gizmo */
    if (*s == '=')
	goto doshell;

    for (s = cmd; *s; s++) {
	if (*s != ' ' && !isALPHA(*s) &&
	    strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
	    if (*s == '\n' && !s[1]) {
		*s = '\0';
		break;
	    }
	    /* handle the 2>&1 construct at the end */
	    if (*s == '>' && s[1] == '&' && s[2] == '1'
		&& s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
		&& (!s[3] || isSPACE(s[3])))
	    {
                const char *t = s + 3;

		while (*t && isSPACE(*t))
		    ++t;
		if (!*t && (PerlLIO_dup2(1,2) != -1)) {
		    s[-2] = '\0';
		    break;
		}
	    }
	  doshell:
	    PERL_FPU_PRE_EXEC
	    PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
	    PERL_FPU_POST_EXEC
 	    S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
	    Safefree(buf);
	    return FALSE;
	}
    }

    Newx(PL_Argv, (s - cmd) / 2 + 2, char*);
    PL_Cmd = savepvn(cmd, s-cmd);
    a = PL_Argv;
    for (s = PL_Cmd; *s;) {
	while (isSPACE(*s))
	    s++;
	if (*s)
	    *(a++) = s;
	while (*s && !isSPACE(*s))
	    s++;
	if (*s)
	    *s++ = '\0';
    }
    *a = NULL;
    if (PL_Argv[0]) {
	PERL_FPU_PRE_EXEC
	PerlProc_execvp(PL_Argv[0],PL_Argv);
	PERL_FPU_POST_EXEC
	if (errno == ENOEXEC) {		/* for system V NIH syndrome */
	    do_execfree();
	    goto doshell;
	}
 	S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
    }
    do_execfree();
    Safefree(buf);
    return FALSE;
}

#endif /* OS2 || WIN32 */

I32
Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
{
    register I32 val;
    register I32 tot = 0;
    const char *const what = PL_op_name[type];
    const char *s;
    SV ** const oldmark = mark;

    /* Doing this ahead of the switch statement preserves the old behaviour,
       where attempting to use kill as a taint test test would fail on
       platforms where kill was not defined.  */
#ifndef HAS_KILL
    if (type == OP_KILL)
	Perl_die(aTHX_ PL_no_func, what);
#endif
#ifndef HAS_CHOWN
    if (type == OP_CHOWN)
	Perl_die(aTHX_ PL_no_func, what);
#endif


#define APPLY_TAINT_PROPER() \
    STMT_START {							\
	if (PL_tainted) { TAINT_PROPER(what); }				\
    } STMT_END

    /* This is a first heuristic; it doesn't catch tainting magic. */
    if (PL_tainting) {
	while (++mark <= sp) {
	    if (SvTAINTED(*mark)) {
		TAINT;
		break;
	    }
	}
	mark = oldmark;
    }
    switch (type) {
    case OP_CHMOD:
	APPLY_TAINT_PROPER();
	if (++mark <= sp) {
	    val = SvIV(*mark);
	    APPLY_TAINT_PROPER();
	    tot = sp - mark;
	    while (++mark <= sp) {
                GV* gv;
                if (isGV_with_GP(*mark)) {
                    gv = (GV*)*mark;
		do_fchmod:
		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FCHMOD
			APPLY_TAINT_PROPER();
			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
			    tot--;
#else
			Perl_die(aTHX_ PL_no_func, "fchmod");
#endif
		    }
		    else {
			tot--;
		    }
		}
		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
		    gv = (GV*)SvRV(*mark);
		    goto do_fchmod;
		}
		else {
		    const char *name = SvPV_nolen_const(*mark);
		    APPLY_TAINT_PROPER();
		    if (PerlLIO_chmod(name, val))
			tot--;
		}
	    }
	}
	break;
#ifdef HAS_CHOWN
    case OP_CHOWN:
	APPLY_TAINT_PROPER();
	if (sp - mark > 2) {
            register I32 val2;
	    val = SvIVx(*++mark);
	    val2 = SvIVx(*++mark);
	    APPLY_TAINT_PROPER();
	    tot = sp - mark;
	    while (++mark <= sp) {
                GV* gv;
                if (isGV_with_GP(*mark)) {
                    gv = (GV*)*mark;
		do_fchown:
		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FCHOWN
			APPLY_TAINT_PROPER();
			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
			    tot--;
#else
			Perl_die(aTHX_ PL_no_func, "fchown");
#endif
		    }
		    else {
			tot--;
		    }
		}
		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
		    gv = (GV*)SvRV(*mark);
		    goto do_fchown;
		}
		else {
		    const char *name = SvPV_nolen_const(*mark);
		    APPLY_TAINT_PROPER();
		    if (PerlLIO_chown(name, val, val2))
			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:
	APPLY_TAINT_PROPER();
	if (mark == sp)
	    break;
	s = SvPVx_nolen_const(*++mark);
	if (isALPHA(*s)) {
	    if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
		s += 3;
	    if ((val = whichsig((char *)s)) < 0)
		Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
	}
	else
	    val = SvIV(*mark);
	APPLY_TAINT_PROPER();
	tot = sp - mark;
#ifdef VMS
	/* kill() doesn't do process groups (job trees?) under VMS */
	if (val < 0) val = -val;
	if (val == SIGKILL) {
#	    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()
	     */
	    while (++mark <= sp) {
		I32 proc = SvIV(*mark);
		register unsigned long int __vmssts;
		APPLY_TAINT_PROPER();
		if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
		    tot--;
		    switch (__vmssts) {
			case SS$_NONEXPR:
			case SS$_NOSUCHNODE:
			    SETERRNO(ESRCH,__vmssts);
			    break;
			case SS$_NOPRIV:
			    SETERRNO(EPERM,__vmssts);
			    break;
			default:
			    SETERRNO(EVMSERR,__vmssts);
		    }
		}
	    }
	    break;
	}
#endif
	if (val < 0) {
	    val = -val;
	    while (++mark <= sp) {
		const I32 proc = SvIV(*mark);
		APPLY_TAINT_PROPER();
#ifdef HAS_KILLPG
		if (PerlProc_killpg(proc,val))	/* BSD */
#else
		if (PerlProc_kill(-proc,val))	/* SYSV */
#endif
		    tot--;
	    }
	}
	else {
	    while (++mark <= sp) {
		const I32 proc = SvIV(*mark);
		APPLY_TAINT_PROPER();
		if (PerlProc_kill(proc, val))
		    tot--;
	    }
	}
	break;
#endif
    case OP_UNLINK:
	APPLY_TAINT_PROPER();
	tot = sp - mark;
	while (++mark <= sp) {
	    s = SvPV_nolen_const(*mark);
	    APPLY_TAINT_PROPER();
	    if (PL_euid || PL_unsafe) {
		if (UNLINK((char *)s))
		    tot--;
	    }
	    else {	/* don't let root wipe out directories without -U */
		if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
		    tot--;
		else {
		    if (UNLINK((char*)s))
			tot--;
		}
	    }
	}
	break;
#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
    case OP_UTIME:
	APPLY_TAINT_PROPER();
	if (sp - mark > 2) {
#if defined(HAS_FUTIMES)
	    struct timeval utbuf[2];
	    void *utbufp = utbuf;
#elif 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* const accessed = *++mark;
	   SV* const modified = *++mark;

           /* 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;
           else {
                Zero(&utbuf, sizeof utbuf, char);
#ifdef HAS_FUTIMES
		utbuf[0].tv_sec = (long)SvIV(accessed);  /* time accessed */
		utbuf[0].tv_usec = 0;
		utbuf[1].tv_sec = (long)SvIV(modified);  /* time modified */
		utbuf[1].tv_usec = 0;
#elif defined(BIG_TIME)
                utbuf.actime = (Time_t)SvNV(accessed);  /* time accessed */
                utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
#else
                utbuf.actime = (Time_t)SvIV(accessed);  /* time accessed */
                utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
#endif
            }
	    APPLY_TAINT_PROPER();
	    tot = sp - mark;
	    while (++mark <= sp) {
                GV* gv;
                if (isGV_with_GP(*mark)) {
                    gv = (GV*)*mark;
		do_futimes:
		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FUTIMES
			APPLY_TAINT_PROPER();
			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
                            (struct timeval *) utbufp))
			    tot--;
#else
			Perl_die(aTHX_ PL_no_func, "futimes");
#endif
		    }
		    else {
			tot--;
		    }
		}
		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
		    gv = (GV*)SvRV(*mark);
		    goto do_futimes;
		}
		else {
		    const char * const name = SvPV_nolen_const(*mark);
		    APPLY_TAINT_PROPER();
#ifdef HAS_FUTIMES
		    if (utimes(name, (struct timeval *)utbufp))
#else
		    /* For the benefit of paranoid hysterical raisins, I'd
		       prefer to keep the paramters of all existing perl
		       functions the same, rather than adding the const.
		       Hence the need to cast away const.  */
		    if (PerlLIO_utime((char *)name, utbufp))
#endif
			tot--;
		}

	    }
	}
	else
	    tot = 0;
	break;
#endif
    }
    return tot;

#undef APPLY_TAINT_PROPER
}

/* Do the permissions allow some operation?  Assumes statcache already set. */
#ifndef VMS /* VMS' cando is in vms.c */
bool
Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
/* 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
      */
     return (mode & statbufp->st_mode) ? TRUE : FALSE;

#else /* ! DOSISH */
    if ((effective ? PL_euid : PL_uid) == 0) {	/* root is special */
	if (mode == S_IXUSR) {
	    if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
		return TRUE;
	}
	else
	    return TRUE;		/* root reads and writes anything */
	return FALSE;
    }
    if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
	if (statbufp->st_mode & mode)
	    return TRUE;	/* ok as "user" */
    }
    else if (ingroup(statbufp->st_gid,effective)) {
	if (statbufp->st_mode & mode >> 3)
	    return TRUE;	/* ok as "group" */
    }
    else if (statbufp->st_mode & mode >> 6)
	return TRUE;	/* ok as "other" */
    return FALSE;
#endif /* ! DOSISH */
}
#endif /* ! VMS */

bool
Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
{
#ifdef MACOS_TRADITIONAL
    /* This is simply not correct for AppleShare, but fix it yerself. */
    return TRUE;
#else
    if (testgid == (effective ? PL_egid : PL_gid))
	return TRUE;
#ifdef HAS_GETGROUPS
    {
	Groups_t *gary = NULL;
	I32 anum;
        bool rc = FALSE;

	anum = getgroups(0, gary);
        Newx(gary, anum, Groups_t);
        anum = getgroups(anum, gary);
	while (--anum >= 0)
	    if (gary[anum] == testgid) {
                rc = TRUE;
                break;
            }

        Safefree(gary);
        return rc;
    }
#else
    return FALSE;
#endif
#endif
}

#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)

I32
Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
{
    const key_t key = (key_t)SvNVx(*++mark);
    const I32 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
    const I32 flags = SvIVx(*++mark);

    PERL_UNUSED_ARG(sp);

    SETERRNO(0,0);
    switch (optype)
    {
#ifdef HAS_MSG
    case OP_MSGGET:
	return msgget(key, flags);
#endif
#ifdef HAS_SEM
    case OP_SEMGET:
	return semget(key, n, flags);
#endif
#ifdef HAS_SHM
    case OP_SHMGET:
	return shmget(key, n, flags);
#endif
#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
    default:
	Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
#endif
    }
    return -1;			/* should never happen */
}

I32
Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
{
    char *a;
    I32 ret = -1;
    const I32 id  = SvIVx(*++mark);
#ifdef Semctl
    const I32 n   = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
#endif
    const I32 cmd = SvIVx(*++mark);
    SV * const astr = *++mark;
    STRLEN infosize = 0;
    I32 getinfo = (cmd == IPC_STAT);

    PERL_UNUSED_ARG(sp);

    switch (optype)
    {
#ifdef HAS_MSG
    case OP_MSGCTL:
	if (cmd == IPC_STAT || cmd == IPC_SET)
	    infosize = sizeof(struct msqid_ds);
	break;
#endif
#ifdef HAS_SHM
    case OP_SHMCTL:
	if (cmd == IPC_STAT || cmd == IPC_SET)
	    infosize = sizeof(struct shmid_ds);
	break;
#endif
#ifdef HAS_SEM
    case OP_SEMCTL:
#ifdef Semctl
	if (cmd == IPC_STAT || cmd == IPC_SET)
	    infosize = sizeof(struct semid_ds);
	else if (cmd == GETALL || cmd == SETALL)
	{
	    struct semid_ds semds;
	    union semun semun;
#ifdef EXTRA_F_IN_SEMUN_BUF
            semun.buff = &semds;
#else
            semun.buf = &semds;
#endif
	    getinfo = (cmd == GETALL);
	    if (Semctl(id, 0, IPC_STAT, semun) == -1)
		return -1;
	    infosize = semds.sem_nsems * sizeof(short);
		/* "short" is technically wrong but much more portable
		   than guessing about u_?short(_t)? */
	}
#else
	Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
#endif
	break;
#endif
#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
    default:
	Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
#endif
    }

    if (infosize)
    {
	if (getinfo)
	{
	    SvPV_force_nolen(astr);
	    a = SvGROW(astr, infosize+1);
	}
	else
	{
	    STRLEN len;
	    a = SvPV(astr, len);
	    if (len != infosize)
		Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
		      PL_op_desc[optype],
		      (unsigned long)len,
		      (long)infosize);
	}
    }
    else
    {
	const IV i = SvIV(astr);
	a = INT2PTR(char *,i);		/* ouch */
    }
    SETERRNO(0,0);
    switch (optype)
    {
#ifdef HAS_MSG
    case OP_MSGCTL:
	ret = msgctl(id, cmd, (struct msqid_ds *)a);
	break;
#endif
#ifdef HAS_SEM
    case OP_SEMCTL: {
#ifdef Semctl
            union semun unsemds;

#ifdef EXTRA_F_IN_SEMUN_BUF
            unsemds.buff = (struct semid_ds *)a;
#else
            unsemds.buf = (struct semid_ds *)a;
#endif
	    ret = Semctl(id, n, cmd, unsemds);
#else
	    Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
#endif
        }
	break;
#endif
#ifdef HAS_SHM
    case OP_SHMCTL:
	ret = shmctl(id, cmd, (struct shmid_ds *)a);
	break;
#endif
    }
    if (getinfo && ret >= 0) {
	SvCUR_set(astr, infosize);
	*SvEND(astr) = '\0';
	SvSETMAGIC(astr);
    }
    return ret;
}

I32
Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
    STRLEN len;
    const I32 id = SvIVx(*++mark);
    SV * const mstr = *++mark;
    const I32 flags = SvIVx(*++mark);
    const char * const mbuf = SvPV_const(mstr, len);
    const I32 msize = len - sizeof(long);

    PERL_UNUSED_ARG(sp);

    if (msize < 0)
	Perl_croak(aTHX_ "Arg too short for msgsnd");
    SETERRNO(0,0);
    return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
#else
    PERL_UNUSED_ARG(sp);
    PERL_UNUSED_ARG(mark);
    Perl_croak(aTHX_ "msgsnd not implemented");
#endif
}

I32
Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
    char *mbuf;
    long mtype;
    I32 msize, flags, ret;
    const I32 id = SvIVx(*++mark);
    SV * const mstr = *++mark;
    PERL_UNUSED_ARG(sp);

    /* suppress warning when reading into undef var --jhi */
    if (! SvOK(mstr))
	sv_setpvn(mstr, "", 0);
    msize = SvIVx(*++mark);
    mtype = (long)SvIVx(*++mark);
    flags = SvIVx(*++mark);
    SvPV_force_nolen(mstr);
    mbuf = SvGROW(mstr, sizeof(long)+msize+1);

    SETERRNO(0,0);
    ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
    if (ret >= 0) {
	SvCUR_set(mstr, sizeof(long)+ret);
	*SvEND(mstr) = '\0';
#ifndef INCOMPLETE_TAINTS
	/* who knows who has been playing with this message? */
	SvTAINTED_on(mstr);
#endif
    }
    return ret;
#else
    PERL_UNUSED_ARG(sp);
    PERL_UNUSED_ARG(mark);
    Perl_croak(aTHX_ "msgrcv not implemented");
#endif
}

I32
Perl_do_semop(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_SEM
    STRLEN opsize;
    const I32 id = SvIVx(*++mark);
    SV * const opstr = *++mark;
    const char * const opbuf = SvPV_const(opstr, opsize);
    PERL_UNUSED_ARG(sp);

    if (opsize < 3 * SHORTSIZE
	|| (opsize % (3 * SHORTSIZE))) {
	SETERRNO(EINVAL,LIB_INVARG);
	return -1;
    }
    SETERRNO(0,0);
    /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
    {
        const int nsops  = opsize / (3 * sizeof (short));
        int i      = nsops;
        short * const ops = (short *) opbuf;
        short *o   = ops;
        struct sembuf *temps, *t;
        I32 result;

        Newx (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
}

I32
Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
{
#ifdef HAS_SHM
    char *shm;
    struct shmid_ds shmds;
    const I32 id = SvIVx(*++mark);
    SV * const mstr = *++mark;
    const I32 mpos = SvIVx(*++mark);
    const I32 msize = SvIVx(*++mark);
    PERL_UNUSED_ARG(sp);

    SETERRNO(0,0);
    if (shmctl(id, IPC_STAT, &shmds) == -1)
	return -1;
    if (mpos < 0 || msize < 0
	|| (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
	SETERRNO(EFAULT,SS_ACCVIO);		/* can't do as caller requested */
	return -1;
    }
    shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
    if (shm == (char *)-1)	/* I hate System V IPC, I really do */
	return -1;
    if (optype == OP_SHMREAD) {
	char *mbuf;
	/* suppress warning when reading into undef var (tchrist 3/Mar/00) */
	if (! SvOK(mstr))
	    sv_setpvn(mstr, "", 0);
	SvPV_force_nolen(mstr);
	mbuf = SvGROW(mstr, (STRLEN)msize+1);

	Copy(shm + mpos, mbuf, msize, char);
	SvCUR_set(mstr, msize);
	*SvEND(mstr) = '\0';
	SvSETMAGIC(mstr);
#ifndef INCOMPLETE_TAINTS
	/* who knows who has been playing with this shared memory? */
	SvTAINTED_on(mstr);
#endif
    }
    else {
	STRLEN len;

	const char *mbuf = SvPV_const(mstr, len);
	const I32 n = ((I32)len > msize) ? msize : (I32)len;
	Copy(mbuf, shm + mpos, n, char);
	if (n < msize)
	    memzero(shm + mpos + n, msize - n);
    }
    return shmdt(shm);
#else
    Perl_croak(aTHX_ "shm I/O not implemented");
#endif
}

#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 process.
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 * const tmpcmd = newSV(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 <descrip.h>
#include <lib$routines.h>
#include <nam.h>
#include <rmsdef.h>
	char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
	char vmsspec[NAM$C_MAXRSS+1];
	char * const rstr = rslt + sizeof(unsigned short int);
	char *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;

	if (!SvOK(tmpglob)) {
	    SETERRNO(ENOENT,RMS$_FNF);
	    return NULL;
	}

	/* 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) {
	    int found = 0;
	    Stat_t st;
	    if (!PerlLIO_stat(SvPVX_const(tmpglob),&st) && S_ISDIR(st.st_mode))
		ok = ((wilddsc.dsc$a_pointer = tovmspath((char *)SvPVX_const(tmpglob),vmsspec)) != NULL);
	    else ok = ((wilddsc.dsc$a_pointer = tovmsspec((char *)SvPVX_const(tmpglob),vmsspec)) != NULL);
	    if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
	    for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
		if (*cp == '?') *cp = '%';  /* VMS style single-char wildcard */
	    while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
					       &dfltdsc,NULL,NULL,NULL))&1)) {

		found++;
		/* with varying string, 1st word of buffer contains result length */
		end = rstr + *((unsigned short int*)rslt);
		if (!hasver) while (*end != ';' && end > rstr) 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 (!found) {
	        /* Be POSIXish: return the input pattern when no matches */
	        strcpy(rstr,SvPVX(tmpglob));
	        strcat(rstr,"\n");
	        ok = (PerlIO_puts(tmpfp,rstr) != EOF);
	    }

	    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, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
		  FALSE, O_RDONLY, 0, NULL);
    fp = IoIFP(io);
#endif /* !VMS */
    LEAVE;
    return fp;
}

/*
 * Local variables:
 * c-indentation-style: bsd
 * c-basic-offset: 4
 * indent-tabs-mode: t
 * End:
 *
 * ex: set ts=8 sts=4 sw=4 noet:
 */
