Add newSVuv().

[perl5.git] / pp_sys.c

/*    pp_sys.c
 *
 *    Copyright (c) 1991-2000, 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.
 *
 */

/*
 * But only a short way ahead its floor and the walls on either side were
 * cloven by a great fissure, out of which the red glare came, now leaping
 * up, now dying down into darkness; and all the while far below there was
 * a rumour and a trouble as of great engines throbbing and labouring.
 */

#include "EXTERN.h"
#define PERL_IN_PP_SYS_C
#include "perl.h"

#ifdef I_SHADOW
/* Shadow password support for solaris - pdo@cs.umd.edu
 * Not just Solaris: at least HP-UX, IRIX, Linux.
 * the API is from SysV. --jhi */
#ifdef __hpux__
/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
 * and another MAXINT from "perl.h" <- <sys/param.h>. */ 
#undef MAXINT
#endif
#include <shadow.h>
#endif

/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
#ifdef I_UNISTD
# include <unistd.h>
#endif

#ifdef HAS_SYSCALL   
#ifdef __cplusplus              
extern "C" int syscall(unsigned long,...);
#endif
#endif

#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif

#ifdef I_SYS_RESOURCE
# include <sys/resource.h>
#endif

#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
# include <sys/socket.h>
# if defined(USE_SOCKS) && defined(I_SOCKS)
#   include <socks.h>
# endif 
# ifdef I_NETDB
#  include <netdb.h>
# endif
# ifndef ENOTSOCK
#  ifdef I_NET_ERRNO
#   include <net/errno.h>
#  endif
# endif
#endif

#ifdef HAS_SELECT
#ifdef I_SYS_SELECT
#include <sys/select.h>
#endif
#endif

/* XXX Configure test needed.
   h_errno might not be a simple 'int', especially for multi-threaded
   applications, see "extern int errno in perl.h".  Creating such
   a test requires taking into account the differences between
   compiling multithreaded and singlethreaded ($ccflags et al).
   HOST_NOT_FOUND is typically defined in <netdb.h>.
*/
#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
extern int h_errno;
#endif

#ifdef HAS_PASSWD
# ifdef I_PWD
#  include <pwd.h>
# else
    struct passwd *getpwnam (char *);
    struct passwd *getpwuid (Uid_t);
# endif
# ifdef HAS_GETPWENT
  struct passwd *getpwent (void);
# endif
#endif

#ifdef HAS_GROUP
# ifdef I_GRP
#  include <grp.h>
# else
    struct group *getgrnam (char *);
    struct group *getgrgid (Gid_t);
# endif
# ifdef HAS_GETGRENT
    struct group *getgrent (void);
# endif
#endif

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

/* Put this after #includes because fork and vfork prototypes may conflict. */
#ifndef HAS_VFORK
#   define vfork fork
#endif

#ifdef HAS_CHSIZE
# ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
#   undef my_chsize
# endif
# define my_chsize PerlLIO_chsize
#endif

#ifdef HAS_FLOCK
#  define FLOCK flock
#else /* no flock() */

   /* fcntl.h might not have been included, even if it exists, because
      the current Configure only sets I_FCNTL if it's needed to pick up
      the *_OK constants.  Make sure it has been included before testing
      the fcntl() locking constants. */
#  if defined(HAS_FCNTL) && !defined(I_FCNTL)
#    include <fcntl.h>
#  endif

#  if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
#    define FLOCK fcntl_emulate_flock
#    define FCNTL_EMULATE_FLOCK
#  else /* no flock() or fcntl(F_SETLK,...) */
#    ifdef HAS_LOCKF
#      define FLOCK lockf_emulate_flock
#      define LOCKF_EMULATE_FLOCK
#    endif /* lockf */
#  endif /* no flock() or fcntl(F_SETLK,...) */

#  ifdef FLOCK
     static int FLOCK (int, int);

    /*
     * These are the flock() constants.  Since this sytems doesn't have
     * flock(), the values of the constants are probably not available.
     */
#    ifndef LOCK_SH
#      define LOCK_SH 1
#    endif
#    ifndef LOCK_EX
#      define LOCK_EX 2
#    endif
#    ifndef LOCK_NB
#      define LOCK_NB 4
#    endif
#    ifndef LOCK_UN
#      define LOCK_UN 8
#    endif
#  endif /* emulating flock() */

#endif /* no flock() */

#define ZBTLEN 10
static char zero_but_true[ZBTLEN + 1] = "0 but true";

#if defined(I_SYS_ACCESS) && !defined(R_OK)
#  include <sys/access.h>
#endif

#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
#  define FD_CLOEXEC 1		/* NeXT needs this */
#endif

#undef PERL_EFF_ACCESS_R_OK	/* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK

/* F_OK unused: if stat() cannot find it... */

#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
    /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
#   define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
#   define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
#   define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
#endif

#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
#   if defined(I_SYS_SECURITY)
#       include <sys/security.h>
#   endif
    /* XXX Configure test needed for eaccess */
#   ifdef ACC_SELF
        /* HP SecureWare */
#       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
#       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
#       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
#   else
        /* SCO */
#       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
#       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
#       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
#   endif
#endif

#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
    /* AIX */
#   define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
#   define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
#   define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
#endif

#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS)	\
    && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)		\
	|| defined(HAS_SETREGID) || defined(HAS_SETRESGID))
/* The Hard Way. */
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
    Uid_t ruid = getuid();
    Uid_t euid = geteuid();
    Gid_t rgid = getgid();
    Gid_t egid = getegid();
    int res;

    LOCK_CRED_MUTEX;
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
    Perl_croak(aTHX_ "switching effective uid is not implemented");
#else
#ifdef HAS_SETREUID
    if (setreuid(euid, ruid))
#else
#ifdef HAS_SETRESUID
    if (setresuid(euid, ruid, (Uid_t)-1))
#endif
#endif
	Perl_croak(aTHX_ "entering effective uid failed");
#endif

#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
    Perl_croak(aTHX_ "switching effective gid is not implemented");
#else
#ifdef HAS_SETREGID
    if (setregid(egid, rgid))
#else
#ifdef HAS_SETRESGID
    if (setresgid(egid, rgid, (Gid_t)-1))
#endif
#endif
	Perl_croak(aTHX_ "entering effective gid failed");
#endif

    res = access(path, mode);

#ifdef HAS_SETREUID
    if (setreuid(ruid, euid))
#else
#ifdef HAS_SETRESUID
    if (setresuid(ruid, euid, (Uid_t)-1))
#endif
#endif
	Perl_croak(aTHX_ "leaving effective uid failed");

#ifdef HAS_SETREGID
    if (setregid(rgid, egid))
#else
#ifdef HAS_SETRESGID
    if (setresgid(rgid, egid, (Gid_t)-1))
#endif
#endif
	Perl_croak(aTHX_ "leaving effective gid failed");
    UNLOCK_CRED_MUTEX;

    return res;
}
#   define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
#   define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
#   define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
#endif

#if !defined(PERL_EFF_ACCESS_R_OK)
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
    Perl_croak(aTHX_ "switching effective uid is not implemented");
    /*NOTREACHED*/
    return -1;
}
#endif

PP(pp_backtick)
{
    djSP; dTARGET;
    PerlIO *fp;
    STRLEN n_a;
    char *tmps = POPpx;
    I32 gimme = GIMME_V;
    char *mode = "r";

    TAINT_PROPER("``");
    if (PL_op->op_private & OPpOPEN_IN_RAW)
	mode = "rb";
    else if (PL_op->op_private & OPpOPEN_IN_CRLF)
	mode = "rt";
    fp = PerlProc_popen(tmps, mode);
    if (fp) {
	if (gimme == G_VOID) {
	    char tmpbuf[256];
	    while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
		/*SUPPRESS 530*/
		;
	}
	else if (gimme == G_SCALAR) {
	    sv_setpv(TARG, "");	/* note that this preserves previous buffer */
	    while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
		/*SUPPRESS 530*/
		;
	    XPUSHs(TARG);
	    SvTAINTED_on(TARG);
	}
	else {
	    SV *sv;

	    for (;;) {
		sv = NEWSV(56, 79);
		if (sv_gets(sv, fp, 0) == Nullch) {
		    SvREFCNT_dec(sv);
		    break;
		}
		XPUSHs(sv_2mortal(sv));
		if (SvLEN(sv) - SvCUR(sv) > 20) {
		    SvLEN_set(sv, SvCUR(sv)+1);
		    Renew(SvPVX(sv), SvLEN(sv), char);
		}
		SvTAINTED_on(sv);
	    }
	}
	STATUS_NATIVE_SET(PerlProc_pclose(fp));
	TAINT;		/* "I believe that this is not gratuitous!" */
    }
    else {
	STATUS_NATIVE_SET(-1);
	if (gimme == G_SCALAR)
	    RETPUSHUNDEF;
    }

    RETURN;
}

PP(pp_glob)
{
    OP *result;
    tryAMAGICunTARGET(iter, -1);

    /* Note that we only ever get here if File::Glob fails to load
     * without at the same time croaking, for some reason, or if
     * perl was built with PERL_EXTERNAL_GLOB */

    ENTER;

#ifndef VMS
    if (PL_tainting) {
	/*
	 * The external globbing program may use things we can't control,
	 * so for security reasons we must assume the worst.
	 */
	TAINT;
	taint_proper(PL_no_security, "glob");
    }
#endif /* !VMS */

    SAVESPTR(PL_last_in_gv);	/* We don't want this to be permanent. */
    PL_last_in_gv = (GV*)*PL_stack_sp--;

    SAVESPTR(PL_rs);		/* This is not permanent, either. */
    PL_rs = sv_2mortal(newSVpvn("\000", 1));
#ifndef DOSISH
#ifndef CSH
    *SvPVX(PL_rs) = '\n';
#endif	/* !CSH */
#endif	/* !DOSISH */

    result = do_readline();
    LEAVE;
    return result;
}

#if 0		/* XXX never used! */
PP(pp_indread)
{
    STRLEN n_a;
    PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
    return do_readline();
}
#endif

PP(pp_rcatline)
{
    PL_last_in_gv = cGVOP_gv;
    return do_readline();
}

