perl-5.6.0 + local changes

10 files changed, 151 insertions, 40 deletions

diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt
index 9dc721d36b0..29f2bdb8757 100644
--- a/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt
@@ -17,5 +17,5 @@ $ MMK install
 If you have any problems or suggestions, please feel free to let me know.
 
 Regards,
-Charles Bailey  bailey@genetics.upenn.edu
+Charles Bailey  bailey@newman.upenn.edu
 17-Aug-1995
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm
index 44c4b84a654..7989cee0ad5 100644
--- a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm
@@ -256,7 +256,7 @@ version of this package.
 
 =head1 AUTHOR
 
-Charles Bailey  bailey@genetics.upenn.edu
+Charles Bailey  bailey@newman.upenn.edu
 
 =head1 VERSION
 
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs
index 35cabc525ea..f0f19f4d160 100644
--- a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs
@@ -1,13 +1,13 @@
 /* VMS::DCLsym - manipulate DCL symbols
  *
  * Version:  1.0
- * Author:   Charles Bailey  bailey@genetics.upenn.edu
+ * Author:   Charles Bailey  bailey@newman.upenn.edu
  * Revised:  17-Aug-1995
  *
  *
  * Revision History:
  * 
- * 1.0  17-Aug-1995  Charles Bailey  bailey@genetics.upenn.edu
+ * 1.0  17-Aug-1995  Charles Bailey  bailey@newman.upenn.edu
  *      original production version
  */
 
diff --git a/gnu/usr.bin/perl/vms/ext/Filespec.pm b/gnu/usr.bin/perl/vms/ext/Filespec.pm
index 4a539c27016..375e962c67a 100644
--- a/gnu/usr.bin/perl/vms/ext/Filespec.pm
+++ b/gnu/usr.bin/perl/vms/ext/Filespec.pm
@@ -2,7 +2,7 @@
 #   of VMS and Unix file specification syntax.
 #
 #   Version:  1.1
-#   Author:   Charles Bailey  bailey@genetics.upenn.edu
+#   Author:   Charles Bailey  bailey@newman.upenn.edu
 #   Revised:  08-Mar-1995
 
 =head1 NAME
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm
index 04b339725fb..b51f2c9f15d 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm
+++ b/gnu/usr.bin/perl/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.1
-#   Revised: 24-Mar-1998
+#   Version: 2.2
+#   Revised: 19-Jul-1998
 #   Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd@ous.edu>
 
 package VMS::Stdio;
@@ -13,17 +13,17 @@ use Carp '&croak';
 use DynaLoader ();
 use Exporter ();
  
-$VERSION = '2.1';
+$VERSION = '2.2';
 @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 &setdef &tmpnam
+@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( &flush &getname &remove &rewind &setdef
-                                    &sync &tmpnam &vmsopen &vmssysopen
+                 FUNCTIONS => [ qw( &binmode &flush &getname &remove &rewind
+                                    &setdef &sync &tmpnam &vmsopen &vmssysopen
                                     &waitfh &writeof ) ] );
 
 bootstrap VMS::Stdio $VERSION;
@@ -100,6 +100,7 @@ VMS::Stdio - standard I/O functions via VMS extensions
   close($fh);
   remove("another.file");
   writeof($pipefh);
+  binmode($fh);
 
 =head1 DESCRIPTION
 
@@ -147,6 +148,22 @@ update your code to use the new routines.
 
 =over
 
+=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
@@ -620,6 +637,6 @@ it encounters an error.
 =head1 REVISION
 
 This document was last revised on 13-Oct-1998, for Perl 5.004, 5.005, and
-5.006.
+5.6.0.
 
 =cut
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
index 53b491575dc..22d9a7262cf 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
+++ b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
@@ -1,8 +1,8 @@
 /* VMS::Stdio - VMS extensions to stdio routines 
  *
- * Version:  2.1
- * Author:   Charles Bailey  bailey@genetics.upenn.edu
- * Revised:  24-Mar-1998
+ * Version:  2.2
+ * Author:   Charles Bailey  bailey@newman.upenn.edu
+ * Revised:  18-Jul-1998
  *
  */
 
