[perl5.git] / ext / VMS-Stdio / Stdio.xs

/* VMS::Stdio - VMS extensions to stdio routines 
 *
 * Author:   Charles Bailey  bailey@newman.upenn.edu
 *
 */

/* We now depend on handy.h macros that are not public API. */
#define PERL_EXT

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <file.h>
#include <iodef.h>
#include <rms.h>
#include <starlet.h>

static bool
constant(char *name, IV *pval)
{
    if (! strBEGINs(name, "O_")) return FALSE;

    if (strEQ(name, "O_APPEND"))
#ifdef O_APPEND
	{ *pval = O_APPEND; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_CREAT"))
#ifdef O_CREAT
	{ *pval = O_CREAT; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_EXCL"))
#ifdef O_EXCL
	{ *pval = O_EXCL; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_NDELAY"))
#ifdef O_NDELAY
	{ *pval = O_NDELAY; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_NOWAIT"))
#ifdef O_NOWAIT
	{ *pval = O_NOWAIT; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_RDONLY"))
#ifdef O_RDONLY
	{ *pval = O_RDONLY; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_RDWR"))
#ifdef O_RDWR
	{ *pval = O_RDWR; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_TRUNC"))
#ifdef O_TRUNC
	{ *pval = O_TRUNC; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_WRONLY"))
#ifdef O_WRONLY
	{ *pval = O_WRONLY; return TRUE; }
#else
	return FALSE;
#endif

    return FALSE;
}


static SV *
newFH(PerlIO *fp, char type) {
    SV *rv;
    GV **stashp, *gv = (GV *)newSV(0);
    HV *stash;
    IO *io;

    /* Find stash for VMS::Stdio.  We don't do this once at boot
     * to allow for possibility of threaded Perl with per-thread
     * symbol tables.  This code (through io = ...) is really
     * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
     * with a little less overhead, and good exercise for me. :-) */
    stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
    if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
    if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
    stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
    if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
    if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();

    /* Set up GV to point to IO, and then take reference */
    gv_init(gv,stash,"__FH__",6,0);
    io = GvIOp(gv) = newIO();
    IoIFP(io) = fp;
    if (type != '<') IoOFP(io) = fp;
    IoTYPE(io) = type;
    rv = newRV((SV *)gv);
    SvREFCNT_dec(gv);
    return sv_bless(rv,stash);
}

MODULE = VMS::Stdio  PACKAGE = VMS::Stdio

void
constant(name)
	char *	name
	PROTOTYPE: $
	CODE:
	IV i;
	if (constant(name, &i))
	    ST(0) = sv_2mortal(newSViv(i));
	else
	    ST(0) = &PL_sv_undef;

void
binmode(fh)
	SV *	fh
	PROTOTYPE: $
	CODE:
           SV *name;
	   IO *io;
	   char iotype;
	   char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = NULL;
	   int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
           SV pos;
           PerlIO *fp;
	   io = sv_2io(fh);
           fp = io ? IoOFP(io) : NULL;
	   iotype = io ? IoTYPE(io) : '\0';
	    if (fp == NULL || strchr(">was+-|",iotype) == NULL) {
	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
	    }
           if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
	    for (s = filespec; *s; s++) {
	      if (*s == ':') colon = s;
	      else if (*s == ']' || *s == '>') dirend = s;
	    }
	    /* Looks like a tmpfile, which will go away if reopened */
	    if (s == dirend + 3) {
	      set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
	    }
	    /* If we've got a non-file-structured device, clip off the trailing
	     * junk, and don't lose sleep if we can't get a stream position.  */
	    if (dirend == NULL) *(colon+1) = '\0'; 
           if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
	      XSRETURN_UNDEF;
	    switch (iotype) {
	      case '<': case 'r':           acmode = "rb";                      break;
	      case '>': case 'w': case '|':
	        /* use 'a' instead of 'w' to avoid creating new file;
	           fsetpos below will take care of restoring file position */
	      case 'a':                     acmode = "ab";                      break;
	      case '+':  case 's':          acmode = "rb+";                     break;
             case '-':                     acmode = PerlIO_fileno(fp) ? "ab" : "rb";  break;
	      /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
	      /* since we didn't really open them and can't really */
	      /* reopen them */
	      case 0:                       XSRETURN_UNDEF;
	      default:
	        if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
	                         iotype, filespec);
	        acmode = "rb+";
	    }
           /* appearances to the contrary, this is an freopen substitute */
           name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
           if (PerlIO_openn(aTHX_ NULL,acmode,-1,0,0,fp,1,&name) == NULL) XSRETURN_UNDEF;
           if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
	    if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
	    XSRETURN_YES;


void
flush(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
           else            { clearerr(stdio); ST(0) = &PL_sv_yes; }
           PerlIO_releaseFILE(fp,stdio);

char *
getname(fp)
	PerlIO * fp
	PROTOTYPE: $
	CODE:
            FILE *stdio = PerlIO_exportFILE(fp,0);
	    char fname[NAM$C_MAXRSS+1];
	    ST(0) = sv_newmortal();
            if (fgetname(stdio,fname) != NULL) sv_setpv(ST(0),fname);
            PerlIO_releaseFILE(fp,stdio);

void
rewind(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
           PerlIO_releaseFILE(fp,stdio);

void
remove(name)
	char *name
	PROTOTYPE: $
	CODE:
	    ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;

void
setdef(...)
	PROTOTYPE: @
	CODE:
	    char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
	    unsigned long int retsts;
	    struct FAB deffab = cc$rms_fab;
	    struct NAM defnam = cc$rms_nam;
	    struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	    STRLEN n_a;
	    if (items) {
		SV *defsv = ST(items-1);  /* mimic chdir() */
		ST(0) = &PL_sv_undef;
		if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
		if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); }
		deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
	    }
	    else {
		deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
		EXTEND(sp,1);  ST(0) = &PL_sv_undef;
	    }
	    defnam.nam$l_esa = es;  defnam.nam$b_ess = sizeof es;
	    deffab.fab$l_nam = &defnam;
	    retsts = sys$parse(&deffab,0,0);
	    if (retsts & 1) {
		if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
		else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
	             defnam.nam$b_ver > 1) retsts = RMS$_DIR;
		}
	    defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
	    if (!(retsts & 1)) {
		set_vaxc_errno(retsts);
		switch (retsts) {
		    case RMS$_DNF:
			set_errno(ENOENT); break;
		    case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
			set_errno(EINVAL); break;
		    case RMS$_PRV:
			set_errno(EACCES); break;
		    default:
			set_errno(EVMSERR); break;
		}
		(void) sys$parse(&deffab,0,0);  /* free up context */
		XSRETURN(1);
	    }
	    sep = *defnam.nam$l_dir;
	    *defnam.nam$l_dir = '\0';
	    my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
	    *defnam.nam$l_dir = sep;
	    dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
	    if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes;
	    else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
	    (void) sys$parse(&deffab,0,0);  /* free up context */

void
sync(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
           else                   { clearerr(stdio); ST(0) = &PL_sv_yes; }
           PerlIO_releaseFILE(fp,stdio);

char *
tmpnam()
	PROTOTYPE:
	CODE:
	    char fname[L_tmpnam];
	    ST(0) = sv_newmortal();
	    if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);

void
vmsopen(spec,...)
	char *	spec
	PROTOTYPE: @
	CODE:
	    char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
	    int i, myargc;
	    FILE *fp;
            SV *fh;
           PerlIO *pio_fp;
	    STRLEN n_a;
	
	    if (!spec || !*spec) {
	       SETERRNO(EINVAL,LIB$_INVARG);
	       XSRETURN_UNDEF;
	    }
	    if (items > 9) croak("too many args");
	
	    /* First, set up name and mode args from perl's string */
	    if (*spec == '+') {
	      mode[1] = '+';
	      spec++;
	    }
	    if (*spec == '>') {
	      if (*(spec+1) == '>') *mode = 'a', spec += 2;
	      else *mode = 'w',  spec++;
	    }
	    else if (*spec == '<') spec++;
	    myargc = items - 1;
	    for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a);
	    /* This hack brought to you by C's opaque arglist management */
	    switch (myargc) {
	      case 0:
	        fp = fopen(spec,mode);
	        break;
	      case 1:
	        fp = fopen(spec,mode,args[0]);
	        break;
	      case 2:
	        fp = fopen(spec,mode,args[0],args[1]);
	        break;
	      case 3:
	        fp = fopen(spec,mode,args[0],args[1],args[2]);
	        break;
	      case 4:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
	        break;
	      case 5:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
	        break;
	      case 6:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
	        break;
	      case 7:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	        break;
	      case 8:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	        break;
	    }
	    if (fp != NULL) {
             pio_fp = PerlIO_fdopen(fileno(fp),mode);
             fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
	     ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
	    }
	    else { ST(0) = &PL_sv_undef; }

void
vmssysopen(spec,mode,perm,...)
	char *	spec
	int	mode
	int	perm
	PROTOTYPE: @
	CODE:
	    char *args[8];
	    int i, myargc, fd;
	    PerlIO *pio_fp;
	    SV *fh;
	    STRLEN n_a;
	    if (!spec || !*spec) {
	       SETERRNO(EINVAL,LIB$_INVARG);
	       XSRETURN_UNDEF;
	    }
	    if (items > 11) croak("too many args");
	    myargc = items - 3;
	    for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a);
	    /* More fun with C calls; can't combine with above because
	       args 2,3 of different types in fopen() and open() */
	    switch (myargc) {
	      case 0:
	        fd = open(spec,mode,perm);
	        break;
	      case 1:
	        fd = open(spec,mode,perm,args[0]);
	        break;
	      case 2:
	        fd = open(spec,mode,perm,args[0],args[1]);
	        break;
	      case 3:
	        fd = open(spec,mode,perm,args[0],args[1],args[2]);
	        break;
	      case 4:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
	        break;
	      case 5:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
	        break;
	      case 6:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
	        break;
	      case 7:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	        break;
	      case 8:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	        break;
	    }
	    i = mode & 3;
	    if (fd >= 0 &&
              ((pio_fp = PerlIO_fdopen(fd, &("r\000w\000r+"[2*i]))) != NULL)) {
             fh = newFH(pio_fp,"<>++"[i]);
	     ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
	    }
	    else { ST(0) = &PL_sv_undef; }

void
waitfh(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
           PerlIO_releaseFILE(fp,stdio);

void
writeof(mysv)
	SV *	mysv
	PROTOTYPE: $
	CODE:
	    char devnam[257], *cp;
	    unsigned long int chan, iosb[2], retsts, retsts2;
	    struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
	    IO *io = sv_2io(mysv);
           PerlIO *fp = io ? IoOFP(io) : NULL;
	    if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == NULL) {
	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
	    }
           if (PerlIO_getname(fp,devnam) == NULL) { ST(0) = &PL_sv_undef; XSRETURN(1); }
	    if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
	    devdsc.dsc$w_length = strlen(devnam);
	    retsts = sys$assign(&devdsc,&chan,0,0);
	    if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
	    if (retsts & 1) retsts = iosb[0];
	    retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
	    if (retsts & 1) retsts = retsts2;
	    if (retsts & 1) { ST(0) = &PL_sv_yes; }
	    else {
	      set_vaxc_errno(retsts);
	      switch (retsts) {
	        case SS$_EXQUOTA:  case SS$_INSFMEM:  case SS$_MBFULL:
	        case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
	        case SS$_BUFFEROVF:
	          set_errno(ENOSPC); break;
	        case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
	          set_errno(EBADF);  break;
	        case SS$_NOPRIV:
	          set_errno(EACCES); break;
	        default:  /* Includes "shouldn't happen" cases that might map */
	          set_errno(EVMSERR); break;         /* to other errno values */
	      }
	      ST(0) = &PL_sv_undef;
	    }
Commit	Line	Data
2ae00b68	1	/* VMS::Stdio - VMS extensions to stdio routines
748a9306	2	*
562a7b0c	3	* Author: Charles Bailey bailey@newman.upenn.edu
748a9306	4	*
748a9306 LW	5	*/
748a9306 LW	6
652712ce CB	7	/* We now depend on handy.h macros that are not public API. */
	8	#define PERL_EXT
	9
748a9306 LW	10	#include "EXTERN.h"
	11	#include "perl.h"
	12	#include "XSUB.h"
2ae00b68	13	#include <file.h>
17f28c40 CB	14	#include <iodef.h>
	15	#include <rms.h>
	16	#include <starlet.h>
2ae00b68	17
2ae00b68	18	static bool
b626ecd9	19	constant(char name, IV pval)
2ae00b68	20	{
f55ac4a4	21	if (! strBEGINs(name, "O_")) return FALSE;
2ae00b68	22
	23	if (strEQ(name, "O_APPEND"))
	24	#ifdef O_APPEND
	25	{ *pval = O_APPEND; return TRUE; }
	26	#else
	27	return FALSE;
	28	#endif
	29	if (strEQ(name, "O_CREAT"))
	30	#ifdef O_CREAT
	31	{ *pval = O_CREAT; return TRUE; }
	32	#else
	33	return FALSE;
	34	#endif
	35	if (strEQ(name, "O_EXCL"))
	36	#ifdef O_EXCL
	37	{ *pval = O_EXCL; return TRUE; }
	38	#else
	39	return FALSE;
	40	#endif
	41	if (strEQ(name, "O_NDELAY"))
	42	#ifdef O_NDELAY
	43	{ *pval = O_NDELAY; return TRUE; }
	44	#else
	45	return FALSE;
	46	#endif
	47	if (strEQ(name, "O_NOWAIT"))
	48	#ifdef O_NOWAIT
	49	{ *pval = O_NOWAIT; return TRUE; }
	50	#else
	51	return FALSE;
	52	#endif
	53	if (strEQ(name, "O_RDONLY"))
	54	#ifdef O_RDONLY
	55	{ *pval = O_RDONLY; return TRUE; }
	56	#else
	57	return FALSE;
	58	#endif
	59	if (strEQ(name, "O_RDWR"))
	60	#ifdef O_RDWR
	61	{ *pval = O_RDWR; return TRUE; }
	62	#else
	63	return FALSE;
	64	#endif
	65	if (strEQ(name, "O_TRUNC"))
	66	#ifdef O_TRUNC
	67	{ *pval = O_TRUNC; return TRUE; }
	68	#else
	69	return FALSE;
	70	#endif
	71	if (strEQ(name, "O_WRONLY"))
	72	#ifdef O_WRONLY
	73	{ *pval = O_WRONLY; return TRUE; }
	74	#else
	75	return FALSE;
	76	#endif
	77
	78	return FALSE;
	79	}
748a9306	80
748a9306	81
2ae00b68	82	static SV *
a15cef0c	83	newFH(PerlIO *fp, char type) {
55497cff	84	SV *rv;
561b68a9	85	GV *stashp, gv = (GV *)newSV(0);
2ae00b68	86	HV *stash;
	87	IO *io;
	88
	89	/* Find stash for VMS::Stdio. We don't do this once at boot
	90	* to allow for possibility of threaded Perl with per-thread
	91	* symbol tables. This code (through io = ...) is really
	92	* equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
	93	* with a little less overhead, and good exercise for me. :-) */
a26fecbb	94	stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
4e205ed6	95	if (!stashp \|\| stashp == (GV )&PL_sv_undef) return NULL;
2ae00b68	96	if (!(stash = GvHV(stashp))) stash = GvHV(stashp) = newHV();
a26fecbb	97	stashp = (GV *)hv_fetch(GvHV(stashp),"Stdio::",7,TRUE);
4e205ed6	98	if (!stashp \|\| stashp == (GV )&PL_sv_undef) return NULL;
2ae00b68	99	if (!(stash = GvHV(stashp))) stash = GvHV(stashp) = newHV();
	100
	101	/* Set up GV to point to IO, and then take reference */
	102	gv_init(gv,stash,"__FH__",6,0);
	103	io = GvIOp(gv) = newIO();
	104	IoIFP(io) = fp;
5f05dabc	105	if (type != '<') IoOFP(io) = fp;
2ae00b68	106	IoTYPE(io) = type;
55497cff	107	rv = newRV((SV *)gv);
2ae00b68	108	SvREFCNT_dec(gv);
	109	return sv_bless(rv,stash);
	110	}
	111
	112	MODULE = VMS::Stdio PACKAGE = VMS::Stdio
748a9306 LW	113
748a9306 LW	114	void
2ae00b68	115	constant(name)
748a9306	116	char * name
2ae00b68	117	PROTOTYPE: $
	118	CODE:
	119	IV i;
	120	if (constant(name, &i))
	121	ST(0) = sv_2mortal(newSViv(i));
	122	else
6b88bc9c	123	ST(0) = &PL_sv_undef;
2ae00b68	124
2ae00b68	125	void
562a7b0c CB	126	binmode(fh)
	127	SV * fh
	128	PROTOTYPE: $
	129	CODE:
493ba88a PP	130	SV *name;
	131	IO *io;
	132	char iotype;
4e205ed6	133	char filespec[NAM$C_MAXRSS], acmode, s, colon, dirend = NULL;
493ba88a	134	int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
a15cef0c	135	SV pos;
493ba88a PP	136	PerlIO *fp;
	137	io = sv_2io(fh);
	138	fp = io ? IoOFP(io) : NULL;
	139	iotype = io ? IoTYPE(io) : '\0';
4e205ed6	140	if (fp == NULL \|\| strchr(">was+-\|",iotype) == NULL) {
562a7b0c CB	141	set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
562a7b0c CB	142	}
a15cef0c	143	if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
562a7b0c CB	144	for (s = filespec; *s; s++) {
	145	if (*s == ':') colon = s;
	146	else if (s == ']' \|\| s == '>') dirend = s;
	147	}
	148	/* Looks like a tmpfile, which will go away if reopened */
	149	if (s == dirend + 3) {
	150	set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
	151	}
	152	/* If we've got a non-file-structured device, clip off the trailing
	153	* junk, and don't lose sleep if we can't get a stream position. */
4e205ed6	154	if (dirend == NULL) *(colon+1) = '\0';
a15cef0c	155	if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
562a7b0c CB	156	XSRETURN_UNDEF;
	157	switch (iotype) {
	158	case '<': case 'r': acmode = "rb"; break;
	159	case '>': case 'w': case '\|':
	160	/* use 'a' instead of 'w' to avoid creating new file;
	161	fsetpos below will take care of restoring file position */
	162	case 'a': acmode = "ab"; break;
	163	case '+': case 's': acmode = "rb+"; break;
a15cef0c	164	case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb"; break;
562a7b0c CB	165	/* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
	166	/* since we didn't really open them and can't really */
	167	/* reopen them */
	168	case 0: XSRETURN_UNDEF;
	169	default:
	170	if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
	171	iotype, filespec);
	172	acmode = "rb+";
	173	}
a15cef0c	174	/* appearances to the contrary, this is an freopen substitute */
493ba88a	175	name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
4e205ed6	176	if (PerlIO_openn(aTHX_ NULL,acmode,-1,0,0,fp,1,&name) == NULL) XSRETURN_UNDEF;
a15cef0c	177	if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
562a7b0c CB	178	if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
	179	XSRETURN_YES;
	180
	181
	182	void
17f28c40	183	flush(fp)
a15cef0c	184	PerlIO * fp
2ae00b68	185	PROTOTYPE: $
2ae00b68	186	CODE:
a15cef0c CB	187	FILE *stdio = PerlIO_exportFILE(fp,0);
	188	if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
	189	else { clearerr(stdio); ST(0) = &PL_sv_yes; }
	190	PerlIO_releaseFILE(fp,stdio);
2ae00b68	191
	192	char *
	193	getname(fp)
7f8ddb16	194	PerlIO * fp
2ae00b68	195	PROTOTYPE: $
2ae00b68	196	CODE:
7f8ddb16	197	FILE *stdio = PerlIO_exportFILE(fp,0);
17f28c40	198	char fname[NAM$C_MAXRSS+1];
2ae00b68	199	ST(0) = sv_newmortal();
7f8ddb16	200	if (fgetname(stdio,fname) != NULL) sv_setpv(ST(0),fname);
b89086ac	201	PerlIO_releaseFILE(fp,stdio);
2ae00b68	202
	203	void
	204	rewind(fp)
a15cef0c	205	PerlIO * fp
2ae00b68	206	PROTOTYPE: $
2ae00b68	207	CODE:
a15cef0c CB	208	FILE *stdio = PerlIO_exportFILE(fp,0);
	209	ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
	210	PerlIO_releaseFILE(fp,stdio);
2ae00b68	211
	212	void
	213	remove(name)
	214	char *name
	215	PROTOTYPE: $
	216	CODE:
6b88bc9c	217	ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;
2ae00b68	218
2ae00b68	219	void
17f28c40 CB	220	setdef(...)
	221	PROTOTYPE: @
	222	CODE:
	223	char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
	224	unsigned long int retsts;
	225	struct FAB deffab = cc$rms_fab;
	226	struct NAM defnam = cc$rms_nam;
	227	struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2d8e6c8d	228	STRLEN n_a;
17f28c40 CB	229	if (items) {
17f28c40 CB	230	SV defsv = ST(items-1); / mimic chdir() */
6b88bc9c	231	ST(0) = &PL_sv_undef;
17f28c40	232	if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
2d8e6c8d	233	if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); }
17f28c40 CB	234	deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
	235	}
	236	else {
	237	deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
6b88bc9c	238	EXTEND(sp,1); ST(0) = &PL_sv_undef;
17f28c40 CB	239	}
	240	defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es;
	241	deffab.fab$l_nam = &defnam;
	242	retsts = sys$parse(&deffab,0,0);
	243	if (retsts & 1) {
	244	if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
	245	else if (defnam.nam$b_name \|\| defnam.nam$b_type > 1 \|\|
	246	defnam.nam$b_ver > 1) retsts = RMS$_DIR;
	247	}
	248	defnam.nam$b_nop \|= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
	249	if (!(retsts & 1)) {
	250	set_vaxc_errno(retsts);
	251	switch (retsts) {
	252	case RMS$_DNF:
	253	set_errno(ENOENT); break;
	254	case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
	255	set_errno(EINVAL); break;
	256	case RMS$_PRV:
	257	set_errno(EACCES); break;
	258	default:
	259	set_errno(EVMSERR); break;
	260	}
	261	(void) sys$parse(&deffab,0,0); /* free up context */
	262	XSRETURN(1);
	263	}
	264	sep = *defnam.nam$l_dir;
	265	*defnam.nam$l_dir = '\0';
	266	my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
	267	*defnam.nam$l_dir = sep;
	268	dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
6b88bc9c	269	if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes;
17f28c40 CB	270	else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
	271	(void) sys$parse(&deffab,0,0); /* free up context */
	272
	273	void
2ae00b68	274	sync(fp)
a15cef0c	275	PerlIO * fp
2ae00b68	276	PROTOTYPE: $
2ae00b68	277	CODE:
a15cef0c CB	278	FILE *stdio = PerlIO_exportFILE(fp,0);
	279	if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
	280	else { clearerr(stdio); ST(0) = &PL_sv_yes; }
	281	PerlIO_releaseFILE(fp,stdio);
2ae00b68	282
	283	char *
	284	tmpnam()
	285	PROTOTYPE:
	286	CODE:
	287	char fname[L_tmpnam];
	288	ST(0) = sv_newmortal();
	289	if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
	290
	291	void
	292	vmsopen(spec,...)
	293	char * spec
	294	PROTOTYPE: @
748a9306	295	CODE:
2ae00b68	296	char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
5aaab254	297	int i, myargc;
748a9306	298	FILE *fp;
493ba88a	299	SV *fh;
a15cef0c	300	PerlIO *pio_fp;
2d8e6c8d	301	STRLEN n_a;
2ae00b68	302
	303	if (!spec \|\| !*spec) {
	304	SETERRNO(EINVAL,LIB$_INVARG);
	305	XSRETURN_UNDEF;
748a9306	306	}
2ae00b68	307	if (items > 9) croak("too many args");
2ae00b68	308
748a9306	309	/* First, set up name and mode args from perl's string */
2ae00b68	310	if (*spec == '+') {
748a9306	311	mode[1] = '+';
2ae00b68	312	spec++;
748a9306	313	}
2ae00b68	314	if (*spec == '>') {
	315	if ((spec+1) == '>') mode = 'a', spec += 2;
	316	else *mode = 'w', spec++;
748a9306	317	}
2ae00b68	318	else if (*spec == '<') spec++;
748a9306	319	myargc = items - 1;
2d8e6c8d	320	for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a);
748a9306 LW	321	/* This hack brought to you by C's opaque arglist management */
	322	switch (myargc) {
	323	case 0:
2ae00b68	324	fp = fopen(spec,mode);
748a9306 LW	325	break;
748a9306 LW	326	case 1:
2ae00b68	327	fp = fopen(spec,mode,args[0]);
748a9306 LW	328	break;
748a9306 LW	329	case 2:
2ae00b68	330	fp = fopen(spec,mode,args[0],args[1]);
748a9306 LW	331	break;
748a9306 LW	332	case 3:
2ae00b68	333	fp = fopen(spec,mode,args[0],args[1],args[2]);
748a9306 LW	334	break;
748a9306 LW	335	case 4:
2ae00b68	336	fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
748a9306 LW	337	break;
748a9306 LW	338	case 5:
2ae00b68	339	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
748a9306 LW	340	break;
748a9306 LW	341	case 6:
2ae00b68	342	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
748a9306 LW	343	break;
748a9306 LW	344	case 7:
2ae00b68	345	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
748a9306 LW	346	break;
748a9306 LW	347	case 8:
2ae00b68	348	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
748a9306 LW	349	break;
748a9306 LW	350	}
b9893e57	351	if (fp != NULL) {
7f8ddb16	352	pio_fp = PerlIO_fdopen(fileno(fp),mode);
493ba88a PP	353	fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
493ba88a PP	354	ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
748a9306	355	}
6b88bc9c	356	else { ST(0) = &PL_sv_undef; }
748a9306	357
2ae00b68	358	void
	359	vmssysopen(spec,mode,perm,...)
	360	char * spec
	361	int mode
	362	int perm
	363	PROTOTYPE: @
