[patch@31846] vms stat and chmod fixes.

From: "John E. Malmberg" <wb8tyw@qsl.net>
Message-ID: <46E7567A.8090203@qsl.net>

p4raw-id: //depot/perl@31850

2 files changed, 83 insertions, 1 deletions

diff --git a/vms/vms.c b/vms/vms.c
index de9c5c40f6..40e80a2f7d 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2083,6 +2083,61 @@ Perl_my_chdir(pTHX_ const char *dir)
 /*}}}*/
 
 
+/*{{{int my_chmod(char *, mode_t)*/
+int
+Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
+{
+  STRLEN speclen = strlen(file_spec);
+
+  /* zero length string sometimes gives ACCVIO */
+  if (speclen == 0) return -1;
+
+  /* some versions of CRTL chmod() doesn't tolerate trailing /, since
+   * that implies null file name/type.  However, it's commonplace under Unix,
+   * so we'll allow it for a gain in portability.
+   *
+   * Tests are showing that chmod() on VMS 8.3 is only accepting directories
+   * in VMS file.dir notation.
+   */
+  if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
+    char *vms_src, *vms_dir, *rslt;
+    int ret = -1;
+    errno = EIO;
+
+    /* First convert this to a VMS format specification */
+    vms_src = PerlMem_malloc(VMS_MAXRSS);
+    if (vms_src == NULL)
+	_ckvmssts(SS$_INSFMEM);
+
+    rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
+    if (rslt == NULL) {
+	/* If we fail, then not a file specification */
+	PerlMem_free(vms_src);
+	errno = EIO;
+	return -1;
+    }
+
+    /* Now make it a directory spec so chmod is happy */
+    vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
+    if (vms_dir == NULL)
+	_ckvmssts(SS$_INSFMEM);
+    rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
+    PerlMem_free(vms_src);
+
+    /* Now do it */
+    if (rslt != NULL) {
+	ret = chmod(vms_dir, mode);
+    } else {
+	errno = EIO;
+    }
+    PerlMem_free(vms_dir);
+    return ret;
+  }
+  else return chmod(file_spec, mode);
+}  /* end of my_chmod */
+/*}}}*/
+
+
 /*{{{FILE *my_tmpfile()*/
 FILE *
 my_tmpfile(void)
@@ -11746,6 +11801,27 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
 	retval = lstat(temp_fspec,(stat_t *) statbufp);
       save_spec = temp_fspec;
     }
+/*
+ * In debugging, on 8.3 Alpha, I found a case where stat was returning a
+ * file not found error for a directory named foo:[bar.t] or /foo/bar/t
+ * and lstat was working correctly for the same file.
+ * The only syntax that was working for stat was "foo:[bar]t.dir".
+ *
+ * Other directories with the same syntax worked fine.
+ * So work around the problem when it shows up here.
+ */
+    if (retval) {
+        int save_errno = errno;
+	if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
+	    if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
+		retval = stat(fileified, (stat_t *) statbufp);
+		save_spec = fileified;
+	    }
+	}
+	/* Restore the errno value if third stat does not succeed */
+	if (retval != 0)
+	    errno = save_errno;
+    }
 #if __CRTL_VER >= 80200000 && !defined(__VAX)
   } else {
     if (lstat_flag == 0)
diff --git a/vms/vmsish.h b/vms/vmsish.h
index 05d49229c3..a9452eb4f1 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -175,6 +175,7 @@
 #define kill_file		Perl_kill_file
 #define my_utime		Perl_my_utime
 #define my_chdir		Perl_my_chdir
+#define my_chmod		Perl_my_chmod
 #define do_aspawn		Perl_do_aspawn
 #define seekdir			Perl_seekdir
 #define my_gmtime		Perl_my_gmtime
@@ -239,6 +240,7 @@
 #define kill_file(a)		Perl_kill_file(aTHX_ a)
 #define my_utime(a,b)		Perl_my_utime(aTHX_ a,b)
 #define my_chdir(a)		Perl_my_chdir(aTHX_ a)
+#define my_chmod(a,b)		Perl_my_chmod(aTHX_ a,b)
 #define do_aspawn(a,b,c)	Perl_do_aspawn(aTHX_ a,b,c)
 #define seekdir(a,b)		Perl_seekdir(aTHX_ a,b)
 #define my_gmtime(a)		Perl_my_gmtime(aTHX_ a)
@@ -627,12 +629,15 @@ struct utimbuf {
 /* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */
 #define Mkdir(dir,mode) Perl_my_mkdir(aTHX_ (dir),(mode))
 #define Chdir(dir) my_chdir((dir))
+#ifndef DONT_MASK_RTL_CALLS
+#define chmod(file_spec, mode) my_chmod((file_spec), (mode))
+#endif
 
 /* Use our own stat() clones, which handle Unix-style directory names */
 #define Stat(name,bufptr) flex_stat(name,bufptr)
 #define Fstat(fd,bufptr) Perl_flex_fstat(aTHX_ fd,bufptr)
 #ifndef DONT_MASK_RTL_CALLS
-#define lstat(name, bufptr) Perl_flex_lstat(name, bufptr)
+#define lstat(name, bufptr) flex_lstat(name, bufptr)
 #endif
 
 /* Setup for the dirent routines:
@@ -914,6 +919,7 @@ Pid_t	Perl_my_waitpid (pTHX_ Pid_t, int *, int);
 char *	my_gconvert (double, int, int, char *);
 int	Perl_kill_file (pTHX_ const char *);
 int	Perl_my_chdir (pTHX_ const char *);
+int	Perl_my_chmod(pTHX_ const char *, mode_t);
 FILE *	Perl_my_tmpfile (void);
 #ifndef HOMEGROWN_POSIX_SIGNALS
 int	Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);