PP(pp_warn)
{
    djSP; dMARK;
    SV *tmpsv;
    char *tmps;
    STRLEN len;
    if (SP - MARK != 1) {
	dTARGET;
	do_join(TARG, &PL_sv_no, MARK, SP);
	tmpsv = TARG;
	SP = MARK + 1;
    }
    else {
	tmpsv = TOPs;
    }
    tmps = SvPV(tmpsv, len);
    if (!tmps || !len) {
  	SV *error = ERRSV;
	(void)SvUPGRADE(error, SVt_PV);
	if (SvPOK(error) && SvCUR(error))
	    sv_catpv(error, "\t...caught");
	tmpsv = error;
	tmps = SvPV(tmpsv, len);
    }
    if (!tmps || !len)
	tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));

    Perl_warn(aTHX_ "%"SVf, tmpsv);
    RETSETYES;
}

PP(pp_die)
{
    djSP; dMARK;
    char *tmps;
    SV *tmpsv;
    STRLEN len;
    bool multiarg = 0;
    if (SP - MARK != 1) {
	dTARGET;
	do_join(TARG, &PL_sv_no, MARK, SP);
	tmpsv = TARG;
	tmps = SvPV(tmpsv, len);
	multiarg = 1;
	SP = MARK + 1;
    }
    else {
	tmpsv = TOPs;
	tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
    }
    if (!tmps || !len) {
  	SV *error = ERRSV;
	(void)SvUPGRADE(error, SVt_PV);
	if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
	    if (!multiarg)
		SvSetSV(error,tmpsv);
	    else if (sv_isobject(error)) {
		HV *stash = SvSTASH(SvRV(error));
		GV *gv = gv_fetchmethod(stash, "PROPAGATE");
		if (gv) {
		    SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
		    SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop)));
		    EXTEND(SP, 3);
		    PUSHMARK(SP);
		    PUSHs(error);
		    PUSHs(file);
 		    PUSHs(line);
		    PUTBACK;
		    call_sv((SV*)GvCV(gv),
			    G_SCALAR|G_EVAL|G_KEEPERR);
		    sv_setsv(error,*PL_stack_sp--);
		}
	    }
	    DIE(aTHX_ Nullch);
	}
	else {
	    if (SvPOK(error) && SvCUR(error))
		sv_catpv(error, "\t...propagated");
	    tmpsv = error;
	    tmps = SvPV(tmpsv, len);
	}
    }
    if (!tmps || !len)
	tmpsv = sv_2mortal(newSVpvn("Died", 4));

    DIE(aTHX_ "%"SVf, tmpsv);
}

/* I/O. */

PP(pp_open)
{
    djSP; dTARGET;
    GV *gv;
    SV *sv;
    SV *name;
    I32 have_name = 0;
    char *tmps;
    STRLEN len;
    MAGIC *mg;

    if (MAXARG > 2) {
	name = POPs;
	have_name = 1;
    }
    if (MAXARG > 1)
	sv = POPs;
    if (!isGV(TOPs))
	DIE(aTHX_ PL_no_usym, "filehandle");
    if (MAXARG <= 1)
	sv = GvSV(TOPs);
    gv = (GV*)POPs;
    if (!isGV(gv))
	DIE(aTHX_ PL_no_usym, "filehandle");
    if (GvIOp(gv))
	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;

    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	XPUSHs(sv);
	if (have_name)
	    XPUSHs(name);
	PUTBACK;
	ENTER;
	call_method("OPEN", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    tmps = SvPV(sv, len);
    if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
	PUSHi( (I32)PL_forkprocess );
    else if (PL_forkprocess == 0)		/* we are a new child */
	PUSHi(0);
    else
	RETPUSHUNDEF;
    RETURN;
}

PP(pp_close)
{
    djSP;
    GV *gv;
    MAGIC *mg;

    if (MAXARG == 0)
	gv = PL_defoutgv;
    else
	gv = (GV*)POPs;

    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	PUTBACK;
	ENTER;
	call_method("CLOSE", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }
    EXTEND(SP, 1);
    PUSHs(boolSV(do_close(gv, TRUE)));
    RETURN;
}

PP(pp_pipe_op)
{
    djSP;
#ifdef HAS_PIPE
    GV *rgv;
    GV *wgv;
    register IO *rstio;
    register IO *wstio;
    int fd[2];

    wgv = (GV*)POPs;
    rgv = (GV*)POPs;

    if (!rgv || !wgv)
	goto badexit;

    if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
	DIE(aTHX_ PL_no_usym, "filehandle");
    rstio = GvIOn(rgv);
    wstio = GvIOn(wgv);

    if (IoIFP(rstio))
	do_close(rgv, FALSE);
    if (IoIFP(wstio))
	do_close(wgv, FALSE);

    if (PerlProc_pipe(fd) < 0)
	goto badexit;

    IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
    IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
    IoIFP(wstio) = IoOFP(wstio);
    IoTYPE(rstio) = '<';
    IoTYPE(wstio) = '>';

    if (!IoIFP(rstio) || !IoOFP(wstio)) {
	if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
	else PerlLIO_close(fd[0]);
	if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
	else PerlLIO_close(fd[1]);
	goto badexit;
    }
#if defined(HAS_FCNTL) && defined(F_SETFD)
    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
#endif
    RETPUSHYES;

badexit:
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_func, "pipe");
#endif
}

PP(pp_fileno)
{
    djSP; dTARGET;
    GV *gv;
    IO *io;
    PerlIO *fp;
    MAGIC  *mg;

    if (MAXARG < 1)
	RETPUSHUNDEF;
    gv = (GV*)POPs;

    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	PUTBACK;
	ENTER;
	call_method("FILENO", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
	RETPUSHUNDEF;
    PUSHi(PerlIO_fileno(fp));
    RETURN;
}

PP(pp_umask)
{
    djSP; dTARGET;
    Mode_t anum;

#ifdef HAS_UMASK
    if (MAXARG < 1) {
	anum = PerlLIO_umask(0);
	(void)PerlLIO_umask(anum);
    }
    else
	anum = PerlLIO_umask(POPi);
    TAINT_PROPER("umask");
    XPUSHi(anum);
#else
    /* Only DIE if trying to restrict permissions on `user' (self).
     * Otherwise it's harmless and more useful to just return undef
     * since 'group' and 'other' concepts probably don't exist here. */
    if (MAXARG >= 1 && (POPi & 0700))
	DIE(aTHX_ "umask not implemented");
    XPUSHs(&PL_sv_undef);
#endif
    RETURN;
}

PP(pp_binmode)
{
    djSP;
    GV *gv;
    IO *io;
    PerlIO *fp;
    MAGIC *mg;
    SV *discp = Nullsv;

    if (MAXARG < 1)
	RETPUSHUNDEF;
    if (MAXARG > 1)
	discp = POPs;

    gv = (GV*)POPs; 

    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	if (discp)
	    XPUSHs(discp);
	PUTBACK;
	ENTER;
	call_method("BINMODE", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    EXTEND(SP, 1);
    if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
	RETPUSHUNDEF;

    if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) 
	RETPUSHYES;
    else
	RETPUSHUNDEF;
}

PP(pp_tie)
{
    djSP;
    dMARK;
    SV *varsv;
    HV* stash;
    GV *gv;
    SV *sv;
    I32 markoff = MARK - PL_stack_base;
    char *methname;
    int how = 'P';
    U32 items;
    STRLEN n_a;

    varsv = *++MARK;
    switch(SvTYPE(varsv)) {
	case SVt_PVHV:
	    methname = "TIEHASH";
	    break;
	case SVt_PVAV:
	    methname = "TIEARRAY";
	    break;
	case SVt_PVGV:
	    methname = "TIEHANDLE";
	    how = 'q';
	    break;
	default:
	    methname = "TIESCALAR";
	    how = 'q';
	    break;
    }
    items = SP - MARK++;
    if (sv_isobject(*MARK)) {
	ENTER;
	PUSHSTACKi(PERLSI_MAGIC);
	PUSHMARK(SP);
	EXTEND(SP,items);
	while (items--)
	    PUSHs(*MARK++);
	PUTBACK;
	call_method(methname, G_SCALAR);
    } 
    else {
	/* Not clear why we don't call call_method here too.
	 * perhaps to get different error message ?
	 */
	stash = gv_stashsv(*MARK, FALSE);
	if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
	    DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
		 methname, SvPV(*MARK,n_a));                   
	}
	ENTER;
	PUSHSTACKi(PERLSI_MAGIC);
	PUSHMARK(SP);
	EXTEND(SP,items);
	while (items--)
	    PUSHs(*MARK++);
	PUTBACK;
	call_sv((SV*)GvCV(gv), G_SCALAR);
    }
    SPAGAIN;

    sv = TOPs;
    POPSTACK;
    if (sv_isobject(sv)) {
	sv_unmagic(varsv, how);
	sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
    }
    LEAVE;
    SP = PL_stack_base + markoff;
    PUSHs(sv);
    RETURN;
}

