[p5sagit/p5-mst-13.2.git] / vms / ext / Stdio / Stdio.xs

/* VMS::Stdio - VMS extensions to stdio routines 
 *
 * Version:  2.1
 * Author:   Charles Bailey  bailey@genetics.upenn.edu
 * Revised:  24-Mar-1998
 *
 */

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

static bool
constant(name, pval)
char *name;
IV *pval;
{
    if (strnNE(name, "O_", 2)) 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(FILE *fp, char type) {
    SV *rv;
    GV **stashp, *gv = (GV *)NEWSV(0,0);
    HV *stash;
    IO *io;

    dTHR;
    /* 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(defstash,"VMS::",5,TRUE);
    if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
    if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
    stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
    if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
    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) = &sv_undef;

void
flush(fp)
	FILE *	fp
	PROTOTYPE: $
	CODE:
	    if (fflush(fp)) { ST(0) = &sv_undef; }
	    else            { clearerr(fp); ST(0) = &sv_yes; }

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

void
rewind(fp)
	FILE *	fp
	PROTOTYPE: $
	CODE:
	    ST(0) = rewind(fp) ? &sv_undef : &sv_yes;

void
remove(name)
	char *name
	PROTOTYPE: $
	CODE:
	    ST(0) = remove(name) ? &sv_undef : &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};
	    if (items) {
		SV *defsv = ST(items-1);  /* mimic chdir() */
		ST(0) = &sv_undef;
		if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
		if (tovmsspec(SvPV(defsv,na),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) = &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) = &sv_yes;
	    else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
	    (void) sys$parse(&deffab,0,0);  /* free up context */

void
sync(fp)
	FILE *	fp
	PROTOTYPE: $
	CODE:
	    if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
	    else                   { clearerr(fp); ST(0) = &sv_yes; }

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 = '<';
	    register int i, myargc;
	    FILE *fp;
	
	    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),na);
	    /* 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 != Nullfp) {
	      SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
	      ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
	    }
	    else { ST(0) = &sv_undef; }

void
vmssysopen(spec,mode,perm,...)
	char *	spec
	int	mode
	int	perm
	PROTOTYPE: @
	CODE:
	    char *args[8];
	    int i, myargc, fd;
	    FILE *fp;
	    SV *fh;
	    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),na);
	    /* 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 &&
	       ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
	      SV *fh = newFH(fp,"<>++"[i]);
	      ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
	    }
	    else { ST(0) = &sv_undef; }

void
waitfh(fp)
	FILE *	fp
	PROTOTYPE: $
	CODE:
	    ST(0) = fwait(fp) ? &sv_undef : &sv_yes;

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);
	    FILE *fp = io ? IoOFP(io) : NULL;
	    if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
	      ST(0) = &sv_undef;  XSRETURN(1);
	    }
	    if (fgetname(fp,devnam) == Nullch) { ST(0) = &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) = &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) = &sv_undef;
	    }
Commit	Line	Data
2ae00b68	1	/* VMS::Stdio - VMS extensions to stdio routines
748a9306	2	*
17f28c40	3	* Version: 2.1
748a9306	4	* Author: Charles Bailey bailey@genetics.upenn.edu
17f28c40	5	* Revised: 24-Mar-1998
748a9306	6	*
748a9306	7	*/
	8
	9	#include "EXTERN.h"
	10	#include "perl.h"
	11	#include "XSUB.h"
2ae00b68	12	#include <file.h>
17f28c40	13	#include <iodef.h>
	14	#include <rms.h>
	15	#include <starlet.h>
