Re: [PATCH] xsubpp prototypes warnings

[perl5.git] / pp_sys.c

/*    pp_sys.c
 *
 *    Copyright (c) 1991-2002, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * 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.
 *
 * There are at least two more shadow interfaces,
 * see the comments in pp_gpwent().
 *
 * --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

#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

#ifdef NETWARE
NETDB_DEFINE_CONTEXT
#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
#  if !defined(VMS)
    struct passwd *getpwnam (char *);
    struct passwd *getpwuid (Uid_t);
#  endif
# 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

#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(FCNTL_CAN_LOCK)
#    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)
#   ifdef I_SYS_SECURITY
#       include <sys/security.h>
#   endif
#   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)
/* With it or without it: anyway you get a warning: either that
   it is unused, or it is declared static and never defined.
 */
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)
{
    dSP; 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) {
	char *type = NULL;
	if (PL_curcop->cop_io) {
	    type = SvPV_nolen(PL_curcop->cop_io);
	}
	if (type && *type)
	    PerlIO_apply_layers(aTHX_ fp,mode,type);

	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;
}

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

PP(pp_warn)
{
    dSP; 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)
{
    dSP; dMARK;
    char *tmps;
    SV *tmpsv;
    STRLEN len;
    bool multiarg = 0;
#ifdef VMS
    VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
#endif
    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) && PL_in_eval) ? 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(newSVuv(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_ Nullformat);
	}
	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)
{
    dSP;
    dMARK; dORIGMARK;
    dTARGET;
    GV *gv;
    SV *sv;
    IO *io;
    char *tmps;
    STRLEN len;
    MAGIC *mg;
    bool  ok;

    gv = (GV *)*++MARK;
    if (!isGV(gv))
	DIE(aTHX_ PL_no_usym, "filehandle");
    if ((io = GvIOp(gv)))
	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;

    if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
	/* Method's args are same as ours ... */
	/* ... except handle is replaced by the object */
	*MARK-- = SvTIED_obj((SV*)io, mg);
	PUSHMARK(MARK);
	PUTBACK;
	ENTER;
	call_method("OPEN", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

    if (MARK < SP) {
	sv = *++MARK;
    }
    else {
	sv = GvSV(gv);
    }

    tmps = SvPV(sv, len);
    ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
    SP = ORIGMARK;
    if (ok)
	PUSHi( (I32)PL_forkprocess );
    else if (PL_forkprocess == 0)		/* we are a new child */
	PUSHi(0);
    else
	RETPUSHUNDEF;
    RETURN;
}

PP(pp_close)
{
    dSP;
    GV *gv;
    IO *io;
    MAGIC *mg;

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

    if (gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, 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)
{
#ifdef HAS_PIPE
    dSP;
    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_RDONLY;
    IoTYPE(wstio) = IoTYPE_WRONLY;

    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)
{
    dSP; dTARGET;
    GV *gv;
    IO *io;
    PerlIO *fp;
    MAGIC  *mg;

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

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

    if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
	/* Can't do this because people seem to do things like
	   defined(fileno($foo)) to check whether $foo is a valid fh.
	  if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	      report_evil_fh(gv, io, PL_op->op_type);
	    */
	RETPUSHUNDEF;
    }

    PUSHi(PerlIO_fileno(fp));
    RETURN;
}

PP(pp_umask)
{
    dSP; dTARGET;
#ifdef HAS_UMASK
    Mode_t anum;

    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)
{
    dSP;
    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 && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, 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))) {
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	    report_evil_fh(gv, io, PL_op->op_type);
        RETPUSHUNDEF;
    }

    if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
                       (discp) ? SvPV_nolen(discp) : Nullch))
	RETPUSHYES;
    else
	RETPUSHUNDEF;
}

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

    varsv = *++MARK;
    switch(SvTYPE(varsv)) {
	case SVt_PVHV:
	    methname = "TIEHASH";
	    HvEITER((HV *)varsv) = Null(HE *);
	    break;
	case SVt_PVAV:
	    methname = "TIEARRAY";
	    break;
	case SVt_PVGV:
#ifdef GV_UNIQUE_CHECK
	    if (GvUNIQUE((GV*)varsv)) {
                Perl_croak(aTHX_ "Attempt to tie unique GV");
	    }
#endif
	    methname = "TIEHANDLE";
	    how = PERL_MAGIC_tiedscalar;
	    /* For tied filehandles, we apply tiedscalar magic to the IO
	       slot of the GP rather than the GV itself. AMS 20010812 */
	    if (!GvIOp(varsv))
		GvIOp(varsv) = newIO();
	    varsv = (SV *)GvIOp(varsv);
	    break;
	default:
	    methname = "TIESCALAR";
	    how = PERL_MAGIC_tiedscalar;
	    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);
	/* Croak if a self-tie on an aggregate is attempted. */
	if (varsv == SvRV(sv) &&
	    (SvTYPE(sv) == SVt_PVAV ||
	     SvTYPE(sv) == SVt_PVHV))
	    Perl_croak(aTHX_
		       "Self-ties of arrays and hashes are not supported");
	sv_magic(varsv, sv, how, Nullch, 0);
    }
    LEAVE;
    SP = PL_stack_base + markoff;
    PUSHs(sv);
    RETURN;
}

