Major rewrite, renaming, and extension

1 files changed, 246 insertions, 61 deletions

diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index 737229fe0b..79eb95335e 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -1,110 +1,295 @@
-/* VMS::stdio - VMS extensions to stdio routines 
+/* VMS::Stdio - VMS extensions to stdio routines 
  *
- * Version:  1.1
+ * Version:  2.0
  * Author:   Charles Bailey  bailey@genetics.upenn.edu
- * Revised:  09-Mar-1995
+ * Revised:  28-Feb-1996
  *
- *
- * Revision History:
- * 
- * 1.0  29-Nov-1994  Charles Bailey  bailey@genetics.upenn.edu
- *      original version - vmsfopen
- * 1.1  09-Mar-1995  Charles Bailey  bailey@genetics.upenn.edu
- *      changed calling sequence to return FH/undef - like POSIX::open
- *      added fgetname and tmpnam
  */
 
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+#include <file.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;
+}
 
-/* Use type for FILE * from Perl's XSUB typemap.  This is a bit
- * of a hack, since all Perl filehandles using this type will permit
- * both read & write operations, but it saves having to write the PPCODE
- * directly for updating the Perl filehandles.
- */
-typedef FILE * InOutStream;
 
-MODULE = VMS::stdio  PACKAGE = VMS::stdio
+static SV *
+newFH(FILE *fp, char type) {
+    SV *rv, *gv = NEWSV(0,0);
+    GV **stashp;
+    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(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(gv);
+    SvREFCNT_dec(gv);
+    return sv_bless(rv,stash);
+}
+
+MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
 
 void
-vmsfopen(name,...)
+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(sv)
+	SV *	sv
+	PROTOTYPE: $
+	CODE:
+	    FILE *fp = Nullfp;
+	    if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
+	    ST(0) = fflush(fp) ? &sv_undef : &sv_yes;
+
+char *
+getname(fp)
+	FILE *	fp
+	PROTOTYPE: $
+	CODE:
+	    char fname[257];
+	    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
+sync(fp)
+	FILE *	fp
+	PROTOTYPE: $
+	CODE:
+	    ST(0) = fsync(fileno(fp)) ? &sv_undef : &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[5] = {'r','\0','\0','\0','\0'}, c;
+	    char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
 	    register int i, myargc;
 	    FILE *fp;
-	    if (items > 9) {
-	      croak("File::VMSfopen::vmsfopen - too many args");
+	
+	    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 (*name == '+') {
+	    if (*spec == '+') {
 	      mode[1] = '+';
-	      name++;
+	      spec++;
 	    }
-	    if (*name == '>') {
-	      if (*(name+1) == '>') *mode = 'a', name += 2;
-	      else *mode = 'w',  name++;
+	    if (*spec == '>') {
+	      if (*(spec+1) == '>') *mode = 'a', spec += 2;
+	      else *mode = 'w',  spec++;
 	    }
-	    else if (*name == '<') name++;
+	    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(name,mode);
+	        fp = fopen(spec,mode);
 	        break;
 	      case 1:
-	        fp = fopen(name,mode,args[0]);
+	        fp = fopen(spec,mode,args[0]);
 	        break;
 	      case 2:
-	        fp = fopen(name,mode,args[0],args[1]);
+	        fp = fopen(spec,mode,args[0],args[1]);
 	        break;
 	      case 3:
-	        fp = fopen(name,mode,args[0],args[1],args[2]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2]);
 	        break;
 	      case 4:
-	        fp = fopen(name,mode,args[0],args[1],args[2],args[3]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
 	        break;
 	      case 5:
-	        fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
 	        break;
 	      case 6:
-	        fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
 	        break;
 	      case 7:
-	        fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 	        break;
 	      case 8:
-	        fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
+	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 	        break;
 	    }
-	    ST(0) = sv_newmortal();
-	    if (fp != NULL) {
-	       GV *gv = newGVgen("VMS::stdio");
-               c = mode[0]; name = mode;
-               if (mode[1])  *(name++) = '+';
-               if (c == 'r') *(name++) = '<';
-               else {
-                 *(name++) = '>';
-                 if (c == 'a') *(name++) = '>';
-               }
-               *(name++) = '&';
-	       if (do_open(gv,mode,name - mode,FALSE,0,0,fp))
-	         sv_setsv(ST(0),newRV((SV*)gv));
+	    if (fp != Nullfp) {
+	      SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>')));
+	      ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 	    }
+	    else { ST(0) = &sv_undef; }
 
-char *
-fgetname(fp)
-	FILE *	fp
+void
+vmssysopen(spec,mode,perm,...)
+	char *	spec
+	int	mode
+	int	perm
+	PROTOTYPE: @
 	CODE:
-	  char fname[257];
-	  ST(0) = sv_newmortal();
-	  if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+	    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; }
 
-char *
-tmpnam()
+void
+waitfh(fp)
+	FILE *	fp
+	PROTOTYPE: $
 	CODE:
-	  char fname[L_tmpnam];
-	  ST(0) = sv_newmortal();
-	  if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
+	    ST(0) = fwait(fp) ? &sv_undef : &sv_yes;