Next wave of _63 VMS patches

p4raw-id: //depot/perl@854

6 files changed, 182 insertions, 55 deletions

diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm
index db3283c571..b0b1414599 100644
--- a/vms/ext/Filespec.pm
+++ b/vms/ext/Filespec.pm
@@ -12,7 +12,7 @@ VMS::Filespec - convert between VMS and Unix file specification syntax
 =head1 SYNOPSIS
 
 use VMS::Filespec;
-$fullspec = rmsexpand('[.VMS]file.specification');
+$fullspec = rmsexpand('[.VMS]file.specification'[, 'default:[file.spec]']);
 $vmsspec = vmsify('/my/Unix/file/specification');
 $unixspec = unixify('my:[VMS]file.specification');
 $path = pathify('my:[VMS.or.Unix.directory]specification.dir');
@@ -65,9 +65,11 @@ The routines provided are:
 =head2 rmsexpand
 
 Uses the RMS $PARSE and $SEARCH services to expand the input
-specification to its fully qualified form.  (If the file does
-not exist, the input specification is expanded as much as
-possible.)  If an error occurs, returns C<undef> and sets C<$!>
+specification to its fully qualified form, except that a null type
+or version is not added unless it was present in either the original
+file specification or the default specification passed to C<rmsexpand>.
+(If the file does not exist, the input specification is expanded as much
+as possible.)  If an error occurs, returns C<undef> and sets C<$!>
 and C<$^E>.
 
 =head2 vmsify
diff --git a/vms/ext/Stdio/0README.txt b/vms/ext/Stdio/0README.txt
index 28f82b3a14..25329f9334 100644
--- a/vms/ext/Stdio/0README.txt
+++ b/vms/ext/Stdio/0README.txt
@@ -3,26 +3,6 @@ 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.
 
-                       *** Please Note ***
-
-This package is the direct descendant of VMS::stdio, but as of Perl
-5.002, the name has been changed to VMS::Stdio, in order to conform
-to the Perl naming convention that extensions whose name begins
-with a lowercase letter represent compile-time "pragmas", while
-extensions which provide added functionality have names whose parts
-begin with uppercase letters.  In addition, the functions
-vmsfopen and fgetname have been renamed vmsopen and getname,
-respectively, in order to more closely resemble related Perl
-I/O operators, which do not retain the 'f' from corresponding
-C routine names.
-
-A transitional interface to the old routine names has been
-provided, so that calls to these routines will generate a
-warning, and be routed to the corresponding VMS::Stdio
-routine.  This interface will be removed in a future release,
-so please update your code to use the new names.
-
-
 ===> Installation
 
 This extension, like most Perl extensions, should be installed
@@ -45,3 +25,6 @@ the Perl distribution tree, and then saying
 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/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
index 01ff32db64..ea5d9074ef 100644
--- a/vms/ext/Stdio/Stdio.pm
+++ b/vms/ext/Stdio/Stdio.pm
@@ -1,8 +1,8 @@
 #   VMS::Stdio - VMS extensions to Perl's stdio calls
 #
 #   Author:  Charles Bailey  bailey@genetics.upenn.edu
-#   Version: 2.02
-#   Revised: 15-Feb-1997
+#   Version: 2.1
+#   Revised: 24-Mar-1998
 
 package VMS::Stdio;
 
@@ -12,17 +12,18 @@ use Carp '&croak';
 use DynaLoader ();
 use Exporter ();
  
-$VERSION = '2.02';
+$VERSION = '2.1';
 @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( &flush &getname &remove &rewind &sync &tmpnam
-                 &vmsopen &vmssysopen &waitfh );
+@EXPORT_OK = qw( &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( &flush &getname &remove &rewind &sync
-                                     &tmpnam &vmsopen &vmssysopen &waitfh ) ] );
+                 FUNCTIONS => [ qw( &flush &getname &remove &rewind &setdef
+                                    &sync &tmpnam &vmsopen &vmssysopen
+                                    &waitfh &writeof ) ] );
 
 bootstrap VMS::Stdio $VERSION;
 
@@ -80,8 +81,9 @@ VMS::Stdio - standard I/O functions via VMS extensions
 
 =head1 SYNOPSIS
 
-use VMS::Stdio qw( &flush &getname &remove &rewind &sync &tmpnam
-                   &vmsopen &vmssysopen &waitfh );
+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);
@@ -96,7 +98,7 @@ sysread($fh,$data,128);
 waitfh($fh);
 close($fh);
 remove("another.file");
-
+writeof($pipefh);
 =head1 DESCRIPTION
 
 This package gives Perl scripts access via VMS extensions to several
@@ -175,6 +177,13 @@ 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 and error.
+
 =item sync
 
 This function flushes buffered data for the specified file handle