2ae00b68	16
	17	static bool
	18	constant(name, pval)
	19	char *name;
	20	IV *pval;
	21	{
	22	if (strnNE(name, "O_", 2)) return FALSE;
	23
	24	if (strEQ(name, "O_APPEND"))
	25	#ifdef O_APPEND
	26	{ *pval = O_APPEND; return TRUE; }
	27	#else
	28	return FALSE;
	29	#endif
	30	if (strEQ(name, "O_CREAT"))
	31	#ifdef O_CREAT
	32	{ *pval = O_CREAT; return TRUE; }
	33	#else
	34	return FALSE;
	35	#endif
	36	if (strEQ(name, "O_EXCL"))
	37	#ifdef O_EXCL
	38	{ *pval = O_EXCL; return TRUE; }
	39	#else
	40	return FALSE;
	41	#endif
	42	if (strEQ(name, "O_NDELAY"))
	43	#ifdef O_NDELAY
	44	{ *pval = O_NDELAY; return TRUE; }
	45	#else
	46	return FALSE;
	47	#endif
	48	if (strEQ(name, "O_NOWAIT"))
	49	#ifdef O_NOWAIT
	50	{ *pval = O_NOWAIT; return TRUE; }
	51	#else
	52	return FALSE;
	53	#endif
	54	if (strEQ(name, "O_RDONLY"))
	55	#ifdef O_RDONLY
	56	{ *pval = O_RDONLY; return TRUE; }
	57	#else
	58	return FALSE;
	59	#endif
	60	if (strEQ(name, "O_RDWR"))
	61	#ifdef O_RDWR
	62	{ *pval = O_RDWR; return TRUE; }
	63	#else
	64	return FALSE;
	65	#endif
	66	if (strEQ(name, "O_TRUNC"))
	67	#ifdef O_TRUNC
	68	{ *pval = O_TRUNC; return TRUE; }
	69	#else
	70	return FALSE;
	71	#endif
	72	if (strEQ(name, "O_WRONLY"))
	73	#ifdef O_WRONLY
	74	{ *pval = O_WRONLY; return TRUE; }
	75	#else
	76	return FALSE;
	77	#endif
	78
	79	return FALSE;
80	}
748a9306	81
748a9306	82
2ae00b68	83	static SV *
2ae00b68	84	newFH(FILE *fp, char type) {
55497cff	85	SV *rv;
55497cff	86	GV *stashp, gv = (GV *)NEWSV(0,0);
2ae00b68	87	HV *stash;
	88	IO *io;
	89
ecbaadc1	90	dTHR;
2ae00b68	91	/* Find stash for VMS::Stdio. We don't do this once at boot
	92	* to allow for possibility of threaded Perl with per-thread
	93	* symbol tables. This code (through io = ...) is really
	94	* equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
	95	* with a little less overhead, and good exercise for me. :-) */
	96	stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE);
	97	if (!stashp \|\| stashp == (GV )&sv_undef) return Nullsv;
	98	if (!(stash = GvHV(stashp))) stash = GvHV(stashp) = newHV();
	99	stashp = (GV *)hv_fetch(GvHV(stashp),"Stdio::",7,TRUE);
	100	if (!stashp \|\| stashp == (GV )&sv_undef) return Nullsv;
	101	if (!(stash = GvHV(stashp))) stash = GvHV(stashp) = newHV();
	102
	103	/* Set up GV to point to IO, and then take reference */
	104	gv_init(gv,stash,"__FH__",6,0);
	105	io = GvIOp(gv) = newIO();
	106	IoIFP(io) = fp;
5f05dabc	107	if (type != '<') IoOFP(io) = fp;
2ae00b68	108	IoTYPE(io) = type;
55497cff	109	rv = newRV((SV *)gv);
2ae00b68	110	SvREFCNT_dec(gv);
	111	return sv_bless(rv,stash);
	112	}
	113
	114	MODULE = VMS::Stdio PACKAGE = VMS::Stdio
748a9306	115
748a9306	116	void
2ae00b68	117	constant(name)
748a9306	118	char * name
2ae00b68	119	PROTOTYPE: $
	120	CODE:
	121	IV i;
	122	if (constant(name, &i))
	123	ST(0) = sv_2mortal(newSViv(i));
	124	else
	125	ST(0) = &sv_undef;
	126
	127	void
17f28c40	128	flush(fp)
17f28c40	129	FILE * fp
2ae00b68	130	PROTOTYPE: $
2ae00b68	131	CODE:
ff0cee69	132	if (fflush(fp)) { ST(0) = &sv_undef; }
ff0cee69	133	else { clearerr(fp); ST(0) = &sv_yes; }
2ae00b68	134
	135	char *
	136	getname(fp)
	137	FILE * fp
	138	PROTOTYPE: $
	139	CODE:
17f28c40	140	char fname[NAM$C_MAXRSS+1];
2ae00b68	141	ST(0) = sv_newmortal();
	142	if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
	143
	144	void
	145	rewind(fp)
	146	FILE * fp
	147	PROTOTYPE: $
	148	CODE:
	149	ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
	150
	151	void
	152	remove(name)
	153	char *name
	154	PROTOTYPE: $
	155	CODE:
	156	ST(0) = remove(name) ? &sv_undef : &sv_yes;
	157
	158	void
17f28c40	159	setdef(...)
	160	PROTOTYPE: @
	161	CODE:
	162	char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
	163	unsigned long int retsts;
	164	struct FAB deffab = cc$rms_fab;
	165	struct NAM defnam = cc$rms_nam;
	166	struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	167	if (items) {
	168	SV defsv = ST(items-1); / mimic chdir() */
	169	ST(0) = &sv_undef;
	170	if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
	171	if (tovmsspec(SvPV(defsv,na),vmsdef) == NULL) { XSRETURN(1); }
	172	deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
	173	}
	174	else {
	175	deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
	176	EXTEND(sp,1); ST(0) = &sv_undef;
	177	}
	178	defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es;
	179	deffab.fab$l_nam = &defnam;
	180	retsts = sys$parse(&deffab,0,0);
	181	if (retsts & 1) {
	182	if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
	183	else if (defnam.nam$b_name \|\| defnam.nam$b_type > 1 \|\|
	184	defnam.nam$b_ver > 1) retsts = RMS$_DIR;
	185	}
	186	defnam.nam$b_nop \|= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
	187	if (!(retsts & 1)) {
	188	set_vaxc_errno(retsts);
	189	switch (retsts) {
	190	case RMS$_DNF:
	191	set_errno(ENOENT); break;
	192	case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
	193	set_errno(EINVAL); break;
	194	case RMS$_PRV:
	195	set_errno(EACCES); break;
	196	default:
	197	set_errno(EVMSERR); break;
	198	}
	199	(void) sys$parse(&deffab,0,0); /* free up context */
	200	XSRETURN(1);
	201	}
	202	sep = *defnam.nam$l_dir;
	203	*defnam.nam$l_dir = '\0';
	204	my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
	205	*defnam.nam$l_dir = sep;
	206	dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
	207	if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &sv_yes;
	208	else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
	209	(void) sys$parse(&deffab,0,0); /* free up context */
	210
	211	void
2ae00b68	212	sync(fp)
	213	FILE * fp
	214	PROTOTYPE: $
	215	CODE:
ff0cee69	216	if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
ff0cee69	217	else { clearerr(fp); ST(0) = &sv_yes; }
2ae00b68	218
	219	char *
	220	tmpnam()
	221	PROTOTYPE:
	222	CODE:
	223	char fname[L_tmpnam];
	224	ST(0) = sv_newmortal();
	225	if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
	226
	227	void
	228	vmsopen(spec,...)
	229	char * spec
	230	PROTOTYPE: @
748a9306	231	CODE:
2ae00b68	232	char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
748a9306	233	register int i, myargc;
748a9306	234	FILE *fp;
2ae00b68	235
	236	if (!spec \|\| !*spec) {
	237	SETERRNO(EINVAL,LIB$_INVARG);
	238	XSRETURN_UNDEF;
748a9306	239	}
2ae00b68	240	if (items > 9) croak("too many args");
2ae00b68	241
748a9306	242	/* First, set up name and mode args from perl's string */
2ae00b68	243	if (*spec == '+') {
748a9306	244	mode[1] = '+';
2ae00b68	245	spec++;
748a9306	246	}
2ae00b68	247	if (*spec == '>') {
	248	if ((spec+1) == '>') mode = 'a', spec += 2;
	249	else *mode = 'w', spec++;
748a9306	250	}
2ae00b68	251	else if (*spec == '<') spec++;
748a9306	252	myargc = items - 1;
	253	for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
	254	/* This hack brought to you by C's opaque arglist management */
	255	switch (myargc) {
	256	case 0:
2ae00b68	257	fp = fopen(spec,mode);
748a9306	258	break;
748a9306	259	case 1:
2ae00b68	260	fp = fopen(spec,mode,args[0]);
748a9306	261	break;
748a9306	262	case 2:
2ae00b68	263	fp = fopen(spec,mode,args[0],args[1]);
748a9306	264	break;
748a9306	265	case 3:
2ae00b68	266	fp = fopen(spec,mode,args[0],args[1],args[2]);
748a9306	267	break;
748a9306	268	case 4:
2ae00b68	269	fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
748a9306	270	break;
748a9306	271	case 5:
2ae00b68	272	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
748a9306	273	break;
748a9306	274	case 6:
2ae00b68	275	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
748a9306	276	break;
748a9306	277	case 7:
2ae00b68	278	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
748a9306	279	break;
748a9306	280	case 8:
2ae00b68	281	fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
748a9306	282	break;
748a9306	283	}
2ae00b68	284	if (fp != Nullfp) {
5f05dabc	285	SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
2ae00b68	286	ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
748a9306	287	}
2ae00b68	288	else { ST(0) = &sv_undef; }
748a9306	289
2ae00b68	290	void
	291	vmssysopen(spec,mode,perm,...)
	292	char * spec
	293	int mode
	294	int perm
	295	PROTOTYPE: @