PP(pp_untie)
{
    djSP;
    SV *sv = POPs;
    char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';

    if (ckWARN(WARN_UNTIE)) {
        MAGIC * mg ;
        if ((mg = SvTIED_mg(sv, how))) {
            if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
		Perl_warner(aTHX_ WARN_UNTIE,
		    "untie attempted while %"UVuf" inner references still exist",
		    (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
        }
    }
 
    sv_unmagic(sv, how);
    RETPUSHYES;
}

PP(pp_tied)
{
    djSP;
    SV *sv = POPs;
    char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
    MAGIC *mg;

    if ((mg = SvTIED_mg(sv, how))) {
	SV *osv = SvTIED_obj(sv, mg);
	if (osv == mg->mg_obj)
	    osv = sv_mortalcopy(osv);
	PUSHs(osv);
	RETURN;
    }
    RETPUSHUNDEF;
}

PP(pp_dbmopen)
{
    djSP;
    HV *hv;
    dPOPPOPssrl;
    HV* stash;
    GV *gv;
    SV *sv;

    hv = (HV*)POPs;

    sv = sv_mortalcopy(&PL_sv_no);
    sv_setpv(sv, "AnyDBM_File");
    stash = gv_stashsv(sv, FALSE);
    if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
	PUTBACK;
	require_pv("AnyDBM_File.pm");
	SPAGAIN;
	if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
	    DIE(aTHX_ "No dbm on this machine");
    }

    ENTER;
    PUSHMARK(SP);

    EXTEND(SP, 5);
    PUSHs(sv);
    PUSHs(left);
    if (SvIV(right))
	PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
    else
	PUSHs(sv_2mortal(newSViv(O_RDWR)));
    PUSHs(right);
    PUTBACK;
    call_sv((SV*)GvCV(gv), G_SCALAR);
    SPAGAIN;

    if (!sv_isobject(TOPs)) {
	SP--;
	PUSHMARK(SP);
	PUSHs(sv);
	PUSHs(left);
	PUSHs(sv_2mortal(newSViv(O_RDONLY)));
	PUSHs(right);
	PUTBACK;
	call_sv((SV*)GvCV(gv), G_SCALAR);
	SPAGAIN;
    }

    if (sv_isobject(TOPs)) {
	sv_unmagic((SV *) hv, 'P');            
	sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
    }
    LEAVE;
    RETURN;
}

PP(pp_dbmclose)
{
    return pp_untie();
}

PP(pp_sselect)
{
    djSP; dTARGET;
#ifdef HAS_SELECT
    register I32 i;
    register I32 j;
    register char *s;
    register SV *sv;
    NV value;
    I32 maxlen = 0;
    I32 nfound;
    struct timeval timebuf;
    struct timeval *tbuf = &timebuf;
    I32 growsize;
    char *fd_sets[4];
    STRLEN n_a;
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
	I32 masksize;
	I32 offset;
	I32 k;

#   if BYTEORDER & 0xf0000
#	define ORDERBYTE (0x88888888 - BYTEORDER)
#   else
#	define ORDERBYTE (0x4444 - BYTEORDER)
#   endif

#endif

    SP -= 4;
    for (i = 1; i <= 3; i++) {
	if (!SvPOK(SP[i]))
	    continue;
	j = SvCUR(SP[i]);
	if (maxlen < j)
	    maxlen = j;
    }

/* little endians can use vecs directly */
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
#  if SELECT_MIN_BITS > 1
    /* If SELECT_MIN_BITS is greater than one we most probably will want
     * to align the sizes with SELECT_MIN_BITS/8 because for example
     * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
     * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
     * on (sets/tests/clears bits) is 32 bits.  */
    growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
#  else
    growsize = sizeof(fd_set);
#  endif
# else
#  ifdef NFDBITS

#    ifndef NBBY
#     define NBBY 8
#    endif

    masksize = NFDBITS / NBBY;
#  else
    masksize = sizeof(long);	/* documented int, everyone seems to use long */
#  endif
    growsize = maxlen + (masksize - (maxlen % masksize));
    Zero(&fd_sets[0], 4, char*);
#endif

    sv = SP[4];
    if (SvOK(sv)) {
	value = SvNV(sv);
	if (value < 0.0)
	    value = 0.0;
	timebuf.tv_sec = (long)value;
	value -= (NV)timebuf.tv_sec;
	timebuf.tv_usec = (long)(value * 1000000.0);
    }
    else
	tbuf = Null(struct timeval*);

    for (i = 1; i <= 3; i++) {
	sv = SP[i];
	if (!SvOK(sv)) {
	    fd_sets[i] = 0;
	    continue;
	}
	else if (!SvPOK(sv))
	    SvPV_force(sv,n_a);	/* force string conversion */
	j = SvLEN(sv);
	if (j < growsize) {
	    Sv_Grow(sv, growsize);
	}
	j = SvCUR(sv);
	s = SvPVX(sv) + j;
	while (++j <= growsize) {
	    *s++ = '\0';
	}

#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
	s = SvPVX(sv);
	New(403, fd_sets[i], growsize, char);
	for (offset = 0; offset < growsize; offset += masksize) {
	    for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
		fd_sets[i][j+offset] = s[(k % masksize) + offset];
	}
#else
	fd_sets[i] = SvPVX(sv);
#endif
    }

    nfound = PerlSock_select(
	maxlen * 8,
	(Select_fd_set_t) fd_sets[1],
	(Select_fd_set_t) fd_sets[2],
	(Select_fd_set_t) fd_sets[3],
	tbuf);
    for (i = 1; i <= 3; i++) {
	if (fd_sets[i]) {
	    sv = SP[i];
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
	    s = SvPVX(sv);
	    for (offset = 0; offset < growsize; offset += masksize) {
		for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
		    s[(k % masksize) + offset] = fd_sets[i][j+offset];
	    }
	    Safefree(fd_sets[i]);
#endif
	    SvSETMAGIC(sv);
	}
    }

    PUSHi(nfound);
    if (GIMME == G_ARRAY && tbuf) {
	value = (NV)(timebuf.tv_sec) +
		(NV)(timebuf.tv_usec) / 1000000.0;
	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
	sv_setnv(sv, value);
    }
    RETURN;
#else
    DIE(aTHX_ "select not implemented");
#endif
}

void
Perl_setdefout(pTHX_ GV *gv)
{
    dTHR;
    if (gv)
	(void)SvREFCNT_inc(gv);
    if (PL_defoutgv)
	SvREFCNT_dec(PL_defoutgv);
    PL_defoutgv = gv;
}

PP(pp_select)
{
    djSP; dTARGET;
    GV *newdefout, *egv;
    HV *hv;

    newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;

    egv = GvEGV(PL_defoutgv);
    if (!egv)
	egv = PL_defoutgv;
    hv = GvSTASH(egv);
    if (! hv)
	XPUSHs(&PL_sv_undef);
    else {
	GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
	if (gvp && *gvp == egv) {
	    gv_efullname3(TARG, PL_defoutgv, Nullch);
	    XPUSHTARG;
	}
	else {
	    XPUSHs(sv_2mortal(newRV((SV*)egv)));
	}
    }

    if (newdefout) {
	if (!GvIO(newdefout))
	    gv_IOadd(newdefout);
	setdefout(newdefout);
    }

    RETURN;
}

PP(pp_getc)
{
    djSP; dTARGET;
    GV *gv;
    MAGIC *mg;

    if (MAXARG == 0)
	gv = PL_stdingv;
    else
	gv = (GV*)POPs;

    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
	I32 gimme = GIMME_V;
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	PUTBACK;
	ENTER;
	call_method("GETC", gimme);
	LEAVE;
	SPAGAIN;
	if (gimme == G_SCALAR)
	    SvSetMagicSV_nosteal(TARG, TOPs);
	RETURN;
    }
    if (!gv || do_eof(gv)) /* make sure we have fp with something */
	RETPUSHUNDEF;
    TAINT;
    sv_setpv(TARG, " ");
    *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
    PUSHTARG;
    RETURN;
}

PP(pp_read)
{
    return pp_sysread();
}

STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
    dTHR;
    register PERL_CONTEXT *cx;
    I32 gimme = GIMME_V;
    AV* padlist = CvPADLIST(cv);
    SV** svp = AvARRAY(padlist);

    ENTER;
    SAVETMPS;

    push_return(retop);
    PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
    PUSHFORMAT(cx);
    SAVEVPTR(PL_curpad);
    PL_curpad = AvARRAY((AV*)svp[1]);

    setdefout(gv);	    /* locally select filehandle so $% et al work */
    return CvSTART(cv);
}

PP(pp_enterwrite)
{
    djSP;
    register GV *gv;
    register IO *io;
    GV *fgv;
    CV *cv;

    if (MAXARG == 0)
	gv = PL_defoutgv;
    else {
	gv = (GV*)POPs;
	if (!gv)
	    gv = PL_defoutgv;
    }
    EXTEND(SP, 1);
    io = GvIO(gv);
    if (!io) {
	RETPUSHNO;
    }
    if (IoFMT_GV(io))
	fgv = IoFMT_GV(io);
    else
	fgv = gv;

    cv = GvFORM(fgv);
    if (!cv) {
	if (fgv) {
	    SV *tmpsv = sv_newmortal();
	    gv_efullname3(tmpsv, fgv, Nullch);
	    DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
	}
	DIE(aTHX_ "Not a format reference");
    }
    if (CvCLONE(cv))
	cv = (CV*)sv_2mortal((SV*)cv_clone(cv));

    IoFLAGS(io) &= ~IOf_DIDTOP;
    return doform(cv,gv,PL_op->op_next);
}

PP(pp_leavewrite)
{
    djSP;
    GV *gv = cxstack[cxstack_ix].blk_sub.gv;
    register IO *io = GvIOp(gv);
    PerlIO *ofp = IoOFP(io);
    PerlIO *fp;
    SV **newsp;
    I32 gimme;
    register PERL_CONTEXT *cx;

    DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
	  (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
    if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
	PL_formtarget != PL_toptarget)
    {
	GV *fgv;
	CV *cv;
	if (!IoTOP_GV(io)) {
	    GV *topgv;
	    SV *topname;

	    if (!IoTOP_NAME(io)) {
		if (!IoFMT_NAME(io))
		    IoFMT_NAME(io) = savepv(GvNAME(gv));
		topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
		topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
		if ((topgv && GvFORM(topgv)) ||
		  !gv_fetchpv("top",FALSE,SVt_PVFM))
		    IoTOP_NAME(io) = savepv(SvPVX(topname));
		else
		    IoTOP_NAME(io) = savepv("top");
	    }
	    topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
	    if (!topgv || !GvFORM(topgv)) {
		IoLINES_LEFT(io) = 100000000;
		goto forget_top;
	    }
	    IoTOP_GV(io) = topgv;
	}
	if (IoFLAGS(io) & IOf_DIDTOP) {	/* Oh dear.  It still doesn't fit. */
	    I32 lines = IoLINES_LEFT(io);
	    char *s = SvPVX(PL_formtarget);
	    if (lines <= 0)		/* Yow, header didn't even fit!!! */
		goto forget_top;
	    while (lines-- > 0) {
		s = strchr(s, '\n');
		if (!s)
		    break;
		s++;
	    }
	    if (s) {
		PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
		sv_chop(PL_formtarget, s);
		FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
	    }
	}
	if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
	    PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
	IoLINES_LEFT(io) = IoPAGE_LEN(io);
	IoPAGE(io)++;
	PL_formtarget = PL_toptarget;
	IoFLAGS(io) |= IOf_DIDTOP;
	fgv = IoTOP_GV(io);
	if (!fgv)
	    DIE(aTHX_ "bad top format reference");
	cv = GvFORM(fgv);
	if (!cv) {
	    SV *tmpsv = sv_newmortal();
	    gv_efullname3(tmpsv, fgv, Nullch);
	    DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
	}
	if (CvCLONE(cv))
	    cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
	return doform(cv,gv,PL_op);
    }

  forget_top:
    POPBLOCK(cx,PL_curpm);
    POPFORMAT(cx);
    LEAVE;

    fp = IoOFP(io);
    if (!fp) {
	if (ckWARN2(WARN_CLOSED,WARN_IO)) {
	    if (IoIFP(io)) {
		SV* sv = sv_newmortal();
		gv_efullname3(sv, gv, Nullch);
		Perl_warner(aTHX_ WARN_IO,
			    "Filehandle %s opened only for input",
			    SvPV_nolen(sv));
	    }
	    else if (ckWARN(WARN_CLOSED))
		report_closed_fh(gv, io, "write", "filehandle");
	}
	PUSHs(&PL_sv_no);
    }
    else {
	if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
	    if (ckWARN(WARN_IO))
		Perl_warner(aTHX_ WARN_IO, "page overflow");
	}
	if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
		PerlIO_error(fp))
	    PUSHs(&PL_sv_no);
	else {
	    FmLINES(PL_formtarget) = 0;
	    SvCUR_set(PL_formtarget, 0);
	    *SvEND(PL_formtarget) = '\0';
	    if (IoFLAGS(io) & IOf_FLUSH)
		(void)PerlIO_flush(fp);
	    PUSHs(&PL_sv_yes);
	}
    }
    PL_formtarget = PL_bodytarget;
    PUTBACK;
    return pop_return();
}