PP(pp_untie)
{
    dSP;
    MAGIC *mg;
    SV *sv = POPs;
    char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
		? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;

    if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
	RETPUSHYES;

    if ((mg = SvTIED_mg(sv, how))) {
	SV *obj = SvRV(mg->mg_obj);
	GV *gv;
	CV *cv = NULL;
        if (obj) {
	    if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
               isGV(gv) && (cv = GvCV(gv))) {
	       PUSHMARK(SP);
	       XPUSHs(SvTIED_obj((SV*)gv, mg));
	       XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
	       PUTBACK;
	       ENTER;
	       call_sv((SV *)cv, G_VOID);
	       LEAVE;
	       SPAGAIN;
            }
           else if (ckWARN(WARN_UNTIE)) {
	       if (mg && SvREFCNT(obj) > 1)
		  Perl_warner(aTHX_ WARN_UNTIE,
		      "untie attempted while %"UVuf" inner references still exist",
		       (UV)SvREFCNT(obj) - 1 ) ;
           }
        }
	sv_unmagic(sv, how) ;
    }
    RETPUSHYES;
}

PP(pp_tied)
{
    dSP;
    MAGIC *mg;
    SV *sv = POPs;
    char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
		? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;

    if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
	RETPUSHUNDEF;

    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)
{
    dSP;
    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(newSVuv(O_RDWR|O_CREAT)));
    else
	PUSHs(sv_2mortal(newSVuv(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(newSVuv(O_RDONLY)));
	PUSHs(right);
	PUTBACK;
	call_sv((SV*)GvCV(gv), G_SCALAR);
	SPAGAIN;
    }

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

PP(pp_dbmclose)
{
    return pp_untie();
}

PP(pp_sselect)
{
#ifdef HAS_SELECT
    dSP; dTARGET;
    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
#  ifdef NFDBITS

#    ifndef NBBY
#     define NBBY 8
#    endif

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

#  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

    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)
{
    if (gv)
	(void)SvREFCNT_inc(gv);
    if (PL_defoutgv)
	SvREFCNT_dec(PL_defoutgv);
    PL_defoutgv = gv;
}

PP(pp_select)
{
    dSP; 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_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
	    XPUSHTARG;
	}
	else {
	    XPUSHs(sv_2mortal(newRV((SV*)egv)));
	}
    }

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

    RETURN;
}

PP(pp_getc)
{
    dSP; dTARGET;
    GV *gv;
    IO *io = NULL;
    MAGIC *mg;

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

    if (gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	I32 gimme = GIMME_V;
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, 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 */
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)
		&& (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)))
	    report_evil_fh(gv, io, PL_op->op_type);
	RETPUSHUNDEF;
    }
    TAINT;
    sv_setpv(TARG, " ");
    *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
    if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
	/* Find out how many bytes the char needs */
	Size_t len = UTF8SKIP(SvPVX(TARG));
	if (len > 1) {
	    SvGROW(TARG,len+1);
	    len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
	    SvCUR_set(TARG,1+len);
	}
	SvUTF8_on(TARG);
    }
    PUSHTARG;
    RETURN;
}

PP(pp_read)
{
    return pp_sysread();
}

STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
    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)
{
    dSP;
    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) {
        char *name = NULL;
	if (fgv) {
	    SV *tmpsv = sv_newmortal();
	    gv_efullname4(tmpsv, fgv, Nullch, FALSE);
	    name = SvPV_nolen(tmpsv);
	}
	if (name && *name)
	    DIE(aTHX_ "Undefined format \"%s\" called", name);
	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)
{
    dSP;
    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 (!io || !ofp)
	goto forget_top;
    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) {
		STRLEN save = SvCUR(PL_formtarget);
		SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
		do_print(PL_formtarget, ofp);
		SvCUR_set(PL_formtarget, save);
		sv_chop(PL_formtarget, s);
		FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
	    }
	}
	if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
	    do_print(PL_formfeed, ofp);
	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);
	{
	    char *name = NULL;
	    if (!cv) {
	        SV *sv = sv_newmortal();
		gv_efullname4(sv, fgv, Nullch, FALSE);
		name = SvPV_nolen(sv);
	    }
	    if (name && *name)
	        DIE(aTHX_ "Undefined top format \"%s\" called",name);
	    /* why no:
	    else
	        DIE(aTHX_ "Undefined top format called");
	    ?*/
	}
	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)) {
		/* integrate with report_evil_fh()? */
	        char *name = NULL;
		if (isGV(gv)) {
		    SV* sv = sv_newmortal();
		    gv_efullname4(sv, gv, Nullch, FALSE);
		    name = SvPV_nolen(sv);
		}
		if (name && *name)
		    Perl_warner(aTHX_ WARN_IO,
				"Filehandle %s opened only for input", name);
		else
		    Perl_warner(aTHX_ WARN_IO,
				"Filehandle opened only for input");
	    }
	    else if (ckWARN(WARN_CLOSED))
		report_evil_fh(gv, io, PL_op->op_type);
	}
	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 (!do_print(PL_formtarget, 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);
	}
    }
    /* bad_ofp: */
    PL_formtarget = PL_bodytarget;
    PUTBACK;
    return pop_return();
}

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

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

    if (gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	if (MARK == ORIGMARK) {
	    MEXTEND(SP, 1);
	    ++MARK;
	    Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
	    ++SP;
	}
	PUSHMARK(MARK - 1);
	*MARK = SvTIED_obj((SV*)io, 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 (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	    report_evil_fh(gv, io, PL_op->op_type);
	SETERRNO(EBADF,RMS$_IFI);
	goto just_say_no;
    }
    else if (!(fp = IoOFP(io))) {
	if (ckWARN2(WARN_CLOSED,WARN_IO))  {
	    /* integrate with report_evil_fh()? */
	    if (IoIFP(io)) {
	        char *name = NULL;
		if (isGV(gv)) {
		    gv_efullname4(sv, gv, Nullch, FALSE);
		    name = SvPV_nolen(sv);
		}
		if (name && *name)
		    Perl_warner(aTHX_ WARN_IO,
				"Filehandle %s opened only for input", name);
		else
		    Perl_warner(aTHX_ WARN_IO,
				"Filehandle opened only for input");
	    }
	    else if (ckWARN(WARN_CLOSED))
		report_evil_fh(gv, io, PL_op->op_type);
	}
	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)
{
    dSP;
    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)
{
    dSP; dMARK; dORIGMARK; dTARGET;
    int offset;
    GV *gv;
    IO *io;
    char *buffer;
    SSize_t length;
    SSize_t count;
    Sock_size_t bufsize;
    SV *bufsv;
    STRLEN blen;
    MAGIC *mg;
    int fp_utf8;
    Size_t got = 0;
    Size_t wanted;
    bool charstart = FALSE;
    STRLEN charskip = 0;
    STRLEN skip = 0;

    gv = (GV*)*++MARK;
    if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
	&& gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	SV *sv;
	
	PUSHMARK(MARK-1);
	*MARK = SvTIED_obj((SV*)io, 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);
    length = SvIVx(*++MARK);
    SETERRNO(0,0);
    if (MARK < SP)
	offset = SvIVx(*++MARK);
    else
	offset = 0;
    io = GvIO(gv);
    if (!io || !IoIFP(io))
	goto say_undef;
    if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
	buffer = SvPVutf8_force(bufsv, blen);
	/* UTF8 may not have been set if they are all low bytes */
	SvUTF8_on(bufsv);
    }
    else {
	buffer = SvPV_force(bufsv, blen);
    }
    if (length < 0)
	DIE(aTHX_ "Negative length");
    wanted = length;

    charstart = TRUE;
    charskip  = 0;
    skip = 0;

#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
	buffer = SvGROW(bufsv, length+1);
	/* 'offset' means 'flags' here */
	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
			  (struct sockaddr *)namebuf, &bufsize);
	if (count < 0)
	    RETPUSHUNDEF;
#ifdef EPOC
        /* Bogus return without padding */
	bufsize = sizeof (struct sockaddr_in);
#endif
	SvCUR_set(bufsv, count);
	*SvEND(bufsv) = '\0';
	(void)SvPOK_only(bufsv);
	if (fp_utf8)
	    SvUTF8_on(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 (DO_UTF8(bufsv)) {
	/* offset adjust in characters not bytes */
	blen = sv_len_utf8(bufsv);
    }
    if (offset < 0) {
	if (-offset > blen)
	    DIE(aTHX_ "Offset outside string");
	offset += blen;
    }
    if (DO_UTF8(bufsv)) {
	/* convert offset-as-chars to offset-as-bytes */
	offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
    }
 more_bytes:
    bufsize = SvCUR(bufsv);
    buffer  = SvGROW(bufsv, length+offset+1);
    if (offset > bufsize) { /* Zero any newly allocated space */
    	Zero(buffer+bufsize, offset-bufsize, char);
    }
    buffer = buffer + offset;

    if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
	if (IoTYPE(io) == IoTYPE_SOCKET) {
	    count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
				   buffer, length, 0);
	}
	else
#endif
	{
	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
				  buffer, length);
	}
    }
    else