748a9306	364	CODE:
2ae00b68	365	char *args[8];
2ae00b68	366	int i, myargc, fd;
7f8ddb16	367	PerlIO *pio_fp;
2ae00b68	368	SV *fh;
2d8e6c8d	369	STRLEN n_a;
2ae00b68	370	if (!spec \|\| !*spec) {
	371	SETERRNO(EINVAL,LIB$_INVARG);
	372	XSRETURN_UNDEF;
	373	}
	374	if (items > 11) croak("too many args");
	375	myargc = items - 3;
2d8e6c8d	376	for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a);
2ae00b68	377	/* More fun with C calls; can't combine with above because
	378	args 2,3 of different types in fopen() and open() */
	379	switch (myargc) {
	380	case 0:
	381	fd = open(spec,mode,perm);
	382	break;
	383	case 1:
	384	fd = open(spec,mode,perm,args[0]);
	385	break;
	386	case 2:
	387	fd = open(spec,mode,perm,args[0],args[1]);
	388	break;
	389	case 3:
	390	fd = open(spec,mode,perm,args[0],args[1],args[2]);
	391	break;
	392	case 4:
	393	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
	394	break;
	395	case 5:
	396	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
	397	break;
	398	case 6:
	399	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
	400	break;
	401	case 7:
	402	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	403	break;
	404	case 8:
	405	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	406	break;
	407	}
	408	i = mode & 3;
	409	if (fd >= 0 &&
4e205ed6	410	((pio_fp = PerlIO_fdopen(fd, &("r\000w\000r+"[2*i]))) != NULL)) {
493ba88a PP	411	fh = newFH(pio_fp,"<>++"[i]);
493ba88a PP	412	ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
2ae00b68	413	}
6b88bc9c	414	else { ST(0) = &PL_sv_undef; }
748a9306	415
2ae00b68	416	void
2ae00b68	417	waitfh(fp)
a15cef0c	418	PerlIO * fp
2ae00b68	419	PROTOTYPE: $
748a9306	420	CODE:
a15cef0c CB	421	FILE *stdio = PerlIO_exportFILE(fp,0);
	422	ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
	423	PerlIO_releaseFILE(fp,stdio);