PP(pp_prtf)
{
    djSP; dMARK; dORIGMARK;
    GV *gv;
    IO *io;
    PerlIO *fp;
    SV *sv;
    MAGIC *mg;
    STRLEN n_a;

    if (PL_op->op_flags & OPf_STACKED)
	gv = (GV*)*++MARK;
    else
	gv = PL_defoutgv;

    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
	if (MARK == ORIGMARK) {
	    MEXTEND(SP, 1);
	    ++MARK;
	    Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
	    ++SP;
	}
	PUSHMARK(MARK - 1);
	*MARK = SvTIED_obj((SV*)gv, mg);
	PUTBACK;
	ENTER;
	call_method("PRINTF", G_SCALAR);
	LEAVE;
	SPAGAIN;
	MARK = ORIGMARK + 1;
	*MARK = *SP;
	SP = MARK;
	RETURN;
    }

    sv = NEWSV(0,0);
    if (!(io = GvIO(gv))) {
	if (ckWARN(WARN_UNOPENED)) {
	    gv_efullname3(sv, gv, Nullch);
	    Perl_warner(aTHX_ WARN_UNOPENED,
			"Filehandle %s never opened", SvPV(sv,n_a));
	}
	SETERRNO(EBADF,RMS$_IFI);
	goto just_say_no;
    }
    else if (!(fp = IoOFP(io))) {
	if (ckWARN2(WARN_CLOSED,WARN_IO))  {
	    if (IoIFP(io)) {
		gv_efullname3(sv, gv, Nullch);
		Perl_warner(aTHX_ WARN_IO,
			    "Filehandle %s opened only for input",
			    SvPV(sv,n_a));
	    }
	    else if (ckWARN(WARN_CLOSED))
		report_closed_fh(gv, io, "printf", "filehandle");
	}
	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
	goto just_say_no;
    }
    else {
	do_sprintf(sv, SP - MARK, MARK + 1);
	if (!do_print(sv, fp))
	    goto just_say_no;

	if (IoFLAGS(io) & IOf_FLUSH)
	    if (PerlIO_flush(fp) == EOF)
		goto just_say_no;
    }
    SvREFCNT_dec(sv);
    SP = ORIGMARK;
    PUSHs(&PL_sv_yes);
    RETURN;

  just_say_no:
    SvREFCNT_dec(sv);
    SP = ORIGMARK;
    PUSHs(&PL_sv_undef);
    RETURN;
}

PP(pp_sysopen)
{
    djSP;
    GV *gv;
    SV *sv;
    char *tmps;
    STRLEN len;
    int mode, perm;

    if (MAXARG > 3)
	perm = POPi;
    else
	perm = 0666;
    mode = POPi;
    sv = POPs;
    gv = (GV *)POPs;

    /* Need TIEHANDLE method ? */

    tmps = SvPV(sv, len);
    if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
	IoLINES(GvIOp(gv)) = 0;
	PUSHs(&PL_sv_yes);
    }
    else {
	PUSHs(&PL_sv_undef);
    }
    RETURN;
}

PP(pp_sysread)
{
    djSP; dMARK; dORIGMARK; dTARGET;
    int offset;
    GV *gv;
    IO *io;
    char *buffer;
    SSize_t length;
    Sock_size_t bufsize;
    SV *bufsv;
    STRLEN blen;
    MAGIC *mg;

    gv = (GV*)*++MARK;
    if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
	(mg = SvTIED_mg((SV*)gv, 'q')))
    {
	SV *sv;
	
	PUSHMARK(MARK-1);
	*MARK = SvTIED_obj((SV*)gv, mg);
	ENTER;
	call_method("READ", G_SCALAR);
	LEAVE;
	SPAGAIN;
	sv = POPs;
	SP = ORIGMARK;
	PUSHs(sv);
	RETURN;
    }

    if (!gv)
	goto say_undef;
    bufsv = *++MARK;
    if (! SvOK(bufsv))
	sv_setpvn(bufsv, "", 0);
    buffer = SvPV_force(bufsv, blen);
    length = SvIVx(*++MARK);
    if (length < 0)
	DIE(aTHX_ "Negative length");
    SETERRNO(0,0);
    if (MARK < SP)
	offset = SvIVx(*++MARK);
    else
	offset = 0;
    io = GvIO(gv);
    if (!io || !IoIFP(io))
	goto say_undef;
#ifdef HAS_SOCKET
    if (PL_op->op_type == OP_RECV) {
	char namebuf[MAXPATHLEN];
#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
	bufsize = sizeof (struct sockaddr_in);
#else
	bufsize = sizeof namebuf;
#endif
#ifdef OS2	/* At least Warp3+IAK: only the first byte of bufsize set */
	if (bufsize >= 256)
	    bufsize = 255;
#endif
#ifdef OS2	/* At least Warp3+IAK: only the first byte of bufsize set */
	if (bufsize >= 256)
	    bufsize = 255;
#endif
	buffer = SvGROW(bufsv, length+1);
	/* 'offset' means 'flags' here */
	length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
			  (struct sockaddr *)namebuf, &bufsize);
	if (length < 0)
	    RETPUSHUNDEF;
	SvCUR_set(bufsv, length);
	*SvEND(bufsv) = '\0';
	(void)SvPOK_only(bufsv);
	SvSETMAGIC(bufsv);
	/* This should not be marked tainted if the fp is marked clean */
	if (!(IoFLAGS(io) & IOf_UNTAINT))
	    SvTAINTED_on(bufsv);
	SP = ORIGMARK;
	sv_setpvn(TARG, namebuf, bufsize);
	PUSHs(TARG);
	RETURN;
    }
#else
    if (PL_op->op_type == OP_RECV)
	DIE(aTHX_ PL_no_sock_func, "recv");
#endif
    if (offset < 0) {
	if (-offset > blen)
	    DIE(aTHX_ "Offset outside string");
	offset += blen;
    }
    bufsize = SvCUR(bufsv);
    buffer = SvGROW(bufsv, length+offset+1);
    if (offset > bufsize) { /* Zero any newly allocated space */
    	Zero(buffer+bufsize, offset-bufsize, char);
    }
    if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
	if (IoTYPE(io) == 's') {
	    length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
				   buffer+offset, length, 0);
	}
	else
#endif
	{
	    length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
				  buffer+offset, length);
	}
    }
    else
#ifdef HAS_SOCKET__bad_code_maybe
    if (IoTYPE(io) == 's') {
	char namebuf[MAXPATHLEN];
#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
	bufsize = sizeof (struct sockaddr_in);
#else
	bufsize = sizeof namebuf;
#endif
	length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
			  (struct sockaddr *)namebuf, &bufsize);
    }
    else
#endif
    {
	length = PerlIO_read(IoIFP(io), buffer+offset, length);
	/* fread() returns 0 on both error and EOF */
	if (length == 0 && PerlIO_error(IoIFP(io)))
	    length = -1;
    }
    if (length < 0) {
	if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
	    || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
	{
	    SV* sv = sv_newmortal();
	    gv_efullname3(sv, gv, Nullch);
	    Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
			SvPV_nolen(sv));
	}
	goto say_undef;
    }
    SvCUR_set(bufsv, length+offset);
    *SvEND(bufsv) = '\0';
    (void)SvPOK_only(bufsv);
    SvSETMAGIC(bufsv);
    /* This should not be marked tainted if the fp is marked clean */
    if (!(IoFLAGS(io) & IOf_UNTAINT))
	SvTAINTED_on(bufsv);
    SP = ORIGMARK;
    PUSHi(length);
    RETURN;

  say_undef:
    SP = ORIGMARK;
    RETPUSHUNDEF;
}

PP(pp_syswrite)
{
    djSP;
    int items = (SP - PL_stack_base) - TOPMARK;
    if (items == 2) {
	SV *sv;
        EXTEND(SP, 1);
	sv = sv_2mortal(newSViv(sv_len(*SP)));
	PUSHs(sv);
        PUTBACK;
    }
    return pp_send();
}

PP(pp_send)
{
    djSP; dMARK; dORIGMARK; dTARGET;
    GV *gv;
    IO *io;
    SV *bufsv;
    char *buffer;
    Size_t length;
    SSize_t retval;
    IV offset;
    STRLEN blen;
    MAGIC *mg;

    gv = (GV*)*++MARK;
    if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	SV *sv;
	
	PUSHMARK(MARK-1);
	*MARK = SvTIED_obj((SV*)gv, mg);
	ENTER;
	call_method("WRITE", G_SCALAR);
	LEAVE;
	SPAGAIN;
	sv = POPs;
	SP = ORIGMARK;
	PUSHs(sv);
	RETURN;
    }
    if (!gv)
	goto say_undef;
    bufsv = *++MARK;
    buffer = SvPV(bufsv, blen);
