Move vms/ext/DCLsym and vms/ext/Stdio to ext/VMS-DCLsym and ext/VMS-Stdio.

5 files changed, 1217 insertions, 0 deletions

diff --git a/ext/VMS-Stdio/0README.txt b/ext/VMS-Stdio/0README.txt
new file mode 100644
index 0000000000..25329f9334
--- /dev/null
+++ b/ext/VMS-Stdio/0README.txt
@@ -0,0 +1,30 @@
+This directory contains the source code for the Perl extension
+VMS::Stdio, which provides access from Perl to VMS-specific
+stdio functions.  For more specific documentation of its
+function, please see the pod section of Stdio.pm.
+
+===> Installation
+
+This extension, like most Perl extensions, should be installed
+by copying the files in this directory to a location *outside*
+the Perl distribution tree, and then saying
+
+    $ perl Makefile.PL  ! Build Descrip.MMS for this extension
+    $ MMK               ! Build the extension
+    $ MMK test          ! Run its regression tests
+    $ MMK install       ! Install required files in public Perl tree
+
+
+===> 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
+2.0  28-Feb-1996  Charles Bailey  bailey@genetics.upenn.edu
+     major rewrite for Perl 5.002: name changed to VMS::Stdio,
+     new functions added, and prototypes incorporated
+2.1  24-Mar-1998  Charles Bailey  bailey@newman.upenn.edu
+     Added writeof()
+     Removed old VMs::stdio compatibility interface
diff --git a/ext/VMS-Stdio/Makefile.PL b/ext/VMS-Stdio/Makefile.PL
new file mode 100644
index 0000000000..4e17a48082
--- /dev/null
+++ b/ext/VMS-Stdio/Makefile.PL
@@ -0,0 +1,5 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION_FROM' => 'Stdio.pm',
+               'MAN3PODS'     => {}, # pods will be built later
+             );
diff --git a/ext/VMS-Stdio/Stdio.pm b/ext/VMS-Stdio/Stdio.pm
new file mode 100644
index 0000000000..54f37c94fb
--- /dev/null
+++ b/ext/VMS-Stdio/Stdio.pm
@@ -0,0 +1,640 @@
+#   VMS::Stdio - VMS extensions to Perl's stdio calls
+#
+#   Author:  Charles Bailey  bailey@genetics.upenn.edu
+#   Version: 2.2
+#   Revised: 19-Jul-1998
+#   Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd@ous.edu>
+
+package VMS::Stdio;
+
+require 5.002;
+use vars qw( $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA );
+use Carp '&croak';
+use DynaLoader ();
+use Exporter ();
+ 
+$VERSION = '2.4';
+@ISA = qw( Exporter DynaLoader IO::File );
+@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY &O_NOWAIT
+              &O_RDONLY &O_RDWR  &O_TRUNC &O_WRONLY );
+@EXPORT_OK = qw( &binmode &flush &getname &remove &rewind &sync &setdef &tmpnam
+                 &vmsopen &vmssysopen &waitfh &writeof );
+%EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY
+                                    &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC
+                                    &O_WRONLY ) ],
+                 FUNCTIONS => [ qw( &binmode &flush &getname &remove &rewind
+                                    &setdef &sync &tmpnam &vmsopen &vmssysopen
+                                    &waitfh &writeof ) ] );
+
+bootstrap VMS::Stdio $VERSION;
+
+sub AUTOLOAD {
+    my($constname) = $AUTOLOAD;
+    $constname =~ s/.*:://;
+    if ($constname =~ /^O_/) {
+      my($val) = constant($constname);
+      defined $val or croak("Unknown VMS::Stdio constant $constname");
+      *$AUTOLOAD = sub { $val; }
+    }
+    else { # We don't know about it; hand off to IO::File
+      require IO::File;
+
+      *$AUTOLOAD = eval "sub { shift->IO::File::$constname(\@_) }";
+      croak "Error autoloading IO::File::$constname: $@" if $@;
+    }
+    goto &$AUTOLOAD;
+}
+
+sub DESTROY { close($_[0]); }
+
+
+################################################################################
+# Intercept calls to old VMS::stdio package, complain, and hand off
+# This will be removed in a future version of VMS::Stdio
+
+package VMS::stdio;
+
+sub AUTOLOAD {
+  my($func) = $AUTOLOAD;
+  $func =~ s/.*:://;
+  # Cheap trick: we know DynaLoader has required Carp.pm
+  Carp::carp("Old package VMS::stdio is now VMS::Stdio; please update your code");
+  if ($func eq 'vmsfopen') {
+    Carp::carp("Old function &vmsfopen is now &vmsopen");
+    goto &VMS::Stdio::vmsopen;
+  }
+  elsif ($func eq 'fgetname') {
+    Carp::carp("Old function &fgetname is now &getname");
+    goto &VMS::Stdio::getname;
+  }
+  else { goto &{"VMS::Stdio::$func"}; }
+}
+
+package VMS::Stdio;  # in case we ever use AutoLoader
+
+1;
+
+__END__
+
+=head1 NAME
+
+VMS::Stdio - standard I/O functions via VMS extensions
+
+=head1 SYNOPSIS
+
+  use VMS::Stdio qw( &flush &getname &remove &rewind &setdef &sync &tmpnam
+                     &vmsopen &vmssysopen &waitfh &writeof );
+  setdef("new:[default.dir]");
+  $uniquename = tmpnam;
+  $fh = vmsopen("my.file","rfm=var","alq=100",...) or die $!;
+  $name = getname($fh);
+  print $fh "Hello, world!\n";
+  flush($fh);
+  sync($fh);
+  rewind($fh);
+  $line = <$fh>;
+  undef $fh;  # closes file
+  $fh = vmssysopen("another.file", O_RDONLY | O_NDELAY, 0, "ctx=bin");
+  sysread($fh,$data,128);
+  waitfh($fh);
+  close($fh);
+  remove("another.file");
+  writeof($pipefh);
+  binmode($fh);
+
+=head1 DESCRIPTION
+
+This package gives Perl scripts access via VMS extensions to several
+C stdio operations not available through Perl's CORE I/O functions.
+The specific routines are described below.  These functions are
+prototyped as unary operators, with the exception of C<vmsopen>
+and C<vmssysopen>, which can take any number of arguments, and
+C<tmpnam>, which takes none.
+
+All of the routines are available for export, though none are
+exported by default.  All of the constants used by C<vmssysopen>
+to specify access modes are exported by default.  The routines
+are associated with the Exporter tag FUNCTIONS, and the constants
+are associated with the Exporter tag CONSTANTS, so you can more
+easily choose what you'd like to import:
+
+    # import constants, but not functions
+    use VMS::Stdio;  # same as use VMS::Stdio qw( :DEFAULT );
+    # import functions, but not constants
+    use VMS::Stdio qw( !:CONSTANTS :FUNCTIONS ); 
+    # import both
+    use VMS::Stdio qw( :CONSTANTS :FUNCTIONS ); 
+    # import neither
+    use VMS::Stdio ();
+
+Of course, you can also choose to import specific functions by
+name, as usual.
+
+This package C<ISA> IO::File, so that you can call IO::File
+methods on the handles returned by C<vmsopen> and C<vmssysopen>.
+The IO::File package is not initialized, however, until you
+actually call a method that VMS::Stdio doesn't provide.  This
+is done to save startup time for users who don't wish to use
+the IO::File methods.
+
+B<Note:>  In order to conform to naming conventions for Perl
+extensions and functions, the name of this package has been
+changed to VMS::Stdio as of Perl 5.002, and the names of some
+routines have been changed.  Calls to the old VMS::stdio routines
+will generate a warning, and will be routed to the equivalent
+VMS::Stdio function.  This compatibility interface will be
+removed in a future release of this extension, so please
+update your code to use the new routines.
+
+=over 4
+
+=item binmode
+
+This function causes the file handle to be reopened with the CRTL's
+carriage control processing disabled; its effect is the same as that
+of the C<b> access mode in C<vmsopen>.  After the file is reopened,
+the file pointer is positioned as close to its position before the
+call as possible (I<i.e.> as close as fsetpos() can get it -- for
+some record-structured files, it's not possible to return to the
+exact byte offset in the file).  Because the file must be reopened,
+this function cannot be used on temporary-delete files. C<binmode>
+returns true if successful, and C<undef> if not.
+
+Note that the effect of C<binmode> differs from that of the binmode()
+function on operating systems such as Windows and MSDOS, and is not
+needed to process most types of file.
+
+=item flush
+
+This function causes the contents of stdio buffers for the specified
+file handle to be flushed.  If C<undef> is used as the argument to
+C<flush>, all currently open file handles are flushed.  Like the CRTL
+fflush() routine, it does not flush any underlying RMS buffers for the
+file, so the data may not be flushed all the way to the disk.  C<flush>
+returns a true value if successful, and C<undef> if not.
+
+=item getname
+
+The C<getname> function returns the file specification associated
+with a Perl I/O handle.  If an error occurs, it returns C<undef>.
+
+=item remove
+
+This function deletes the file named in its argument, returning
+a true value if successful and C<undef> if not.  It differs from
+the CORE Perl function C<unlink> in that it does not try to
+reset file protection if the original protection does not give
+you delete access to the file (cf. L<perlvms>).  In other words,
+C<remove> is equivalent to
+
+  unlink($file) if VMS::Filespec::candelete($file);
+
+=item rewind
+
+C<rewind> resets the current position of the specified file handle
+to the beginning of the file.  It's really just a convenience
+method equivalent in effect to C<seek($fh,0,0)>.  It returns a
+true value if successful, and C<undef> if it fails.
+
+=item setdef
+
+This function sets the default device and directory for the process.
+It is identical to the built-in chdir() operator, except that the change
+persists after Perl exits.  It returns a true value on success, and
+C<undef> if it encounters an error.
+
+=item sync
+
+This function flushes buffered data for the specified file handle
+from stdio and RMS buffers all the way to disk.  If successful, it
+returns a true value; otherwise, it returns C<undef>.
+
+=item tmpnam
+
+The C<tmpnam> function returns a unique string which can be used
+as a filename when creating temporary files.  If, for some
+reason, it is unable to generate a name, it returns C<undef>.
+
+=item vmsopen
+
+The C<vmsopen> function enables you to specify optional RMS arguments
+to the VMS CRTL when opening a file.  Its operation is similar to the built-in
+Perl C<open> function (see L<perlfunc> for a complete description),
+but it will only open normal files; it cannot open pipes or duplicate
+existing I/O handles.  Up to 8 optional arguments may follow the
+file name.  These arguments should be strings which specify
+optional file characteristics as allowed by the CRTL. (See the
+CRTL reference manual description of creat() and fopen() for details.)
+If successful, C<vmsopen> returns a VMS::Stdio file handle; if an
+error occurs, it returns C<undef>.
+
+You can use the file handle returned by C<vmsopen> just as you
+would any other Perl file handle.  The class VMS::Stdio ISA
+IO::File, so you can call IO::File methods using the handle
+returned by C<vmsopen>.  However, C<use>ing VMS::Stdio does not
+automatically C<use> IO::File; you must do so explicitly in
+your program if you want to call IO::File methods.  This is
+done to avoid the overhead of initializing the IO::File package
+in programs which intend to use the handle returned by C<vmsopen>
+as a normal Perl file handle only.  When the scalar containing
+a VMS::Stdio file handle is overwritten, C<undef>d, or goes
+out of scope, the associated file is closed automatically.
+
+File characteristic options:
+
+=over 2
+
+=item alq=INTEGER
+
+Sets the allocation quantity for this file
+
+=item bls=INTEGER
+
+File blocksize
+
+=item ctx=STRING
+
+Sets the context for the file. Takes one of these arguments:
+
+=over 4
+
+=item bin
+
+Disables LF to CRLF translation
+
+=item cvt
+
+Negates previous setting of C<ctx=noctx>
+
+=item nocvt
+
+Disables conversion of FORTRAN carriage control
+
+=item rec
+
+Force record-mode access
+
+=item stm
+
+Force stream mode
+
+=item xplct
+
+Causes records to be flushed I<only> when the file is closed, or when an
+explicit flush is done
+
+=back
+
+=item deq=INTEGER
+
+Sets the default extension quantity
+
+=item dna=FILESPEC
+
+Sets the default filename string. Used to fill in any missing pieces of the
+filename passed.
+
+=item fop=STRING
+
+File processing option. Takes one or more of the following (in a
+comma-separated list if there's more than one)
+
+=over 4
+
+=item ctg
+
+Contiguous.
+
+=item cbt
+
+Contiguous-best-try.
+
+=item dfw
+
+Deferred write; only applicable to files opened for shared access.
+
+=item dlt
+
+Delete file on close.
+
+=item tef
+
+Truncate at end-of-file.
+
+=item cif
+
+Create if nonexistent.
+
+=item sup
+
+Supersede.
+
+=item scf
+
+Submit as command file on close.
+
+=item spl
+
+Spool to system printer on close.
+
+=item tmd
+
+Temporary delete.
+
+=item tmp
+
+Temporary (no file directory).
+
+=item nef
+
+Not end-of-file.
+
+=item rck
+
+Read check compare operation.
+
+=item wck
+
+Write check compare operation.
+
+=item mxv
+
+Maximize version number.
+
+=item rwo
+
+Rewind file on open.
+
+=item pos
+
+Current position.
+
+=item rwc
+
+Rewind file on close.
+
+=item sqo
+
+File can only be processed in a sequential manner.
+
+=back
+
+=item fsz=INTEGER
+
+Fixed header size
+
+=item gbc=INTEGER
+
+Global buffers requested for the file
+
+=item mbc=INTEGER
+
+Multiblock count
+
+=item mbf=INTEGER
+
+Bultibuffer count
+
+=item mrs=INTEGER
+
+Maximum record size
+
+=item rat=STRING
+
+File record attributes. Takes one of the following:
+
+=over 4
+
+=item cr
+
+Carriage-return control.
+
+=item blk
+
+Disallow records to span block boundaries.
+
+=item ftn
+
+FORTRAN print control.
+
+=item none
+
+Explicitly forces no carriage control.
+
+=item prn
+
+Print file format.
+
+=back
+
+=item rfm=STRING
+
+File record format. Takes one of the following:
+
+=over 4
+
+=item fix
+
+Fixed-length record format.
+
+=item stm
+
+RMS stream record format.
+
+=item stmlf
+
+Stream format with line-feed terminator.
+
+=item stmcr
+
+Stream format with carriage-return terminator.
+
+=item var
+
+Variable-length record format.
+
+=item vfc
+
+Variable-length record with fixed control.
+
+=item udf
+
+Undefined format
+
+=back
+
+=item rop=STRING
+
+Record processing operations. Takes one or more of the following in a
+comma-separated list:
+
+=over 4
+
+=item asy
+
+Asynchronous I/O.
+
+=item cco
+
+Cancel Ctrl/O (used with Terminal I/O).
+
+=item cvt
+
+Capitalizes characters on a read from the terminal.
+
+=item eof
+
+Positions the record stream to the end-of-file for the connect operation
+only.
+
+=item nlk
+
+Do not lock record.
+
+=item pmt
+
+Enables use of the prompt specified by pmt=usr-prmpt on input from the
+terminal.
+
+=item pta
+
+Eliminates any information in the type-ahead buffer on a read from the
+terminal.
+
+=item rea
+
+Locks record for a read operation for this process, while allowing other
+accessors to read the record.
+
+=item rlk
+
+Locks record for write.
+
+=item rne
+
+Suppresses echoing of input data on the screen as it is entered on the
+keyboard.
+
+=item rnf
+
+Indicates that Ctrl/U, Ctrl/R, and DELETE are not to be considered control
+commands on terminal input, but are to be passed to the application
+program.
+
+=item rrl
+
+Reads regardless of lock.
+
+=item syncsts
+
+Returns success status of RMS$_SYNCH if the requested service completes its
+task immediately.
+
+=item tmo
+
+Timeout I/O.
+
+=item tpt
+
+Allows put/write services using sequential record access mode to occur at
+any point in the file, truncating the file at that point.
+
+=item ulk
+
+Prohibits RMS from automatically unlocking records.
+
+=item wat
+
+Wait until record is available, if currently locked by another stream.
+
+=item rah
+
+Read ahead.
+
+=item wbh
+
+Write behind.
+
+=back
+
+=item rtv=INTEGER
+
+The number of retrieval pointers that RMS has to maintain (0 to 127255)
+
+=item shr=STRING
+
+File sharing options. Choose one of the following:
+
+=over 4
+
+=item del
+
+Allows users to delete.
+
+=item get
+
+Allows users to read.
+
+=item mse
+
+Allows mainstream access.
+
+=item nil
+
+Prohibits file sharing.
+
+=item put
+
+Allows users to write.
+
+=item upd
+
+Allows users to update.
+
+=item upi
+
+Allows one or more writers.
+
+=back
+
+=item tmo=INTEGER
+
+I/O timeout value
+
+=back
+
+=item vmssysopen
+
+This function bears the same relationship to the CORE function
+C<sysopen> as C<vmsopen> does to C<open>.  Its first three arguments
+are the name, access flags, and permissions for the file.  Like
+C<vmsopen>, it takes up to 8 additional string arguments which
+specify file characteristics.  Its return value is identical to
+that of C<vmsopen>.
+
+The symbolic constants for the mode argument are exported by
+VMS::Stdio by default, and are also exported by the Fcntl package.
+
+=item waitfh
+
+This function causes Perl to wait for the completion of an I/O
+operation on the file handle specified as its argument.  It is
+used with handles opened for asynchronous I/O, and performs its
+task by calling the CRTL routine fwait().
+
+=item writeof
+
+This function writes an EOF to a file handle, if the device driver
+supports this operation.  Its primary use is to send an EOF to a
+subprocess through a pipe opened for writing without closing the
+pipe.  It returns a true value if successful, and C<undef> if
+it encounters an error.
+
+=back
+
+=head1 REVISION
+
+This document was last revised on 13-Oct-1998, for Perl 5.004, 5.005, and
+5.6.0.
+
+=cut
diff --git a/ext/VMS-Stdio/Stdio.xs b/ext/VMS-Stdio/Stdio.xs
new file mode 100644
index 0000000000..c50bacb3f3
--- /dev/null
+++ b/ext/VMS-Stdio/Stdio.xs
@@ -0,0 +1,463 @@
+/* VMS::Stdio - VMS extensions to stdio routines 
+ *
+ * Version:  2.3
+ * Author:   Charles Bailey  bailey@newman.upenn.edu
+ * Revised:  14-Jun-2007
+ *
+ */
+
+#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(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 = '<';
+	    register 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;
+	    }
diff --git a/ext/VMS-Stdio/t/vms_stdio.t b/ext/VMS-Stdio/t/vms_stdio.t
new file mode 100755
index 0000000000..77505d8fac
--- /dev/null
+++ b/ext/VMS-Stdio/t/vms_stdio.t
@@ -0,0 +1,79 @@
+# Tests for VMS::Stdio v2.2
+use VMS::Stdio;
+import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);
+
+print "1..18\n";
+print +(defined(&getname) ? '' : 'not '), "ok 1\n";
+
+#VMS can pretend that it is UNIX.
+my $perl = $^X;
+$perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS';
+
+$name = "test$$";
+$name++ while -e "$name.tmp";
+$fh = VMS::Stdio::vmsopen("+>$name",'ctx=rec','shr=put','fop=dlt','dna=.tmp');
+print +($fh ? '' : 'not '), "ok 2\n";
+
+print +(flush($fh) ? '' : 'not '),"ok 3\n";
+print +(sync($fh) ? '' : 'not '),"ok 4\n";
+
+$time = (stat("$name.tmp"))[9];
+print +($time ? '' : 'not '), "ok 5\n";
+
+$fh->autoflush;  # Can we autoload autoflush from IO::File?  Do or die.
+print "ok 6\n";
+
+print 'not ' unless print $fh scalar(localtime($time)),"\n";
+print "ok 7\n";
+
+print +(rewind($fh) ? '' : 'not '),"ok 8\n";
+
+chop($line = <$fh>);
+print +($line eq localtime($time) ? '' : 'not '), "ok 9\n";
+
+($gotname) = (getname($fh) =~/\](.*);/);
+
+#we may be in UNIX emulation mode.
+if (!defined($gotname)) {
+   ($gotname) = (VMS::Filespec::vmsify(getname($fh)) =~/\](.*)/);
+}
+print +("\U$gotname" eq "\U$name.tmp" ? '' : 'not '), "ok 10\n";
+
+$sfh = VMS::Stdio::vmssysopen($name, O_RDONLY, 0,
+                              'ctx=rec', 'shr=put', 'dna=.tmp');
+print +($sfh ? '' : 'not ($!) '), "ok 11\n";
+
+close($fh);
+sysread($sfh,$line,24);
+print +($line eq localtime($time) ? '' : 'not '), "ok 12\n";
+
+undef $sfh;
+print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
+
+print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
+
+#if (open(P, qq[| $^X -e "1 while (<STDIN>);print 'Foo';1 while (<STDIN>); print 'Bar'" >$name.tmp])) {
+#  print P "Baz\nQuux\n";
+#  print +(VMS::Stdio::writeof(P) ? '' : 'not '),"ok 15\n";
+#  print P "Baz\nQuux\n";
+#  print +(close(P) ? '' : ''),"ok 16\n";
+#  $fh = VMS::Stdio::vmsopen("$name.tmp");
+#  chomp($line = <$fh>);
+#  close $fh;
+#  unlink("$name.tmp");
+#  print +($line eq 'FooBar' ? '' : 'not '),"ok 17\n";
+#}
+#else { 
+print "ok 15\nok 16\nok 17\n";
+#}
+
+$sfh = VMS::Stdio::vmsopen(">$name.tmp");
+$setuperl = "\$ MCR $perl\nBEGIN { \@INC = qw(@INC) };\nuse VMS::Stdio qw(&setdef);";
+print $sfh qq[\$ here = F\$Environment("Default")\n];
+print $sfh "$setuperl\nsetdef();\n\$ Show Default\n\$ Set Default 'here'\n";
+print $sfh "$setuperl\nsetdef('..');\n\$ Show Default\n";
+close $sfh;
+@defs = map { /(\S+)/ && $1 } `\@$name.tmp`;
+unlink("$name.tmp");
+print +($defs[0] eq uc($ENV{'SYS$LOGIN'}) ? '' : "not ($defs[0]) "),"ok 18\n";
+#print +($defs[1] eq VMS::Filespec::rmsexpand('[-]') ? '' : "not ($defs[1]) "),"ok 19\n";