#ifdef HAS_SOCKET__bad_code_maybe
    if (IoTYPE(io) == IoTYPE_SOCKET) {
	char namebuf[MAXPATHLEN];
#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
	bufsize = sizeof (struct sockaddr_in);
#else
	bufsize = sizeof namebuf;
#endif
	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
			  (struct sockaddr *)namebuf, &bufsize);
    }
    else
#endif
    {
	count = PerlIO_read(IoIFP(io), buffer, length);
	/* PerlIO_read() - like fread() returns 0 on both error and EOF */
	if (count == 0 && PerlIO_error(IoIFP(io)))
	    count = -1;
    }
    if (count < 0) {
	if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
	{
	    /* integrate with report_evil_fh()? */
	    char *name = NULL;
	    if (isGV(gv)) {
		SV* sv = sv_newmortal();
		gv_efullname4(sv, gv, Nullch, FALSE);
		name = SvPV_nolen(sv);
	    }
	    if (name && *name)
		Perl_warner(aTHX_ WARN_IO,
			    "Filehandle %s opened only for output", name);
	    else
		Perl_warner(aTHX_ WARN_IO,
			    "Filehandle opened only for output");
	}
	goto say_undef;
    }
    SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
    *SvEND(bufsv) = '\0';
    (void)SvPOK_only(bufsv);
    if (fp_utf8 && !IN_BYTES) {
	/* Look at utf8 we got back and count the characters */
	char *bend = buffer + count;
	while (buffer < bend) {
	    if (charstart) {
	        skip = UTF8SKIP(buffer);
		charskip = 0;
	    }
	    if (buffer - charskip + skip > bend) {
		/* partial character - try for rest of it */
		length = skip - (bend-buffer);
		offset = bend - SvPVX(bufsv);
		charstart = FALSE;
		charskip += count;
		goto more_bytes;
	    }
	    else {
		got++;
		buffer += skip;
		charstart = TRUE;
		charskip  = 0;
	    }
        }
	/* If we have not 'got' the number of _characters_ we 'wanted' get some more
	   provided amount read (count) was what was requested (length)
	 */
	if (got < wanted && count == length) {
	    length = wanted - got;
	    offset = bend - SvPVX(bufsv);
	    goto more_bytes;
	}
	/* return value is character count */
	count = got;
	SvUTF8_on(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(count);
    RETURN;

  say_undef:
    SP = ORIGMARK;
    RETPUSHUNDEF;
}

PP(pp_syswrite)
{
    dSP;
    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)
{
    dSP; dMARK; dORIGMARK; dTARGET;
    GV *gv;
    IO *io;
    SV *bufsv;
    char *buffer;
    Size_t length;
    SSize_t retval;
    STRLEN blen;
    MAGIC *mg;

    gv = (GV*)*++MARK;
    if (PL_op->op_type == OP_SYSWRITE
	&& gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	SV *sv;
	
	PUSHMARK(MARK-1);
	*MARK = SvTIED_obj((SV*)io, mg);
	ENTER;
	call_method("WRITE", G_SCALAR);
	LEAVE;
	SPAGAIN;
	sv = POPs;
	SP = ORIGMARK;
	PUSHs(sv);
	RETURN;
    }
    if (!gv)
	goto say_undef;
    bufsv = *++MARK;
#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))
	    report_evil_fh(gv, io, PL_op->op_type);
	goto say_undef;
    }

    if (PerlIO_isutf8(IoIFP(io))) {
	buffer = SvPVutf8(bufsv, blen);
    }
    else {
	if (DO_UTF8(bufsv))
	    sv_utf8_downgrade(bufsv, FALSE);
	buffer = SvPV(bufsv, blen);
    }

    if (PL_op->op_type == OP_SYSWRITE) {
	IV offset;
	if (DO_UTF8(bufsv)) {
	    /* length and offset are in chars */
	    blen   = sv_len_utf8(bufsv);
	}
	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;
	if (DO_UTF8(bufsv)) {
	    buffer = (char*)utf8_hop((U8 *)buffer, offset);
	    length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
	}
	else {
	    buffer = buffer+offset;
	}
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
	if (IoTYPE(io) == IoTYPE_SOCKET) {
	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
				   buffer, length, 0);
	}
	else
#endif
	{
	    /* See the note at doio.c:do_print about filesize limits. --jhi */
	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
				   buffer, length);
	}
    }