#if Size_t_size > IVSIZE
    length = (Size_t)SvNVx(*++MARK);
#else
    length = (Size_t)SvIVx(*++MARK);
#endif
    if ((SSize_t)length < 0)
	DIE(aTHX_ "Negative length");
    SETERRNO(0,0);
    io = GvIO(gv);
    if (!io || !IoIFP(io)) {
	retval = -1;
	if (ckWARN(WARN_CLOSED)) {
	    if (PL_op->op_type == OP_SYSWRITE)
		report_closed_fh(gv, io, "syswrite", "filehandle");
	    else
		report_closed_fh(gv, io, "send", "socket");
	}
    }
    else if (PL_op->op_type == OP_SYSWRITE) {
	if (MARK < SP) {
	    offset = SvIVx(*++MARK);
	    if (offset < 0) {
		if (-offset > blen)
		    DIE(aTHX_ "Offset outside string");
		offset += blen;
	    } else if (offset >= blen && blen > 0)
		DIE(aTHX_ "Offset outside string");
	} else
	    offset = 0;
	if (length > blen - offset)
	    length = blen - offset;
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
	if (IoTYPE(io) == 's') {
	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
				   buffer+offset, length, 0);
	}
	else
#endif
	{
	    /* See the note at doio.c:do_print about filesize limits. --jhi */
	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
				   buffer+offset, length);
	}
    }
#ifdef HAS_SOCKET
    else if (SP > MARK) {
	char *sockbuf;
	STRLEN mlen;
	sockbuf = SvPVx(*++MARK, mlen);
	retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
				 length, (struct sockaddr *)sockbuf, mlen);
    }
    else
	retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);

#else
    else
	DIE(aTHX_ PL_no_sock_func, "send");
#endif
    if (retval < 0)
	goto say_undef;
    SP = ORIGMARK;
#if Size_t_size > IVSIZE
    PUSHn(retval);
#else
    PUSHi(retval);
#endif
    RETURN;

  say_undef:
    SP = ORIGMARK;
    RETPUSHUNDEF;
}

PP(pp_recv)
{
    return pp_sysread();
}

PP(pp_eof)
{
    djSP;
    GV *gv;
    MAGIC *mg;

    if (MAXARG == 0) {
	if (PL_op->op_flags & OPf_SPECIAL) {	/* eof() */
	    IO *io;
	    gv = PL_last_in_gv = PL_argvgv;
	    io = GvIO(gv);
	    if (io && !IoIFP(io)) {
		if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
		    IoLINES(io) = 0;
		    IoFLAGS(io) &= ~IOf_START;
		    do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
		    sv_setpvn(GvSV(gv), "-", 1);
		    SvSETMAGIC(GvSV(gv));
		}
		else if (!nextargv(gv))
		    RETPUSHYES;
	    }
	}
	else
	    gv = PL_last_in_gv;			/* eof */
    }
    else
	gv = PL_last_in_gv = (GV*)POPs;		/* eof(FH) */

    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	PUTBACK;
	ENTER;
	call_method("EOF", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    PUSHs(boolSV(!gv || do_eof(gv)));
    RETURN;
}

PP(pp_tell)
{
    djSP; dTARGET;
    GV *gv;     
    MAGIC *mg;

    if (MAXARG == 0)
	gv = PL_last_in_gv;
    else
	gv = PL_last_in_gv = (GV*)POPs;

    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
	PUTBACK;
	ENTER;
	call_method("TELL", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

#if LSEEKSIZE > IVSIZE
    PUSHn( do_tell(gv) );
#else
    PUSHi( do_tell(gv) );
#endif
    RETURN;
}

PP(pp_seek)
{
    return pp_sysseek();
}

PP(pp_sysseek)
{
    djSP;
    GV *gv;
    int whence = POPi;
#if LSEEKSIZE > IVSIZE
    Off_t offset = (Off_t)SvNVx(POPs);
#else
    Off_t offset = (Off_t)SvIVx(POPs);
#endif
    MAGIC *mg;

    gv = PL_last_in_gv = (GV*)POPs;

    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)gv, mg));
#if LSEEKSIZE > IVSIZE
	XPUSHs(sv_2mortal(newSVnv((NV) offset)));
#else
	XPUSHs(sv_2mortal(newSViv((IV) offset)));
#endif
	XPUSHs(sv_2mortal(newSViv((IV) whence)));
	PUTBACK;
	ENTER;
	call_method("SEEK", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    if (PL_op->op_type == OP_SEEK)
	PUSHs(boolSV(do_seek(gv, offset, whence)));
    else {
	Off_t n = do_sysseek(gv, offset, whence);
        if (n < 0)
            PUSHs(&PL_sv_undef);
        else {
            SV* sv = n ?
#if LSEEKSIZE > IVSIZE
                newSVnv((NV)n)
#else
                newSViv((IV)n)
#endif
                : newSVpvn(zero_but_true, ZBTLEN);
            PUSHs(sv_2mortal(sv));
        }
    }
    RETURN;
}

PP(pp_truncate)
{
    djSP;
    /* There seems to be no consensus on the length type of truncate()
     * and ftruncate(), both off_t and size_t have supporters. In
     * general one would think that when using large files, off_t is
     * at least as wide as size_t, so using an off_t should be okay. */
    /* XXX Configure probe for the length type of *truncate() needed XXX */
    Off_t len;
    int result = 1;
    GV *tmpgv;
    STRLEN n_a;

#if Size_t_size > IVSIZE
    len = (Off_t)POPn;
#else
    len = (Off_t)POPi;
#endif
    /* Checking for length < 0 is problematic as the type might or
     * might not be signed: if it is not, clever compilers will moan. */ 
    /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
    SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
    if (PL_op->op_flags & OPf_SPECIAL) {
	tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
    do_ftruncate:
	TAINT_PROPER("truncate");
	if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
	    result = 0;
	else {
	    PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
	    if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else 
	    if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
		result = 0;
	}
    }
    else {
	SV *sv = POPs;
	char *name;
	STRLEN n_a;

	if (SvTYPE(sv) == SVt_PVGV) {
	    tmpgv = (GV*)sv;		/* *main::FRED for example */
	    goto do_ftruncate;
	}
	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
	    tmpgv = (GV*) SvRV(sv);	/* \*main::FRED for example */
	    goto do_ftruncate;
	}

	name = SvPV(sv, n_a);
	TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
	if (truncate(name, len) < 0)
	    result = 0;
#else
	{
	    int tmpfd;
	    if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
		result = 0;
	    else {
		if (my_chsize(tmpfd, len) < 0)
		    result = 0;
		PerlLIO_close(tmpfd);
	    }
	}
#endif
    }

    if (result)
	RETPUSHYES;
    if (!errno)
	SETERRNO(EBADF,RMS$_IFI);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ "truncate not implemented");
#endif
}

PP(pp_fcntl)
{
    return pp_ioctl();
}

PP(pp_ioctl)
{
    djSP; dTARGET;
    SV *argsv = POPs;
    unsigned int func = U_I(POPn);
    int optype = PL_op->op_type;
    char *s;
    IV retval;
    GV *gv = (GV*)POPs;
    IO *io = GvIOn(gv);

    if (!io || !argsv || !IoIFP(io)) {
	SETERRNO(EBADF,RMS$_IFI);	/* well, sort of... */
	RETPUSHUNDEF;
    }

    if (SvPOK(argsv) || !SvNIOK(argsv)) {
	STRLEN len;
	STRLEN need;
	s = SvPV_force(argsv, len);
	need = IOCPARM_LEN(func);
	if (len < need) {
	    s = Sv_Grow(argsv, need + 1);
	    SvCUR_set(argsv, need);
	}

	s[SvCUR(argsv)] = 17;	/* a little sanity check here */
    }
    else {
	retval = SvIV(argsv);
	s = INT2PTR(char*,retval);		/* ouch */
    }

    TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");

    if (optype == OP_IOCTL)
#ifdef HAS_IOCTL
	retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
#else
	DIE(aTHX_ "ioctl is not implemented");
#endif
    else
#ifdef HAS_FCNTL
#if defined(OS2) && defined(__EMX__)
	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
#else
	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif 
#else
	DIE(aTHX_ "fcntl is not implemented");
#endif

    if (SvPOK(argsv)) {
	if (s[SvCUR(argsv)] != 17)
	    DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
		PL_op_name[optype]);
	s[SvCUR(argsv)] = 0;		/* put our null back */
	SvSETMAGIC(argsv);		/* Assume it has changed */
    }

    if (retval == -1)
	RETPUSHUNDEF;
    if (retval != 0) {
	PUSHi(retval);
    }
    else {
	PUSHp(zero_but_true, ZBTLEN);
    }
    RETURN;
}

PP(pp_flock)
{
    djSP; dTARGET;
    I32 value;
    int argtype;
    GV *gv;
    PerlIO *fp;

#ifdef FLOCK
    argtype = POPi;
    if (MAXARG == 0)
	gv = PL_last_in_gv;
    else
	gv = (GV*)POPs;
    if (gv && GvIO(gv))
	fp = IoIFP(GvIOp(gv));
    else
	fp = Nullfp;
    if (fp) {
	(void)PerlIO_flush(fp);
	value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
    }
    else {
	value = 0;
	SETERRNO(EBADF,RMS$_IFI);
	if (ckWARN(WARN_CLOSED))
	    report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
    }
    PUSHi(value);
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "flock()");
#endif
}

/* Sockets. */