@@ -125,6 +125,57 @@ constant(name)
 	    ST(0) = &PL_sv_undef;
 
 void
+binmode(fh)
+	SV *	fh
+	PROTOTYPE: $
+	CODE:
+	    IO *io = sv_2io(fh);
+	    FILE *fp = io ? IoOFP(io) : NULL;
+	    char iotype = io ? IoTYPE(io) : '\0';
+	    char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
+	    int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
+	    fpos_t pos;
+	    if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
+	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
+	    }
+	    if (!fgetname(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 == Nullch) *(colon+1) = '\0'; 
+	    if (iotype != '-' && (ret = fgetpos(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 = 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+";
+	    }
+	    if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF;
+	    if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF;
+	    if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
+	    XSRETURN_YES;
+
+
+void
 flush(fp)
 	FILE *	fp
 	PROTOTYPE: $
@@ -365,8 +416,7 @@ writeof(mysv)
 	    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) = &PL_sv_undef;  XSRETURN(1);
+	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
 	    }
 	    if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
 	    if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/test.pl b/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
index 37131deb01e..2f735734c11 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
+++ b/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
@@ -1,4 +1,4 @@
-# Tests for VMS::Stdio v2.1
+# Tests for VMS::Stdio v2.2
 use VMS::Stdio;
 import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);
 
diff --git a/gnu/usr.bin/perl/vms/ext/XSSymSet.pm b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm
index 868a303c01d..679ede4bcf7 100644
--- a/gnu/usr.bin/perl/vms/ext/XSSymSet.pm
+++ b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm
@@ -231,7 +231,7 @@ from this set.
 
 =head1 AUTHOR
 
-Charles Bailey  E<lt>I<bailey@genetics.upenn.edu>E<gt>
+Charles Bailey  E<lt>I<bailey@newman.upenn.edu>E<gt>
 
 =head1 REVISION
 
diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.pm b/gnu/usr.bin/perl/vms/ext/vmsish.pm
index 851d576e792..2fc48530c09 100644
--- a/gnu/usr.bin/perl/vms/ext/vmsish.pm
+++ b/gnu/usr.bin/perl/vms/ext/vmsish.pm
@@ -11,6 +11,7 @@ vmsish - Perl pragma to control VMS-specific language features
     use vmsish 'status';	# or '$?'
     use vmsish 'exit';
     use vmsish 'time';
+    use vmsish 'hushed';
 
     use vmsish;
     no vmsish 'time';
@@ -18,8 +19,8 @@ vmsish - Perl pragma to control VMS-specific language features
 =head1 DESCRIPTION
 
 If no import list is supplied, all possible VMS-specific features are
-assumed.  Currently, there are three VMS-specific features available:
-'status' (a.k.a '$?'), 'exit', and 'time'.
+assumed.  Currently, there are four VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
 
 =over 6
 
@@ -41,6 +42,16 @@ used directly as Perl's exit status.
 This makes all times relative to the local time zone, instead of the
 default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
 
+=item C<vmsish hushed>
+
+This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR
+if Perl terminates with an error status.  This primarily effects error
+exits from things like compiler errors or "standard Perl" runtime errors,
+where text error messages are also generated by Perl.
+
+The error exits from inside VMS.C are generally more serious, and are
+not supressed.
+
 =back
 
 See L<perlmod/Pragmatic Modules>.
@@ -56,21 +67,31 @@ sub bits {
     my $bits = 0;
     my $sememe;
     foreach $sememe (@_) {
-	$bits |= 0x01000000, next if $sememe eq 'status' || $sememe eq '$?';
-	$bits |= 0x02000000, next if $sememe eq 'exit';
-	$bits |= 0x04000000, next if $sememe eq 'time';
+        $bits |= 0x20000000, next if $sememe eq 'hushed';
+        $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
+	$bits |= 0x80000000, next if $sememe eq 'time';
     }
     $bits;
 }
 
 sub import {
     shift;
-    $^H |= bits(@_ ? @_ : qw(status exit time));
+    $^H |= bits(@_ ? @_ : qw(status time hushed));
+    my $sememe;
+
+    foreach $sememe (@_ ? @_ : qw(exit)) {
+        $^H{'vmsish_exit'}   = 1 if $sememe eq 'exit';
+    }
 }
 
 sub unimport {
     shift;
-    $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+    $^H &= ~ bits(@_ ? @_ : qw(status time hushed));
+    my $sememe;
+
+    foreach $sememe (@_ ? @_ : qw(exit)) {
+        $^H{'vmsish_exit'}   = 0 if $sememe eq 'exit';
+    }
 }
 
 1;
diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.t b/gnu/usr.bin/perl/vms/ext/vmsish.t
index f68b3ac89c0..2a5b580bda3 100644
--- a/gnu/usr.bin/perl/vms/ext/vmsish.t
+++ b/gnu/usr.bin/perl/vms/ext/vmsish.t
@@ -3,7 +3,7 @@ BEGIN { unshift @INC, '[-.lib]'; }
 
 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
 
-print "1..16\n";
+print "1..17\n";
 
 #========== vmsish status ==========
 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
@@ -30,10 +30,11 @@ else    { print "ok 5\n";                          }
   else    { print "ok 6\n"; }
 }
 
-#========== vmsish exit ==========
+#========== vmsish exit, messages ==========
 {
   use vmsish qw(status);
-  my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
+
+  $msg = do_a_perl('-e "exit 1"');
   if ($msg !~ /ABORT/) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 7 # subprocess output: |$msg|\n";
@@ -42,7 +43,7 @@ else    { print "ok 5\n";                          }
   if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
   else        { print "ok 8\n"; }
 
-  $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`;
+  $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
   if (length $msg) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 9 # subprocess output: |$msg|\n";
@@ -51,7 +52,7 @@ else    { print "ok 5\n";                          }
   if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
   else              { print "ok 10\n"; }
 
-  $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`;
+  $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
   if ($msg !~ /ABORT/) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 11 # subprocess output: |$msg|\n";
@@ -59,6 +60,14 @@ else    { print "ok 5\n";                          }
   else { print "ok 11\n"; }
   if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
   else        { print "ok 12\n"; }
+
+  $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
+  if ($msg =~ /ABORT/) {
+    $msg =~ s/\n/\\n/g; # keep output on one line
+    print "not ok 13 # subprocess output: |$msg|\n";
+  }
+  else { print "ok 13\n"; }
+
 }
 
 
@@ -93,30 +102,44 @@ else    { print "ok 5\n";                          }
   # an amount, and it renders the test resistant to delays from
   # things like stat() on a file mounted over a slow network link.
   if ($utctime - $vmstime + $offset > 10) {
-    print "not ok 13  # (time) UTC: $utctime  VMS: $vmstime\n";
+    print "not ok 14  # (time) UTC: $utctime  VMS: $vmstime\n";
   }
-  else { print "ok 13\n"; }
+  else { print "ok 14\n"; }
 
   $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
             $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
   $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
             $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
   if ($vmsval - $utcval + $offset > 10) {
-    print "not ok 14  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
+    print "not ok 15  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
   }
-  else { print "ok 14\n"; }
+  else { print "ok 15\n"; }
 
   $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
             $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
   $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
             $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
   if ($vmsval - $utcval + $offset > 10) {
-    print "not ok 15  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
+    print "not ok 16  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
   }
-  else { print "ok 15\n"; }
+  else { print "ok 16\n"; }
 
-  if ($utcmtime - $vmsmtime + $offset > 10) {
-    print "not ok 16  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
+  if ($vmsmtime - $utcmtime + $offset > 10) {
+    print "not ok 17  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
   }
-  else { print "ok 16\n"; }
+  else { print "ok 17\n"; }
+}
+
+#====== need this to make sure error messages come out, even if
+#       they were turned off in invoking procedure
+sub do_a_perl {
+    local *P;
+    open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
+    print P "\$ set message/facil/sever/ident/text\n";
+    print P "\$ $Invoke_Perl @_\n";
+    close P;
+    my $x = `\@vmsish_test.com`;
+    unlink 'vmsish_test.com';
+    return $x;
 }
+