#ifdef HAS_SOCKET
    else if (SP > MARK) {
	char *sockbuf;
	STRLEN mlen;
	sockbuf = SvPVx(*++MARK, mlen);
	/* length is really flags */
	retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
				 length, (struct sockaddr *)sockbuf, mlen);
    }
    else
	/* length is really flags */
	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 (DO_UTF8(bufsv))
        retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
#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)
{
    dSP;
    GV *gv;
    IO *io;
    MAGIC *mg;

    if (MAXARG == 0) {
	if (PL_op->op_flags & OPf_SPECIAL) {	/* eof() */
	    IO *io;
	    gv = PL_last_in_gv = GvEGV(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 && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, mg));
	PUTBACK;
	ENTER;
	call_method("EOF", G_SCALAR);
	LEAVE;
	SPAGAIN;
	RETURN;
    }

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

PP(pp_tell)
{
    dSP; dTARGET;
    GV *gv;
    IO *io;
    MAGIC *mg;

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

    if (gv && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, 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)
{
    dSP;
    GV *gv;
    IO *io;
    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 && (io = GvIO(gv))
	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
    {
	PUSHMARK(SP);
	XPUSHs(SvTIED_obj((SV*)io, mg));
#if LSEEKSIZE > IVSIZE
	XPUSHs(sv_2mortal(newSVnv((NV) offset)));
#else
	XPUSHs(sv_2mortal(newSViv(offset)));
#endif
	XPUSHs(sv_2mortal(newSViv(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 sought = do_sysseek(gv, offset, whence);
        if (sought < 0)
            PUSHs(&PL_sv_undef);
        else {
            SV* sv = sought ?
#if LSEEKSIZE > IVSIZE
                newSVnv((NV)sought)
#else
                newSViv(sought)
#endif
                : newSVpvn(zero_but_true, ZBTLEN);
            PUSHs(sv_2mortal(sv));
        }
    }
    RETURN;
}

PP(pp_truncate)
{
    dSP;
    /* 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;

#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)
    {
        STRLEN n_a;
	int result = 1;
	GV *tmpgv;
	
	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;
	
	    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)
{
    dSP; dTARGET;
    SV *argsv = POPs;
    unsigned int func = POPu;
    int optype = PL_op->op_type;
    char *s;
    IV retval;
    GV *gv = (GV*)POPs;
    IO *io = gv ? GvIOn(gv) : 0;

    if (!io || !argsv || !IoIFP(io)) {
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	    report_evil_fh(gv, io, PL_op->op_type);
	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",
		OP_NAME(PL_op));
	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)
{
#ifdef FLOCK
    dSP; dTARGET;
    I32 value;
    int argtype;
    GV *gv;
    IO *io = NULL;
    PerlIO *fp;

    argtype = POPi;
    if (MAXARG == 0)
	gv = PL_last_in_gv;
    else
	gv = (GV*)POPs;
    if (gv && (io = GvIO(gv)))
	fp = IoIFP(io);
    else {
	fp = Nullfp;
	io = NULL;
    }
    if (fp) {
	(void)PerlIO_flush(fp);
	value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
    }
    else {
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	    report_evil_fh(gv, io, PL_op->op_type);
	value = 0;
	SETERRNO(EBADF,RMS$_IFI);
    }
    PUSHi(value);
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "flock()");
#endif
}

/* Sockets. */

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

    gv = (GV*)POPs;
    io = gv ? GvIOn(gv) : NULL;

    if (!gv || !io) {
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
	    report_evil_fh(gv, io, PL_op->op_type);
	if (IoIFP(io))
	    do_close(gv, FALSE);
	SETERRNO(EBADF,LIB$_INVARG);
	RETPUSHUNDEF;
    }

    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) = IoTYPE_SOCKET;
    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

#ifdef EPOC
    setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
#endif

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

PP(pp_sockpair)
{
#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
    dSP;
    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;
    io1 = gv1 ? GvIOn(gv1) : NULL;
    io2 = gv2 ? GvIOn(gv2) : NULL;
    if (!gv1 || !gv2 || !io1 || !io2) {
	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
	    if (!gv1 || !io1)
		report_evil_fh(gv1, io1, PL_op->op_type);
	    if (!gv2 || !io2)
		report_evil_fh(gv1, io2, PL_op->op_type);
	}
	if (IoIFP(io1))
	    do_close(gv1, FALSE);
	if (IoIFP(io2))
	    do_close(gv2, FALSE);
	RETPUSHUNDEF;
    }

    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) = IoTYPE_SOCKET;
    IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
    IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
    IoTYPE(io2) = IoTYPE_SOCKET;
    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)
{
#ifdef HAS_SOCKET
    dSP;
#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
    extern void GETPRIVMODE();
    extern void 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_evil_fh(gv, io, PL_op->op_type);
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "bind");
#endif
}

PP(pp_connect)
{
#ifdef HAS_SOCKET
    dSP;
    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_evil_fh(gv, io, PL_op->op_type);
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "connect");
#endif
}

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

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

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

nuts:
    if (ckWARN(WARN_CLOSED))
	report_evil_fh(gv, io, PL_op->op_type);
    SETERRNO(EBADF,SS$_IVCHAN);
    RETPUSHUNDEF;
#else
    DIE(aTHX_ PL_no_sock_func, "listen");
#endif
}