PP(pp_socket)
{
    djSP;
#ifdef HAS_SOCKET
    GV *gv;
    register IO *io;
    int protocol = POPi;
    int type = POPi;
    int domain = POPi;
    int fd;

    gv = (GV*)POPs;

    if (!gv) {
	SETERRNO(EBADF,LIB$_INVARG);
	RETPUSHUNDEF;
    }

    io = GvIOn(gv);
    if (IoIFP(io))
	do_close(gv, FALSE);

    TAINT_PROPER("socket");
    fd = PerlSock_socket(domain, type, protocol);
    if (fd < 0)
	RETPUSHUNDEF;
    IoIFP(io) = PerlIO_fdopen(fd, "r");	/* stdio gets confused about sockets */
    IoOFP(io) = PerlIO_fdopen(fd, "w");
    IoTYPE(io) = 's';
    if (!IoIFP(io) || !IoOFP(io)) {
	if (IoIFP(io)) PerlIO_close(IoIFP(io));
	if (IoOFP(io)) PerlIO_close(IoOFP(io));
	if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
	RETPUSHUNDEF;
    }
#if defined(HAS_FCNTL) && defined(F_SETFD)
    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
#endif

    RETPUSHYES;
#else
    DIE(aTHX_ PL_no_sock_func, "socket");
#endif
}

PP(pp_sockpair)
{
    djSP;
#ifdef HAS_SOCKETPAIR
    GV *gv1;
    GV *gv2;
    register IO *io1;
    register IO *io2;
    int protocol = POPi;
    int type = POPi;
    int domain = POPi;
    int fd[2];

    gv2 = (GV*)POPs;
    gv1 = (GV*)POPs;
    if (!gv1 || !gv2)
	RETPUSHUNDEF;

    io1 = GvIOn(gv1);
    io2 = GvIOn(gv2);
    if (IoIFP(io1))
	do_close(gv1, FALSE);
    if (IoIFP(io2))
	do_close(gv2, FALSE);

    TAINT_PROPER("socketpair");
    if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
	RETPUSHUNDEF;
    IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
    IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
    IoTYPE(io1) = 's';
    IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
    IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
    IoTYPE(io2) = 's';
    if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
	if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
	if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
	if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
	if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
	if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
	if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
	RETPUSHUNDEF;
    }
#if defined(HAS_FCNTL) && defined(F_SETFD)
    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
#endif

    RETPUSHYES;
#else
    DIE(aTHX_ PL_no_sock_func, "socketpair");
#endif
}

PP(pp_bind)
{
    djSP;
#ifdef HAS_SOCKET
#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
    extern GETPRIVMODE();
    extern GETUSERMODE();
#endif
    SV *addrsv = POPs;
    char *addr;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);
    STRLEN len;
    int bind_ok = 0;
#ifdef MPE
    int mpeprivmode = 0;
#endif

    if (!io || !IoIFP(io))
	goto nuts;

    addr = SvPV(addrsv, len);
    TAINT_PROPER("bind");
#ifdef MPE /* Deal with MPE bind() peculiarities */
    if (((struct sockaddr *)addr)->sa_family == AF_INET) {
        /* The address *MUST* stupidly be zero. */
        ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
        /* PRIV mode is required to bind() to ports < 1024. */
        if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
            ((struct sockaddr_in *)addr)->sin_port > 0) {
            GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
	    mpeprivmode = 1;
	}
    }
#endif /* MPE */
    if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
		      (struct sockaddr *)addr, len) >= 0)
	bind_ok = 1;

#ifdef MPE /* Switch back to USER mode */
    if (mpeprivmode)
	GETUSERMODE();
#endif /* MPE */

    if (bind_ok)
	RETPUSHYES;
    else
	RETPUSHUNDEF;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io, "bind", "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "bind");
#endif
}

PP(pp_connect)
{
    djSP;
#ifdef HAS_SOCKET
    SV *addrsv = POPs;
    char *addr;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);
    STRLEN len;

    if (!io || !IoIFP(io))
	goto nuts;

    addr = SvPV(addrsv, len);
    TAINT_PROPER("connect");
    if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
	RETPUSHYES;
    else
	RETPUSHUNDEF;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io, "connect", "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "connect");
#endif
}

PP(pp_listen)
{
    djSP;
#ifdef HAS_SOCKET
    int backlog = POPi;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);

    if (!io || !IoIFP(io))
	goto nuts;

    if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
	RETPUSHYES;
    else
	RETPUSHUNDEF;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io, "listen", "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "listen");
#endif
}

PP(pp_accept)
{
    djSP; dTARGET;
#ifdef HAS_SOCKET
    GV *ngv;
    GV *ggv;
    register IO *nstio;
    register IO *gstio;
    struct sockaddr saddr;	/* use a struct to avoid alignment problems */
    Sock_size_t len = sizeof saddr;
    int fd;

    ggv = (GV*)POPs;
    ngv = (GV*)POPs;

    if (!ngv)
	goto badexit;
    if (!ggv)
	goto nuts;

    gstio = GvIO(ggv);
    if (!gstio || !IoIFP(gstio))
	goto nuts;

    nstio = GvIOn(ngv);
    if (IoIFP(nstio))
	do_close(ngv, FALSE);

    fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
    if (fd < 0)
	goto badexit;
    IoIFP(nstio) = PerlIO_fdopen(fd, "r");
    IoOFP(nstio) = PerlIO_fdopen(fd, "w");
    IoTYPE(nstio) = 's';
    if (!IoIFP(nstio) || !IoOFP(nstio)) {
	if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
	if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
	if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
	goto badexit;
    }
#if defined(HAS_FCNTL) && defined(F_SETFD)
    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
#endif

    PUSHp((char *)&saddr, len);
    RETURN;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
    SETERRNO(EBADF,SS$_IVCHAN);

badexit:
    RETPUSHUNDEF;

#else
    DIE(aTHX_ PL_no_sock_func, "accept");
#endif
}

PP(pp_shutdown)
{
    djSP; dTARGET;
#ifdef HAS_SOCKET
    int how = POPi;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);

    if (!io || !IoIFP(io))
	goto nuts;

    PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
    RETURN;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io, "shutdown", "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "shutdown");
#endif
}

PP(pp_gsockopt)
{
#ifdef HAS_SOCKET
    return pp_ssockopt();
#else
    DIE(aTHX_ PL_no_sock_func, "getsockopt");
#endif
}

PP(pp_ssockopt)
{
    djSP;
#ifdef HAS_SOCKET
    int optype = PL_op->op_type;
    SV *sv;
    int fd;
    unsigned int optname;
    unsigned int lvl;
    GV *gv;
    register IO *io;
    Sock_size_t len;

    if (optype == OP_GSOCKOPT)
	sv = sv_2mortal(NEWSV(22, 257));
    else
	sv = POPs;
    optname = (unsigned int) POPi;
    lvl = (unsigned int) POPi;

    gv = (GV*)POPs;
    io = GvIOn(gv);
    if (!io || !IoIFP(io))
	goto nuts;

    fd = PerlIO_fileno(IoIFP(io));
    switch (optype) {
    case OP_GSOCKOPT:
	SvGROW(sv, 257);
	(void)SvPOK_only(sv);
	SvCUR_set(sv,256);
	*SvEND(sv) ='\0';
	len = SvCUR(sv);
	if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
	    goto nuts2;
	SvCUR_set(sv, len);
	*SvEND(sv) ='\0';
	PUSHs(sv);
	break;
    case OP_SSOCKOPT: {
	    char *buf;
	    int aint;
	    if (SvPOKp(sv)) {
		STRLEN l;
		buf = SvPV(sv, l);
		len = l;
	    }
	    else {
		aint = (int)SvIV(sv);
		buf = (char*)&aint;
		len = sizeof(int);
	    }
	    if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
		goto nuts2;
	    PUSHs(&PL_sv_yes);
	}
	break;
    }
    RETURN;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io,
			 optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
			 "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
    RETPUSHUNDEF;

#else
    DIE(aTHX_ PL_no_sock_func, "setsockopt");
#endif
}

PP(pp_getsockname)
{
#ifdef HAS_SOCKET
    return pp_getpeername();
#else
    DIE(aTHX_ PL_no_sock_func, "getsockname");
#endif
}

PP(pp_getpeername)
{
    djSP;
#ifdef HAS_SOCKET
    int optype = PL_op->op_type;
    SV *sv;
    int fd;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);
    Sock_size_t len;

    if (!io || !IoIFP(io))
	goto nuts;

    sv = sv_2mortal(NEWSV(22, 257));
    (void)SvPOK_only(sv);
    len = 256;
    SvCUR_set(sv, len);
    *SvEND(sv) ='\0';
    fd = PerlIO_fileno(IoIFP(io));
    switch (optype) {
    case OP_GETSOCKNAME:
	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
	    goto nuts2;
	break;
    case OP_GETPEERNAME:
	if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
	    goto nuts2;
#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
	{
	    static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
	    /* If the call succeeded, make sure we don't have a zeroed port/addr */
	    if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
		!memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
			sizeof(u_short) + sizeof(struct in_addr))) {
		goto nuts2;	    
	    }
	}
#endif
	break;
    }
#ifdef BOGUS_GETNAME_RETURN
    /* Interactive Unix, getpeername() and getsockname()
      does not return valid namelen */
    if (len == BOGUS_GETNAME_RETURN)
	len = sizeof(struct sockaddr);
#endif
    SvCUR_set(sv, len);
    *SvEND(sv) ='\0';
    PUSHs(sv);
    RETURN;

nuts:
    if (ckWARN(WARN_CLOSED))
	report_closed_fh(gv, io,
			 optype == OP_GETSOCKNAME ? "getsockname"
						  : "getpeername",
			 "socket");
    SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
    RETPUSHUNDEF;

#else
    DIE(aTHX_ PL_no_sock_func, "getpeername");
#endif
}

/* Stat calls. */

PP(pp_lstat)
{
    return pp_stat();
}

