applied suggested patch, modulo superseded parts

	Message-id: <01J8YFGIHW2W001E7S@mail.newman.upenn.edu>
	Subject: [PATCH 5.005_56] Miscellaneous VMS-specific fixes

p4raw-id: //depot/perl@3153

5 files changed, 162 insertions, 82 deletions

diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
index 04b339725f..d485e0e159 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.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
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index 53b491575d..22d9a7262c 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.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/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
index 37131deb01..2f735734c1 100755
--- a/vms/ext/Stdio/test.pl
+++ b/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/vms/test.com b/vms/test.com
index 207aad9087..15c0e8a949 100644
--- a/vms/test.com
+++ b/vms/test.com
@@ -102,7 +102,8 @@ use Config;
 @compexcl=('cpp.t');
 @ioexcl=('argv.t','dup.t','fs.t','pipe.t');
 @libexcl=('db-btree.t','db-hash.t','db-recno.t',
-          'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t',
+          'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
+          'io_sock.t', 'io_unix.t',
           'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
 
 # Note: POSIX is not part of basic build, but can be built
diff --git a/vms/vmsish.h b/vms/vmsish.h
index 7fce3afe0b..4b45cf4968 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -2,8 +2,8 @@
  *
  * VMS-specific C header file for perl5.
  *
- * Last revised: 18-Feb-1997 by Charles Bailey  bailey@genetics.upenn.edu
- * Version: 5.3.28
+ * Last revised: 16-Sep-1998 by Charles Bailey  bailey@newman.upenn.edu
+ * Version: 5.5.2
  */
 
 #ifndef __vmsish_h_included
@@ -64,13 +64,17 @@
 #  define DONT_MASK_RTL_CALLS
 #endif
 
-    /* defined for vms.c so we can see CRTL |  defined for a2p */
+/* Note that we do, in fact, have this */
+#define HAS_GETENV_SV
+
 #ifndef DONT_MASK_RTL_CALLS
 #  ifdef getenv
 #    undef getenv
 #  endif
-#  define getenv(v) my_getenv(v)  /* getenv used for regular logical names */
+  /* getenv used for regular logical names */
+#  define getenv(v) my_getenv(v,TRUE)
 #endif
+#define getenv_sv(v) my_getenv_sv(v,TRUE)
 
 /* DECC introduces this routine in the RTL as of VMS 7.0; for now,
  * we'll use ours, since it gives us the full VMS exit status. */
@@ -83,66 +87,68 @@
 #define DONT_DECLARE_STD 1
 
 /* Our own contribution to PerlShr's global symbols . . . */
-#  define my_trnlnm		Perl_my_trnlnm
-#  define my_getenv		Perl_my_getenv
-#  define prime_env_iter	Perl_prime_env_iter
-#  define my_setenv		Perl_my_setenv
-#  define my_crypt		Perl_my_crypt
-#  define my_waitpid		Perl_my_waitpid
-#  define my_gconvert		Perl_my_gconvert
-#  define do_rmdir		Perl_do_rmdir
-#  define kill_file		Perl_kill_file
-#  define my_mkdir		Perl_my_mkdir
-#  define my_utime		Perl_my_utime
-#  define rmsexpand	Perl_rmsexpand
-#  define rmsexpand_ts	Perl_rmsexpand_ts
-#  define fileify_dirspec	Perl_fileify_dirspec
-#  define fileify_dirspec_ts	Perl_fileify_dirspec_ts
-#  define pathify_dirspec	Perl_pathify_dirspec
-#  define pathify_dirspec_ts	Perl_pathify_dirspec_ts
-#  define tounixspec		Perl_tounixspec
-#  define tounixspec_ts		Perl_tounixspec_ts
-#  define tovmsspec		Perl_tovmsspec
-#  define tovmsspec_ts		Perl_tovmsspec_ts
-#  define tounixpath		Perl_tounixpath
-#  define tounixpath_ts		Perl_tounixpath_ts
-#  define tovmspath		Perl_tovmspath
-#  define tovmspath_ts		Perl_tovmspath_ts
-#  define vms_image_init	Perl_vms_image_init
-#  define opendir		Perl_opendir
-#  define readdir		Perl_readdir
-#  define telldir		Perl_telldir
-#  define seekdir		Perl_seekdir
-#  define closedir		Perl_closedir
-#  define vmsreaddirversions	Perl_vmsreaddirversions
-#  define my_gmtime		Perl_my_gmtime
-#  define my_localtime		Perl_my_localtime
-#  define my_time		Perl_my_time
-#  define my_sigemptyset        Perl_my_sigemptyset
-#  define my_sigfillset         Perl_my_sigfillset
-#  define my_sigaddset          Perl_my_sigaddset
-#  define my_sigdelset          Perl_my_sigdelset
-#  define my_sigismember        Perl_my_sigismember
-#  define my_sigprocmask        Perl_my_sigprocmask
-#  define cando_by_name		Perl_cando_by_name
-#  define flex_fstat		Perl_flex_fstat
-#  define flex_stat		Perl_flex_stat
-#  define trim_unixpath		Perl_trim_unixpath
-#  define my_vfork		Perl_my_vfork
-#  define vms_do_aexec		Perl_vms_do_aexec
-#  define vms_do_exec		Perl_vms_do_exec
-#  define do_aspawn		Perl_do_aspawn
-#  define do_spawn		Perl_do_spawn
-#  define my_fwrite		Perl_my_fwrite
-#  define my_flush		Perl_my_flush
-#  define my_binmode		Perl_my_binmode
-#  define my_getpwnam		Perl_my_getpwnam
-#  define my_getpwuid		Perl_my_getpwuid
-#  define my_getpwent		Perl_my_getpwent
-#  define my_endpwent		Perl_my_endpwent
-#  define my_getlogin		Perl_my_getlogin
-#  define rmscopy		Perl_rmscopy
-#  define init_os_extras	Perl_init_os_extras
+#define vmstrnenv		Perl_vmstrnenv
+#define my_trnlnm		Perl_my_trnlnm
+#define my_getenv		Perl_my_getenv
+#define my_getenv_sv		Perl_my_getenv_sv
+#define prime_env_iter	Perl_prime_env_iter
+#define vmssetenv		Perl_vmssetenv
+#define my_setenv		Perl_my_setenv
+#define my_crypt		Perl_my_crypt
+#define my_waitpid		Perl_my_waitpid
+#define my_gconvert		Perl_my_gconvert
+#define do_rmdir		Perl_do_rmdir
+#define kill_file		Perl_kill_file
+#define my_mkdir		Perl_my_mkdir
+#define my_utime		Perl_my_utime
+#define rmsexpand	Perl_rmsexpand
+#define rmsexpand_ts	Perl_rmsexpand_ts
+#define fileify_dirspec	Perl_fileify_dirspec
+#define fileify_dirspec_ts	Perl_fileify_dirspec_ts
+#define pathify_dirspec	Perl_pathify_dirspec
+#define pathify_dirspec_ts	Perl_pathify_dirspec_ts
+#define tounixspec		Perl_tounixspec
+#define tounixspec_ts		Perl_tounixspec_ts
+#define tovmsspec		Perl_tovmsspec
+#define tovmsspec_ts		Perl_tovmsspec_ts
+#define tounixpath		Perl_tounixpath
+#define tounixpath_ts		Perl_tounixpath_ts
+#define tovmspath		Perl_tovmspath
+#define tovmspath_ts		Perl_tovmspath_ts
+#define vms_image_init	Perl_vms_image_init
+#define opendir		Perl_opendir
+#define readdir		Perl_readdir
+#define telldir		Perl_telldir
+#define seekdir		Perl_seekdir
+#define closedir		Perl_closedir
+#define vmsreaddirversions	Perl_vmsreaddirversions
+#define my_gmtime		Perl_my_gmtime
+#define my_localtime		Perl_my_localtime
+#define my_time		Perl_my_time
+#define my_sigemptyset        Perl_my_sigemptyset
+#define my_sigfillset         Perl_my_sigfillset
+#define my_sigaddset          Perl_my_sigaddset
+#define my_sigdelset          Perl_my_sigdelset
+#define my_sigismember        Perl_my_sigismember
+#define my_sigprocmask        Perl_my_sigprocmask
+#define cando_by_name		Perl_cando_by_name
+#define flex_fstat		Perl_flex_fstat
+#define flex_stat		Perl_flex_stat
+#define trim_unixpath		Perl_trim_unixpath
+#define my_vfork		Perl_my_vfork
+#define vms_do_aexec		Perl_vms_do_aexec
+#define vms_do_exec		Perl_vms_do_exec
+#define do_aspawn		Perl_do_aspawn
+#define do_spawn		Perl_do_spawn
+#define my_fwrite		Perl_my_fwrite
+#define my_flush		Perl_my_flush
+#define my_getpwnam		Perl_my_getpwnam
+#define my_getpwuid		Perl_my_getpwuid
+#define my_getpwent		Perl_my_getpwent
+#define my_endpwent		Perl_my_endpwent
+#define my_getlogin		Perl_my_getlogin
+#define rmscopy		Perl_rmscopy
+#define init_os_extras	Perl_init_os_extras
 
 /* Delete if at all possible, changing protections if necessary. */
 #define unlink kill_file
@@ -208,6 +214,9 @@
 #define VMSISH_EXIT	TEST_VMSISH(HINT_M_VMSISH_EXIT)
 #define VMSISH_TIME	TEST_VMSISH(HINT_M_VMSISH_TIME)
 
+/* Flags for vmstrnenv() */
+#define PERL__TRNENV_SECURE 0x01
+
 /* Handy way to vet calls to VMS system services and RTL routines. */
 #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
   if (!((__ckvms_sts=(call))&1)) { \
@@ -277,7 +286,7 @@
  *	that a file is in "binary" mode -- that is, that no translation
  *	of bytes occurs on read or write operations.
  */
-#define USEMYBINMODE
+#undef USEMYBINMODE
 
 /* Stat_t:
  *	This symbol holds the type used to declare buffers for information
@@ -403,7 +412,8 @@ struct utimbuf {
 #define DYNAMIC_ENV_FETCH 1
 #define ENV_HV_NAME "%EnV%VmS%"
   /* Special getenv function for retrieving %ENV elements. */
-#define ENV_getenv(v) my_getenv(v)
+#define ENVgetenv(v) my_getenv(v,FALSE)
+#define ENVgetenv_sv(v) my_getenv_sv(v,FALSE)
 
 
 /* Thin jacket around cuserid() tomatch Unix' calling sequence */
@@ -568,8 +578,11 @@ void	prime_env_iter _((void));
 void	init_os_extras _(());
 /* prototype section start marker; `typedef' passes through cpp */
 typedef char  __VMS_PROTOTYPES__;
-int	my_trnlnm _((char *, char *, unsigned long int));
-char *	my_getenv _((const char *));
+int	vmstrnenv _((const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int));
+int	my_trnlnm _((const char *, char *, unsigned long int));
+char *	my_getenv _((const char *, bool));
+SV *	my_getenv_sv _((const char *, bool));
+int	vmssetenv _((char *, char *, struct dsc$descriptor_s **));
 char *	my_crypt _((const char *, const char *));
 Pid_t	my_waitpid _((Pid_t, int *, int));
 char *	my_gconvert _((double, int, int, char *));
@@ -620,7 +633,6 @@ unsigned long int	do_aspawn _((void *, void **, void **));
 unsigned long int	do_spawn _((char *));
 int	my_fwrite _((void *, size_t, size_t, FILE *));
 int	my_flush _((FILE *));
-FILE *	my_binmode _((FILE *, char));
 struct passwd *	my_getpwnam _((char *name));
 struct passwd *	my_getpwuid _((Uid_t uid));
 struct passwd *	my_getpwent _(());