PP(pp_accept)
{
#ifdef HAS_SOCKET
    dSP; dTARGET;
    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;
    int fd2;

    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);
    fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
    if (fd < 0)
	goto badexit;
    if (IoIFP(nstio))
	do_close(ngv, FALSE);
    IoIFP(nstio) = PerlIO_fdopen(fd, "r");
    /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
       fclose of IoOFP's FILE * - and hence leak memory.
       Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
     */
    IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
    IoTYPE(nstio) = IoTYPE_SOCKET;
    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 */
    fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd);	/* ensure close-on-exec */
#endif

#ifdef EPOC
    len = sizeof saddr;          /* EPOC somehow truncates info */
    setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
#endif

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

nuts:
    if (ckWARN(WARN_CLOSED))
	report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
    SETERRNO(EBADF,SS$_IVCHAN);

badexit:
    RETPUSHUNDEF;

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

PP(pp_shutdown)
{
#ifdef HAS_SOCKET
    dSP; dTARGET;
    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_evil_fh(gv, io, PL_op->op_type);
    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)
{
#ifdef HAS_SOCKET
    dSP;
    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_evil_fh(gv, io, optype);
    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)
{
#ifdef HAS_SOCKET
    dSP;
    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_evil_fh(gv, io, optype);
    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)
{
    dSP;
    GV *gv;
    I32 gimme;
    I32 max = 13;
    STRLEN n_a;

    if (PL_op->op_flags & OPf_REF) {
	gv = cGVOP_gv;
	if (PL_op->op_type == OP_LSTAT) {
	    if (gv != PL_defgv) {
		if (ckWARN(WARN_IO))
		    Perl_warner(aTHX_ WARN_IO,
			"lstat() on filehandle %s", GvENAME(gv));
	    } else if (PL_laststype != OP_LSTAT)
		Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
	}

      do_fstat:
	if (gv != PL_defgv) {
	    PL_laststype = OP_STAT;
	    PL_statgv = gv;
	    sv_setpv(PL_statname, "");
	    PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
		? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
	}
	if (PL_laststatval < 0) {
	    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
		report_evil_fh(gv, GvIO(gv), PL_op->op_type);
	    max = 0;
	}
    }
    else {
	SV* sv = POPs;
	if (SvTYPE(sv) == SVt_PVGV) {
	    gv = (GV*)sv;
	    goto do_fstat;
	}
	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
	    gv = (GV*)SvRV(sv);
	    if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
		Perl_warner(aTHX_ WARN_IO,
			"lstat() on filehandle %s", GvENAME(gv));
	    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(newSVuv(PL_statcache.st_mode)));
	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
#if Uid_t_size > IVSIZE
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
#else
#   if Uid_t_sign <= 0
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
#   else
	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
#   endif
#endif
#if Gid_t_size > IVSIZE
	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
#else
#   if Gid_t_sign <= 0
	PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
#   else
	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
#   endif
#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(newSVuv(PL_statcache.st_blksize)));
	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
#else
	PUSHs(sv_2mortal(newSVpvn("", 0)));
	PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
    }
    RETURN;
}