PP(pp_stat)
{
    djSP;
    GV *tmpgv;
    I32 gimme;
    I32 max = 13;
    STRLEN n_a;

    if (PL_op->op_flags & OPf_REF) {
	tmpgv = cGVOP_gv;
      do_fstat:
	if (tmpgv != PL_defgv) {
	    PL_laststype = OP_STAT;
	    PL_statgv = tmpgv;
	    sv_setpv(PL_statname, "");
	    PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
		? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
	}
	if (PL_laststatval < 0)
	    max = 0;
    }
    else {
	SV* sv = POPs;
	if (SvTYPE(sv) == SVt_PVGV) {
	    tmpgv = (GV*)sv;
	    goto do_fstat;
	}
	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
	    tmpgv = (GV*)SvRV(sv);
	    goto do_fstat;
	}
	sv_setpv(PL_statname, SvPV(sv,n_a));
	PL_statgv = Nullgv;
#ifdef HAS_LSTAT
	PL_laststype = PL_op->op_type;
	if (PL_op->op_type == OP_LSTAT)
	    PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
	else
#endif
	    PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
	if (PL_laststatval < 0) {
	    if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
		Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
	    max = 0;
	}
    }

    gimme = GIMME_V;
    if (gimme != G_ARRAY) {
	if (gimme != G_VOID)
	    XPUSHs(boolSV(max));
	RETURN;
    }
    if (max) {
	EXTEND(SP, max);
	EXTEND_MORTAL(max);
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
#if Uid_t_size > IVSIZE
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
#else
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
#endif
#if Gid_t_size > IVSIZE 
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
#else
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
#endif
#ifdef USE_STAT_RDEV
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
#else
	PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
#if Off_t_size > IVSIZE
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
#else
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
#endif
#ifdef BIG_TIME
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
#else
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
#endif
#ifdef USE_STAT_BLOCKS
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
#else
	PUSHs(sv_2mortal(newSVpvn("", 0)));
	PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
    }
    RETURN;
}

PP(pp_ftrread)
{
    I32 result;
    djSP;
#if defined(HAS_ACCESS) && defined(R_OK)
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = access(TOPpx, R_OK);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IRUSR, 0, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftrwrite)
{
    I32 result;
    djSP;
#if defined(HAS_ACCESS) && defined(W_OK)
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = access(TOPpx, W_OK);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IWUSR, 0, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftrexec)
{
    I32 result;
    djSP;
#if defined(HAS_ACCESS) && defined(X_OK)
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = access(TOPpx, X_OK);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IXUSR, 0, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_fteread)
{
    I32 result;
    djSP;
#ifdef PERL_EFF_ACCESS_R_OK
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = PERL_EFF_ACCESS_R_OK(TOPpx);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IRUSR, 1, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftewrite)
{
    I32 result;
    djSP;
#ifdef PERL_EFF_ACCESS_W_OK
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = PERL_EFF_ACCESS_W_OK(TOPpx);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IWUSR, 1, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_fteexec)
{
    I32 result;
    djSP;
#ifdef PERL_EFF_ACCESS_X_OK
    STRLEN n_a;
    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
	result = PERL_EFF_ACCESS_X_OK(TOPpx);
	if (result == 0)
	    RETPUSHYES;
	if (result < 0)
	    RETPUSHUNDEF;
	RETPUSHNO;
    }
    else
	result = my_stat();
#else
    result = my_stat();
#endif
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (cando(S_IXUSR, 1, &PL_statcache))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftis)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    RETPUSHYES;
}

PP(pp_fteowned)
{
    return pp_ftrowned();
}

PP(pp_ftrowned)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
				PL_euid : PL_uid) )
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftzero)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_size == 0)
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftsize)
{
    I32 result = my_stat();
    djSP; dTARGET;
    if (result < 0)
	RETPUSHUNDEF;
#if Off_t_size > IVSIZE
    PUSHn(PL_statcache.st_size);
#else
    PUSHi(PL_statcache.st_size);
#endif
    RETURN;
}

PP(pp_ftmtime)
{
    I32 result = my_stat();
    djSP; dTARGET;
    if (result < 0)
	RETPUSHUNDEF;
    PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
    RETURN;
}

PP(pp_ftatime)
{
    I32 result = my_stat();
    djSP; dTARGET;
    if (result < 0)
	RETPUSHUNDEF;
    PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
    RETURN;
}

PP(pp_ftctime)
{
    I32 result = my_stat();
    djSP; dTARGET;
    if (result < 0)
	RETPUSHUNDEF;
    PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
    RETURN;
}

PP(pp_ftsock)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISSOCK(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftchr)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISCHR(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftblk)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISBLK(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftfile)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISREG(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftdir)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISDIR(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftpipe)
{
    I32 result = my_stat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISFIFO(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftlink)
{
    I32 result = my_lstat();
    djSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (S_ISLNK(PL_statcache.st_mode))
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftsuid)
{
    djSP;
#ifdef S_ISUID
    I32 result = my_stat();
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_mode & S_ISUID)
	RETPUSHYES;
#endif
    RETPUSHNO;
}

PP(pp_ftsgid)
{
    djSP;
#ifdef S_ISGID
    I32 result = my_stat();
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_mode & S_ISGID)
	RETPUSHYES;
#endif
    RETPUSHNO;
}

PP(pp_ftsvtx)
{
    djSP;
#ifdef S_ISVTX
    I32 result = my_stat();
    SPAGAIN;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_mode & S_ISVTX)
	RETPUSHYES;
#endif
    RETPUSHNO;
}

PP(pp_fttty)
{
    djSP;
    int fd;
    GV *gv;
    char *tmps = Nullch;
    STRLEN n_a;

    if (PL_op->op_flags & OPf_REF)
	gv = cGVOP_gv;
    else if (isGV(TOPs))
	gv = (GV*)POPs;
    else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
	gv = (GV*)SvRV(POPs);
    else
	gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);

    if (GvIO(gv) && IoIFP(GvIOp(gv)))
	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
    else if (tmps && isDIGIT(*tmps))
	fd = atoi(tmps);
    else
	RETPUSHUNDEF;
    if (PerlLIO_isatty(fd))
	RETPUSHYES;
    RETPUSHNO;
}

#if defined(atarist) /* this will work with atariST. Configure will
			make guesses for other systems. */
# define FILE_base(f) ((f)->_base)
# define FILE_ptr(f) ((f)->_ptr)
# define FILE_cnt(f) ((f)->_cnt)
# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
#endif

PP(pp_fttext)
{
    djSP;
    I32 i;
    I32 len;
    I32 odd = 0;
    STDCHAR tbuf[512];
    register STDCHAR *s;
    register IO *io;
    register SV *sv;
    GV *gv;
    STRLEN n_a;
    PerlIO *fp;

    if (PL_op->op_flags & OPf_REF)
	gv = cGVOP_gv;
    else if (isGV(TOPs))
	gv = (GV*)POPs;
    else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
	gv = (GV*)SvRV(POPs);
    else
	gv = Nullgv;

    if (gv) {
	EXTEND(SP, 1);
	if (gv == PL_defgv) {
	    if (PL_statgv)
		io = GvIO(PL_statgv);
	    else {
		sv = PL_statname;
		goto really_filename;
	    }
	}
	else {
	    PL_statgv = gv;
	    PL_laststatval = -1;
	    sv_setpv(PL_statname, "");
	    io = GvIO(PL_statgv);
	}
	if (io && IoIFP(io)) {
	    if (! PerlIO_has_base(IoIFP(io)))
		DIE(aTHX_ "-T and -B not implemented on filehandles");
	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
	    if (PL_laststatval < 0)
		RETPUSHUNDEF;
	    if (S_ISDIR(PL_statcache.st_mode))	/* handle NFS glitch */
		if (PL_op->op_type == OP_FTTEXT)
		    RETPUSHNO;
		else
		    RETPUSHYES;
	    if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
		i = PerlIO_getc(IoIFP(io));
		if (i != EOF)
		    (void)PerlIO_ungetc(IoIFP(io),i);
	    }
	    if (PerlIO_get_cnt(IoIFP(io)) <= 0)	/* null file is anything */
		RETPUSHYES;
	    len = PerlIO_get_bufsiz(IoIFP(io));
	    s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
	    /* sfio can have large buffers - limit to 512 */
	    if (len > 512)
		len = 512;
	}
	else {
	    if (ckWARN(WARN_UNOPENED)) {
		gv = cGVOP_gv;
		Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
			    GvENAME(gv));
	    }
	    SETERRNO(EBADF,RMS$_IFI);
	    RETPUSHUNDEF;
	}
    }
    else {
	sv = POPs;
      really_filename:
	PL_statgv = Nullgv;
	PL_laststatval = -1;
	sv_setpv(PL_statname, SvPV(sv, n_a));
	if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
	    if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
		Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
	    RETPUSHUNDEF;
	}
	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
	if (PL_laststatval < 0)	{
	    (void)PerlIO_close(fp);
	    RETPUSHUNDEF;
	}
	do_binmode(fp, '<', TRUE);
	len = PerlIO_read(fp, tbuf, sizeof(tbuf));
	(void)PerlIO_close(fp);
	if (len <= 0) {
	    if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
		RETPUSHNO;		/* special case NFS directories */
	    RETPUSHYES;		/* null file is anything */
	}
	s = tbuf;
    }

    /* now scan s to look for textiness */
    /*   XXX ASCII dependent code */

#if defined(DOSISH) || defined(USEMYBINMODE)
    /* ignore trailing ^Z on short files */
    if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
	--len;
#endif

    for (i = 0; i < len; i++, s++) {
	if (!*s) {			/* null never allowed in text */
	    odd += len;
	    break;
	}
#ifdef EBCDIC
        else if (!(isPRINT(*s) || isSPACE(*s))) 
            odd++;
#else
	else if (*s & 128) {
#ifdef USE_LOCALE
	    if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
		continue;
#endif
	    /* utf8 characters don't count as odd */
	    if (*s & 0x40) {
		int ulen = UTF8SKIP(s);
		if (ulen < len - i) {
		    int j;
		    for (j = 1; j < ulen; j++) {
			if ((s[j] & 0xc0) != 0x80)
			    goto not_utf8;
		    }
		    --ulen;	/* loop does extra increment */
		    s += ulen;
		    i += ulen;
		    continue;
		}
	    }
	  not_utf8:
	    odd++;
	}
	else if (*s < 32 &&
	  *s != '\n' && *s != '\r' && *s != '\b' &&
	  *s != '\t' && *s != '\f' && *s != 27)
	    odd++;
#endif
    }

    if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
	RETPUSHNO;
    else
	RETPUSHYES;
}

PP(pp_ftbinary)
{
    return pp_fttext();
}

/* File calls. */