748a9306	296	CODE:
2ae00b68	297	char *args[8];
	298	int i, myargc, fd;
	299	FILE *fp;
	300	SV *fh;
	301	if (!spec \|\| !*spec) {
	302	SETERRNO(EINVAL,LIB$_INVARG);
	303	XSRETURN_UNDEF;
	304	}
	305	if (items > 11) croak("too many args");
	306	myargc = items - 3;
	307	for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
	308	/* More fun with C calls; can't combine with above because
	309	args 2,3 of different types in fopen() and open() */
	310	switch (myargc) {
	311	case 0:
	312	fd = open(spec,mode,perm);
	313	break;
	314	case 1:
	315	fd = open(spec,mode,perm,args[0]);
	316	break;
	317	case 2:
	318	fd = open(spec,mode,perm,args[0],args[1]);
	319	break;
	320	case 3:
	321	fd = open(spec,mode,perm,args[0],args[1],args[2]);
	322	break;
	323	case 4:
	324	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
	325	break;
	326	case 5:
	327	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
	328	break;
	329	case 6:
	330	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
	331	break;
	332	case 7:
	333	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	334	break;
	335	case 8:
	336	fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	337	break;
	338	}
	339	i = mode & 3;
	340	if (fd >= 0 &&
	341	((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
	342	SV *fh = newFH(fp,"<>++"[i]);
	343	ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
	344	}
	345	else { ST(0) = &sv_undef; }
748a9306	346
2ae00b68	347	void
	348	waitfh(fp)
	349	FILE * fp
	350	PROTOTYPE: $
748a9306	351	CODE:
2ae00b68	352	ST(0) = fwait(fp) ? &sv_undef : &sv_yes;
17f28c40	353
	354	void
	355	writeof(mysv)
	356	SV * mysv
	357	PROTOTYPE: $
	358	CODE:
	359	char devnam[257], *cp;
	360	unsigned long int chan, iosb[2], retsts, retsts2;
	361	struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
	362	IO *io = sv_2io(mysv);
	363	FILE *fp = io ? IoOFP(io) : NULL;
	364	if (fp == NULL \|\| strchr(">was+-\|",IoTYPE(io)) == Nullch) {
	365	set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
	366	ST(0) = &sv_undef; XSRETURN(1);
	367	}
	368	if (fgetname(fp,devnam) == Nullch) { ST(0) = &sv_undef; XSRETURN(1); }
	369	if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
	370	devdsc.dsc$w_length = strlen(devnam);
	371	retsts = sys$assign(&devdsc,&chan,0,0);
	372	if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
	373	if (retsts & 1) retsts = iosb[0];
	374	retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
	375	if (retsts & 1) retsts = retsts2;
	376	if (retsts & 1) { ST(0) = &sv_yes; }
	377	else {
	378	set_vaxc_errno(retsts);
	379	switch (retsts) {
	380	case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL:
	381	case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
	382	case SS$_BUFFEROVF:
	383	set_errno(ENOSPC); break;
	384	case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
	385	set_errno(EBADF); break;
	386	case SS$_NOPRIV:
	387	set_errno(EACCES); break;
	388	default: /* Includes "shouldn't happen" cases that might map */
	389	set_errno(EVMSERR); break; /* to other errno values */
	390	}
	391	ST(0) = &sv_undef;
	392	}