PP(pp_ftrread)
{
    I32 result;
    dSP;
#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;
    dSP;
#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;
    dSP;
#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;
    dSP;
#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;
    dSP;
#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;
    dSP;
#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();
    dSP;
    if (result < 0)
	RETPUSHUNDEF;
    RETPUSHYES;
}

PP(pp_fteowned)
{
    return pp_ftrowned();
}

PP(pp_ftrowned)
{
    I32 result = my_stat();
    dSP;
    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();
    dSP;
    if (result < 0)
	RETPUSHUNDEF;
    if (PL_statcache.st_size == 0)
	RETPUSHYES;
    RETPUSHNO;
}

PP(pp_ftsize)
{
    I32 result = my_stat();
    dSP; 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();
    dSP; dTARGET;
    if (result < 0)
	RETPUSHUNDEF;
    PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
    RETURN;
}

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

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

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

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

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

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

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

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

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

PP(pp_ftsuid)
{
    dSP;
#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)
{
    dSP;
#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)
{
    dSP;
#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)
{
    dSP;
    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)
{
    dSP;
    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 (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
		gv = cGVOP_gv;
		report_evil_fh(gv, GvIO(gv), PL_op->op_type);
	    }
	    SETERRNO(EBADF,RMS$_IFI);
	    RETPUSHUNDEF;
	}
    }
    else {
	sv = POPs;
      really_filename:
	PL_statgv = Nullgv;
	PL_laststatval = -1;
	PL_laststype = OP_STAT;
	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;
	}
	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
	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 (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
		continue;
#endif
	    /* utf8 characters don't count as odd */
	    if (UTF8_IS_START(*s)) {
		int ulen = UTF8SKIP(s);
		if (ulen < len - i) {
		    int j;
		    for (j = 1; j < ulen; j++) {
			if (!UTF8_IS_CONTINUATION(s[j]))
			    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)
{
    dSP; dTARGET;
    char *tmps;
    SV **svp;
    STRLEN n_a;

    if( MAXARG == 1 )
        tmps = POPpx;
    else
        tmps = 0;

    if( !tmps || !*tmps ) {
        if (    (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
             || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
#ifdef VMS
             || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
#endif
           )
        {
            if( MAXARG == 1 )
                deprecate_old("chdir('') or chdir(undef) as chdir()");
            tmps = SvPV(*svp, n_a);
        }
        else {
            PUSHi(0);
            TAINT_PROPER("chdir");
            RETURN;
        }
    }

    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)
{
#ifdef HAS_CHOWN
    dSP; dMARK; dTARGET;
    I32 value = (I32)apply(PL_op->op_type, MARK, SP);

    SP = MARK;
    PUSHi(value);
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "chown");
#endif
}

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

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

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

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

PP(pp_rename)
{
    dSP; 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)
{
#ifdef HAS_LINK
    dSP; dTARGET;
    STRLEN n_a;
    char *tmps2 = POPpx;
    char *tmps = SvPV(TOPs, n_a);
    TAINT_PROPER("link");
    SETi( PerlLIO_link(tmps, tmps2) >= 0 );
    RETURN;
#else
    DIE(aTHX_ PL_no_func, "link");
#endif
}