17f28c40 CB	424
	425	void
	426	writeof(mysv)
	427	SV * mysv
	428	PROTOTYPE: $
	429	CODE:
	430	char devnam[257], *cp;
	431	unsigned long int chan, iosb[2], retsts, retsts2;
	432	struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
	433	IO *io = sv_2io(mysv);
a15cef0c	434	PerlIO *fp = io ? IoOFP(io) : NULL;
4e205ed6	435	if (fp == NULL \|\| strchr(">was+-\|",IoTYPE(io)) == NULL) {
562a7b0c	436	set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
17f28c40	437	}
4e205ed6	438	if (PerlIO_getname(fp,devnam) == NULL) { ST(0) = &PL_sv_undef; XSRETURN(1); }
17f28c40 CB	439	if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
	440	devdsc.dsc$w_length = strlen(devnam);
	441	retsts = sys$assign(&devdsc,&chan,0,0);
	442	if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
	443	if (retsts & 1) retsts = iosb[0];
	444	retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
	445	if (retsts & 1) retsts = retsts2;
6b88bc9c	446	if (retsts & 1) { ST(0) = &PL_sv_yes; }
17f28c40 CB	447	else {
	448	set_vaxc_errno(retsts);
	449	switch (retsts) {
	450	case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL:
	451	case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
	452	case SS$_BUFFEROVF:
	453	set_errno(ENOSPC); break;
	454	case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
	455	set_errno(EBADF); break;
	456	case SS$_NOPRIV:
	457	set_errno(EACCES); break;
	458	default: /* Includes "shouldn't happen" cases that might map */
	459	set_errno(EVMSERR); break; /* to other errno values */
	460	}
6b88bc9c	461	ST(0) = &PL_sv_undef;
17f28c40	462	}