@@ -231,6 +240,14 @@ 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.
+
 =head1 REVISION
 
 This document was last revised on 10-Dec-1996, for Perl 5.004.
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index b10fec0d48..0a7b47e514 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -1,8 +1,8 @@
 /* VMS::Stdio - VMS extensions to stdio routines 
  *
- * Version:  2.02
+ * Version:  2.1
  * Author:   Charles Bailey  bailey@genetics.upenn.edu
- * Revised:  15-Feb-1997
+ * Revised:  24-Mar-1998
  *
  */
 
@@ -10,6 +10,9 @@
 #include "perl.h"
 #include "XSUB.h"
 #include <file.h>
+#include <iodef.h>
+#include <rms.h>
+#include <starlet.h>
 
 static bool
 constant(name, pval)
@@ -121,12 +124,10 @@ constant(name)
 	    ST(0) = &sv_undef;
 
 void
-flush(sv)
-	SV *	sv
+flush(fp)
+	FILE *	fp
 	PROTOTYPE: $
 	CODE:
-	    FILE *fp = Nullfp;
-	    if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
 	    if (fflush(fp)) { ST(0) = &sv_undef; }
 	    else            { clearerr(fp); ST(0) = &sv_yes; }
 
@@ -135,7 +136,7 @@ getname(fp)
 	FILE *	fp
 	PROTOTYPE: $
 	CODE:
-	    char fname[257];
+	    char fname[NAM$C_MAXRSS+1];
 	    ST(0) = sv_newmortal();
 	    if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
 
@@ -154,6 +155,59 @@ remove(name)
 	    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: $
@@ -295,3 +349,43 @@ waitfh(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;
+	    }
diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
index 0b50d63e3a..36353d91b3 100755
--- a/vms/ext/Stdio/test.pl
+++ b/vms/ext/Stdio/test.pl
@@ -1,8 +1,8 @@
-# Tests for VMS::Stdio v2.01
+# Tests for VMS::Stdio v2.1
 use VMS::Stdio;
-import VMS::Stdio qw(&flush &getname &rewind &sync);
+import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);
 
-print "1..14\n";
+print "1..19\n";
 print +(defined(&getname) ? '' : 'not '), "ok 1\n";
 
 $name = "test$$";
@@ -42,3 +42,27 @@ undef $sfh;
 print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
 
 print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
+
+if (open(P, qq[| MCR $^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) ? '' : 'not '),"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 "not ok 15\nnot ok 16\nnot ok 17\n"; }
+
+$sfh = VMS::Stdio::vmsopen(">$name.tmp");
+$setuperl = "\$ MCR $^X\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";
diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t
index 1b31f06dff..05644917b6 100644
--- a/vms/ext/filespec.t
+++ b/vms/ext/filespec.t
@@ -10,7 +10,7 @@ foreach (<DATA>) {
   next if /^\s*$/;
   push(@tests,$_);
 }
-print '1..',scalar(@tests)+5,"\n";
+print '1..',scalar(@tests)+6,"\n";
 
 foreach $test (@tests) {
   ($arg,$func,$expect) = split(/\t+/,$test);
@@ -25,14 +25,17 @@ foreach $test (@tests) {
   }
 }
 
+$defwarn = <<'EOW';
+# Note: This failure may have occurred because your default device
+# was set using a non-concealed logical name.  If this is the case,
+# you will need to determine by inspection that the two resultant
+# file specifications shwn above are in fact equivalent.
+EOW
+
 if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; }
 else {
   print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'),
-        "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n";
-  print "# Note: This failure may have occurred because your default device\n";
-  print "# was set using a non-concealed logical name.  If this is the case,\n";
-  print "# you will need to determine by inspection that the two resultant\n";
-  print "# file specifications shwn above are in fact equivalent.\n";
+        "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n$defwarn";
 }
 if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") {
    print 'ok ', ++$idx, "\n";
@@ -40,11 +43,15 @@ if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") {
 else {
   print 'not ok ', ++$idx, ": rmsexpand('from.here') = |",
         rmsexpand('from.here'),
-        "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n";
-  print "# Note: This failure may have occurred because your default device\n";
-  print "# was set using a non-concealed logical name.  If this is the case,\n";
-  print "# you will need to determine by inspection that the two resultant\n";
-  print "# file specifications shwn above are in fact equivalent.\n";
+        "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n$defwarn";
+}
+if (rmsexpand('from') eq "\L$ENV{DEFAULT}from") {
+   print 'ok ', ++$idx, "\n";
+}
+else {
+  print 'not ok ', ++$idx, ": rmsexpand('from') = |",
+        rmsexpand('from'),
+        "|, \$ENV{DEFAULT}from = |\L$ENV{DEFAULT}from|\n$defwarn";
 }
 if (rmsexpand('from.here','cant:[get.there];2') eq
     'cant:[get.there]from.here;2')                 { print 'ok ',++$idx,"\n"; }