PP(pp_chdir)
{
    djSP; dTARGET;
    char *tmps;
    SV **svp;
    STRLEN n_a;

    if (MAXARG < 1)
	tmps = Nullch;
    else
	tmps = POPpx;
    if (!tmps || !*tmps) {
	svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
	if (svp)
	    tmps = SvPV(*svp, n_a);
    }
    if (!tmps || !*tmps) {
	svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
	if (svp)
	    tmps = SvPV(*svp, n_a);
    }
#ifdef VMS
    if (!tmps || !*tmps) {
       svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
       if (svp)
           tmps = SvPV(*svp, n_a);
    }
#endif
    TAINT_PROPER("chdir");
    PUSHi( PerlDir_chdir(tmps) >= 0 );
#ifdef VMS
    /* Clear the DEFAULT element of ENV so we'll get the new value
     * in the future. */
    hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
#endif
    RETURN;
}

PP(pp_chown)
{
    djSP; dMARK; dTARGET;
    I32 value;
#ifdef HAS_CHOWN
    value = (I32)apply(PL_op->op_type, MARK, SP);
    SP = MARK;
    PUSHi(value);
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "Unsupported function chown");
#endif
}

PP(pp_chroot)
{
    djSP; dTARGET;
    char *tmps;
#ifdef HAS_CHROOT
    STRLEN n_a;
    tmps = POPpx;
    TAINT_PROPER("chroot");
    PUSHi( chroot(tmps) >= 0 );
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "chroot");
#endif
}

PP(pp_unlink)
{
    djSP; dMARK; dTARGET;
    I32 value;
    value = (I32)apply(PL_op->op_type, MARK, SP);
    SP = MARK;
    PUSHi(value);
    RETURN;
}

PP(pp_chmod)
{
    djSP; dMARK; dTARGET;
    I32 value;
    value = (I32)apply(PL_op->op_type, MARK, SP);
    SP = MARK;
    PUSHi(value);
    RETURN;
}

PP(pp_utime)
{
    djSP; dMARK; dTARGET;
    I32 value;
    value = (I32)apply(PL_op->op_type, MARK, SP);
    SP = MARK;
    PUSHi(value);
    RETURN;
}

PP(pp_rename)
{
    djSP; dTARGET;
    int anum;
    STRLEN n_a;

    char *tmps2 = POPpx;
    char *tmps = SvPV(TOPs, n_a);
    TAINT_PROPER("rename");
#ifdef HAS_RENAME
    anum = PerlLIO_rename(tmps, tmps2);
#else
    if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
	if (same_dirent(tmps2, tmps))	/* can always rename to same name */
	    anum = 1;
	else {
	    if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
		(void)UNLINK(tmps2);
	    if (!(anum = link(tmps, tmps2)))
		anum = UNLINK(tmps);
	}
    }
#endif
    SETi( anum >= 0 );
    RETURN;
}

PP(pp_link)
{
    djSP; dTARGET;
#ifdef HAS_LINK
    STRLEN n_a;
    char *tmps2 = POPpx;
    char *tmps = SvPV(TOPs, n_a);
    TAINT_PROPER("link");
    SETi( PerlLIO_link(tmps, tmps2) >= 0 );
#else
    DIE(aTHX_ PL_no_func, "Unsupported function link");
#endif
    RETURN;
}

PP(pp_symlink)
{
    djSP; dTARGET;
#ifdef HAS_SYMLINK
    STRLEN n_a;
    char *tmps2 = POPpx;
    char *tmps = SvPV(TOPs, n_a);
    TAINT_PROPER("symlink");
    SETi( symlink(tmps, tmps2) >= 0 );
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "symlink");
#endif
}

PP(pp_readlink)
{
    djSP; dTARGET;
#ifdef HAS_SYMLINK
    char *tmps;
    char buf[MAXPATHLEN];
    int len;
    STRLEN n_a;

#ifndef INCOMPLETE_TAINTS
    TAINT;
#endif
    tmps = POPpx;
    len = readlink(tmps, buf, sizeof buf);
    EXTEND(SP, 1);
    if (len < 0)
	RETPUSHUNDEF;
    PUSHp(buf, len);
    RETURN;
#else
    EXTEND(SP, 1);
    RETSETUNDEF;		/* just pretend it's a normal file */
#endif
}

#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
STATIC int
S_dooneliner(pTHX_ char *cmd, char *filename)
{
    char *save_filename = filename;
    char *cmdline;
    char *s;
    PerlIO *myfp;
    int anum = 1;

    New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
    strcpy(cmdline, cmd);
    strcat(cmdline, " ");
    for (s = cmdline + strlen(cmdline); *filename; ) {
	*s++ = '\\';
	*s++ = *filename++;
    }
    strcpy(s, " 2>&1");
    myfp = PerlProc_popen(cmdline, "r");
    Safefree(cmdline);

    if (myfp) {
	SV *tmpsv = sv_newmortal();
	/* Need to save/restore 'PL_rs' ?? */
	s = sv_gets(tmpsv, myfp, 0);
	(void)PerlProc_pclose(myfp);
	if (s != Nullch) {
	    int e;
	    for (e = 1;
#ifdef HAS_SYS_ERRLIST
		 e <= sys_nerr
#endif
		 ; e++)
	    {
		/* you don't see this */
		char *errmsg =
#ifdef HAS_SYS_ERRLIST
		    sys_errlist[e]
#else
		    strerror(e)
#endif
		    ;
		if (!errmsg)
		    break;
		if (instr(s, errmsg)) {
		    SETERRNO(e,0);
		    return 0;
		}
	    }
	    SETERRNO(0,0);
#ifndef EACCES
#define EACCES EPERM
#endif
	    if (instr(s, "cannot make"))
		SETERRNO(EEXIST,RMS$_FEX);
	    else if (instr(s, "existing file"))
		SETERRNO(EEXIST,RMS$_FEX);
	    else if (instr(s, "ile exists"))
		SETERRNO(EEXIST,RMS$_FEX);
	    else if (instr(s, "non-exist"))
		SETERRNO(ENOENT,RMS$_FNF);
	    else if (instr(s, "does not exist"))
		SETERRNO(ENOENT,RMS$_FNF);
	    else if (instr(s, "not empty"))
		SETERRNO(EBUSY,SS$_DEVOFFLINE);
	    else if (instr(s, "cannot access"))
		SETERRNO(EACCES,RMS$_PRV);
	    else
		SETERRNO(EPERM,RMS$_PRV);
	    return 0;
	}
	else {	/* some mkdirs return no failure indication */
	    anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
	    if (PL_op->op_type == OP_RMDIR)
		anum = !anum;
	    if (anum)
		SETERRNO(0,0);
	    else
		SETERRNO(EACCES,RMS$_PRV);	/* a guess */
	}
	return anum;
    }
    else
	return 0;
}
#endif

PP(pp_mkdir)
{
    djSP; dTARGET;
    int mode;
#ifndef HAS_MKDIR
    int oldumask;
#endif
    STRLEN n_a;
    char *tmps;

    if (MAXARG > 1)
	mode = POPi;
    else
	mode = 0777;

    tmps = SvPV(TOPs, n_a);

    TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
    SETi( PerlDir_mkdir(tmps, mode) >= 0 );
#else
    SETi( dooneliner("mkdir", tmps) );
    oldumask = PerlLIO_umask(0);
    PerlLIO_umask(oldumask);
    PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
#endif
    RETURN;
}

PP(pp_rmdir)
{
    djSP; dTARGET;
    char *tmps;
    STRLEN n_a;

    tmps = POPpx;
    TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
    XPUSHi( PerlDir_rmdir(tmps) >= 0 );
#else
    XPUSHi( dooneliner("rmdir", tmps) );
#endif
    RETURN;
}

/* Directory calls. */

PP(pp_open_dir)
{
    djSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
    STRLEN n_a;
    char *dirname = POPpx;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);

    if (!io)
	goto nope;

    if (IoDIRP(io))
	PerlDir_close(IoDIRP(io));
    if (!(IoDIRP(io) = PerlDir_open(dirname)))
	goto nope;

    RETPUSHYES;
nope:
    if (!errno)
	SETERRNO(EBADF,RMS$_DIR);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_dir_func, "opendir");
#endif
}

PP(pp_readdir)
{
    djSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
#ifndef I_DIRENT
    Direntry_t *readdir (DIR *);
#endif
    register Direntry_t *dp;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);
    SV *sv;

    if (!io || !IoDIRP(io))
	goto nope;

    if (GIMME == G_ARRAY) {
	/*SUPPRESS 560*/
	while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
#ifdef DIRNAMLEN
	    sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
	    sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
	    if (!(IoFLAGS(io) & IOf_UNTAINT))
		SvTAINTED_on(sv);
#endif
	    XPUSHs(sv_2mortal(sv));
	}
    }
    else {
	if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
	    goto nope;
#ifdef DIRNAMLEN
	sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
	sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
	if (!(IoFLAGS(io) & IOf_UNTAINT))
	    SvTAINTED_on(sv);
#endif
	XPUSHs(sv_2mortal(sv));
    }
    RETURN;

nope:
    if (!errno)
	SETERRNO(EBADF,RMS$_ISI);
    if (GIMME == G_ARRAY)
	RETURN;
    else
	RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}

PP(pp_telldir)
{
    djSP; dTARGET;
#if defined(HAS_TELLDIR) || defined(telldir)
 /* XXX does _anyone_ need this? --AD 2/20/1998 */
 /* XXX netbsd still seemed to.
    XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
    --JHI 1999-Feb-02 */
# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
    long telldir (DIR *);
# endif
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);

    if (!io || !IoDIRP(io))
	goto nope;

    PUSHi( PerlDir_tell(IoDIRP(io)) );
    RETURN;
nope:
    if (!errno)
	SETERRNO(EBADF,RMS$_ISI);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_dir_func, "telldir");
#endif
}

PP(pp_seekdir)
{
    djSP;
#if defined(HAS_SEEKDIR) || defined(seekdir)
    long along = POPl;
    GV *gv = (GV*)POPs;
    register IO *io = GvIOn(gv);

    if (!io || !IoDIRP(io))
	goto nope;

    (void)PerlDir_seek(IoDIRP(io), along);

    RETPUSHYES;
nope:
    if (!errno)
	SETERRNO(EBADF,RMS$_ISI);
    RETPUSHUNDEF;
#else