`file-or-directory-permissions': expose more info, add write mode

and add `user-read-bit', etc., to `racket/file'

collects/racket/file.rkt

@@ -24,7 +24,18 @@
          file->list
          display-to-file
          write-to-file
-         display-lines-to-file)
+         display-lines-to-file
+
+         user-read-bit     
+         user-write-bit
+         user-execute-bit
+         group-read-bit
+         group-write-bit
+         group-execute-bit
+         other-read-bit
+         other-write-bit
+         other-execute-bit)
+
 
 (require "private/portlines.rkt")
 
@@ -587,3 +598,13 @@
     (raise-type-error 'display-lines-to-file "list" l))
   (->file 'display-lines-to-file f mode exists
           (lambda (p) (do-lines->port l p newline))))
+
+(define user-read-bit     #o100)
+(define user-write-bit    #o200)
+(define user-execute-bit  #o400)
+(define group-read-bit    #o010)
+(define group-write-bit   #o020)
+(define group-execute-bit #o040)
+(define other-read-bit    #o001)
+(define other-write-bit   #o002)
+(define other-execute-bit #o004)

collects/scribblings/reference/filesystem.scrbl

@@ -286,13 +286,46 @@ called, and the default @racket[fail-thunk] raises
 @racket[exn:fail:filesystem].}
 
 
-@defproc[(file-or-directory-permissions [path path-string?]) (listof symbol?)]{
+@defproc*[([(file-or-directory-permissions [path path-string?] [mode #f #f]) (listof (or/c 'read 'write 'execute))]
+           [(file-or-directory-permissions [path path-string?] [mode 'bits]) (integer-in 0 #xFFFF)]
+           [(file-or-directory-permissions [path path-string?] [mode (integer-in 0 #xFFFF)]) void])]{
 
-Returns a list containing @indexed-racket['read],
+When given one argument or @racket[#f] as the second argument, returns
-@indexed-racket['write], and/or @indexed-racket['execute] for the
+a list containing @indexed-racket['read], @indexed-racket['write],
-given file or directory path. On error (e.g., if no such file exists),
+and/or @indexed-racket['execute] to indicate permission the given file
-the @exnraise[exn:fail:filesystem]. Under @|AllUnix|, permissions are
+or directory path by the current user and group. Under @|AllUnix|,
-checked for the current effective user instead of the real user.}
+permissions are checked for the current effective user instead of the
+real user.
+
+If @racket['bits] is supplied as the second argument, the result is a
+platform-specific integer encoding of the file or directory properties
+(mostly permissions), and the result is independent of the current
+user and group. The lowest nine bits of the encoding are somewhat
+portable, reflecting permissions for the file or directory's owner,
+members of the file or directory's group, or other users:
+
+@itemlist[
+ @item{@racketvalfont{#o100} : owner has read permission}
+ @item{@racketvalfont{#o200} : owner has write permission}
+ @item{@racketvalfont{#o400} : owner has execute permission}
+ @item{@racketvalfont{#o010} : group has read permission}
+ @item{@racketvalfont{#o020} : group has write permission}
+ @item{@racketvalfont{#o040} : group has execute permission}
+ @item{@racketvalfont{#o001} : others have read permission}
+ @item{@racketvalfont{#o002} : others have write permission}
+ @item{@racketvalfont{#o004} : others have execute permission}
+]
+
+See also @racket[user-read-bit], etc. Under Windows, permissions from
+all three (owner, group, and others) are always the same, and read and
+execute permission are always available. Under @|AllUnix|,
+higher bits have a platform-specific meaning.
+
+If an integer is supplied as the second argument, its is used as an
+encoding of properties (mostly permissions) to install for the file.
+
+In all modes, the @exnraise[exn:fail:filesystem] on error (e.g., if no
+such file exists).}
 
 
 @defproc[(file-or-directory-identity [path path-string?]
@@ -1065,11 +1098,26 @@ on @racket[filename] would interfere with replacing @racket[filename]] via
            [(make-lock-file-name [dir path-string?] [name path-string?]) path-string?])]{
 Creates a lock filename by prepending @racket["_LOCK"] on windows or @racket[".LOCK"] on all other platforms
 to the file portion of the path.
-}
 
 @examples[
   #:eval file-eval
-  (make-lock-file-name "/home/george/project/important-file")]
+  (make-lock-file-name "/home/george/project/important-file")]}
+
+@deftogether[(
+@defthing[user-read-bit    @#,schemevalfont{#o100}]
+@defthing[user-write-bit   @#,schemevalfont{#o200}]
+@defthing[user-execute-bit @#,schemevalfont{#o400}]
+@defthing[group-read-bit    @#,schemevalfont{#o010}]
+@defthing[group-write-bit   @#,schemevalfont{#o020}]
+@defthing[group-execute-bit @#,schemevalfont{#o040}]
+@defthing[other-read-bit    @#,schemevalfont{#o001}]
+@defthing[other-write-bit   @#,schemevalfont{#o002}]
+@defthing[other-execute-bit @#,schemevalfont{#o004}]
+)]{
+
+Constants that are useful with @racket[file-or-directory-permissions]
+and bitwise operations such as @racket[bitwise-ior], and
+@racket[bitwise-and].}
 
 
 @(interaction-eval #:eval file-eval (delete-file filename))

collects/tests/racket/file.rktl

@@ -666,6 +666,9 @@
   (close-input-port p)
   (close-input-port q))
 
+;; We should be able to install the current permissions:
+(test (void) file-or-directory-permissions "tmp1" (file-or-directory-permissions "tmp1" 'bits))
+
 (define test-file 
   (open-output-file "tmp2" #:exists 'truncate))
 (write-char #\; test-file)
@@ -1459,6 +1462,9 @@
   (err/rt-test (rename-file-or-directory "tmp1" "tmp11") (fs-reject? 'rename-file-or-directory))
   (err/rt-test (copy-file "tmp1" "tmp11") (fs-reject? 'copy-file))
   (err/rt-test (make-file-or-directory-link "tmp1" "tmp11") (fs-reject? 'make-file-or-directory-link))
+  (err/rt-test (file-or-directory-permissions "tmp1" 7) (fs-reject? 'file-or-directory-permissions))
+  (err/rt-test (file-or-directory-permissions "tmp1" 0) (fs-reject? 'file-or-directory-permissions))
+  (test #t exact-integer? (file-or-directory-permissions "tmp1" 'bits))
   (let ([p (open-input-file "tmp1")])
     (test #t input-port? p)
     (close-input-port p))

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,8 @@
+Version 5.1.0.4
+Change file-or-directory-permission to add 'bits mode
+ and permission-setting mode
+racket/file: add user-read-bit, etc.
+
 Version 5.1.0.2
 Enabled single-precision floats by default
 Added single-flonum?

src/racket/src/file.c

@@ -495,7 +495,7 @@ void scheme_init_file(Scheme_Env *env)
   scheme_add_global_constant("file-or-directory-permissions",
 			     scheme_make_prim_w_arity(file_or_dir_permissions,
 						      "file-or-directory-permissions",
-						      1, 1), 
+						      1, 2), 
 			     env);
   scheme_add_global_constant("file-or-directory-identity",
 			     scheme_make_prim_w_arity(file_identity,
@@ -2102,7 +2102,7 @@ static time_t convert_date(const FILETIME *ft)
 # define MZ_UNC_EXEC 0x4
 
 static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Object **date,
-		    mzlonglong *filesize)
+		    mzlonglong *filesize, int set_flags)
   /* dirname must be absolute */
 {
   /* Note: stat() doesn't work with UNC "drive" names or \\?\ paths.
@@ -2147,22 +2147,36 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
     errno = -1;
     return 0;
   } else {
-    if (must_be_dir && !(GET_FF_ATTRIBS(fd) & FF_A_DIR))
+    if (set_flags != -1) {
-      return 0;
+      DWORD attrs = GET_FF_ATTRIBS(fd);
-    if (flags)
+
-      *flags = MZ_UNC_READ | MZ_UNC_EXEC | ((GET_FF_ATTRIBS(fd) & FF_A_RDONLY) ? 0 : MZ_UNC_WRITE);
+      if (!(set_flags & MZ_UNC_WRITE))
-    if (date) {
+        attrs |= FF_A_RDONLY;
-      Scheme_Object *dt;
+      else if (attrs & FF_A_RDONLY)
-      time_t mdt;
+        attrs -= FF_A_RDONLY;
-      mdt = GET_FF_MODDATE(fd);
+      
-      dt = scheme_make_integer_value_from_time(mdt);
+      if (!SetFileAttributesW(WIDE_PATH(copy), attrs)) {
-      *date = dt;
+        errno = -1;
-    }
+        return 0;
-    if (isdir) {
+      }
-      *isdir = (GET_FF_ATTRIBS(fd) & FF_A_DIR);
+    } else {
-    }
+      if (must_be_dir && !(GET_FF_ATTRIBS(fd) & FF_A_DIR))
-    if (filesize) {
+        return 0;
-      *filesize = ((mzlonglong)fd.nFileSizeHigh << 32) | fd.nFileSizeLow;
+      if (flags)
+        *flags = MZ_UNC_READ | MZ_UNC_EXEC | ((GET_FF_ATTRIBS(fd) & FF_A_RDONLY) ? 0 : MZ_UNC_WRITE);
+      if (date) {
+        Scheme_Object *dt;
+        time_t mdt;
+        mdt = GET_FF_MODDATE(fd);
+        dt = scheme_make_integer_value_from_time(mdt);
+        *date = dt;
+      }
+      if (isdir) {
+        *isdir = (GET_FF_ATTRIBS(fd) & FF_A_DIR);
+      }
+      if (filesize) {
+        *filesize = ((mzlonglong)fd.nFileSizeHigh << 32) | fd.nFileSizeLow;
+      }
     }
     return 1;
   }
@@ -2188,7 +2202,7 @@ int scheme_file_exists(char *filename)
 
   {
     int isdir;
-    return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL)
+    return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL, -1)
 	    && !isdir);
   }
 #  else
@@ -2212,7 +2226,7 @@ int scheme_directory_exists(char *dirname)
 #  ifdef DOS_FILE_SYSTEM
   int isdir;
 
-  return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL)
+  return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL, -1)
 	  && isdir);
 #  else
   struct MSC_IZE(stat) buf;
@@ -5283,7 +5297,7 @@ static Scheme_Object *file_modify_seconds(int argc, Scheme_Object **argv)
     int len = strlen(file);
     Scheme_Object *secs;
 
-    if (UNC_stat(file, len, NULL, NULL, &secs, NULL))
+    if (UNC_stat(file, len, NULL, NULL, &secs, NULL, -1))
       return secs;
   } else 
 # endif
@@ -5359,14 +5373,38 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *l = scheme_null;
   char *filename;
+  int as_bits = 0, set_bits = 0, new_bits = 0;
+  int err_val = 0;
 
   if (!SCHEME_PATH_STRINGP(argv[0]))
     scheme_wrong_type("file-or-directory-permissions", SCHEME_PATH_STRING_STR, 0, argc, argv);
+  if (argc > 1) {
+    l = argv[1];
+    if (SCHEME_FALSEP(l)) {
+    } else if (SCHEME_SYMBOLP(l) && !SCHEME_SYM_WEIRDP(l)
+        && !strcmp("bits", SCHEME_SYM_VAL(l))) {
+      as_bits = 1;
+    } else {
+      as_bits = -1;
+      l = argv[1];
+      if (SCHEME_INTP(l) 
+          && (SCHEME_INT_VAL(l) >= 0) 
+          && (SCHEME_INT_VAL(l) <= 0xFFFF)) {
+        set_bits = 1;
+        new_bits = SCHEME_INT_VAL(l);
+      } else
+        scheme_wrong_type("file-or-directory-permissions", 
+                          "#f, 'bits, or an exact integer in [0, 65535]",
+                          1, argc, argv);
+    }
+  }
 
   filename = scheme_expand_string_filename(argv[0],
 					   "file-or-directory-permissions",
 					   NULL,
-					   SCHEME_GUARD_FILE_READ);
+					   (set_bits
+                                            ? SCHEME_GUARD_FILE_WRITE
+                                            : SCHEME_GUARD_FILE_READ));
 
 # ifdef NO_STAT_PROC
   return scheme_null;
@@ -5383,7 +5421,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
     egid = getegid();
   }
 
-  if ((uid == euid) && (gid == egid)) {
+  if (!as_bits && (uid == euid) && (gid == egid)) {
     /* Not setuid; use access() */
     int read, write, execute, ok;
     
@@ -5430,68 +5468,119 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
     {
       /* Use stat, because setuid, or because or no user info available */
       struct stat buf;
-      int read, write, execute;
+      int ok, read, write, execute;
 
-      if (stat(filename, &buf))
+      do {
+        ok = stat(filename, &buf);
+      } while ((ok == -1) && (errno == EINTR));
+
+      if (ok)
 	l = NULL;
       else {
+        if (as_bits) {
+          if (set_bits) {
+            do {
+              ok = chmod(filename, new_bits);
+            } while ((ok == -1) && (errno == EINTR));
+            if (ok)
+              l = NULL;
+            else
+              l = scheme_void;
+          } else {
+            int bits = buf.st_mode;
+#   ifdef S_IFMT
+            bits -= (bits & S_IFMT);
+#   endif
+            l = scheme_make_integer(bits);
+          }
+        } else {
 #   ifndef NO_UNIX_USERS
-	if (euid == 0) {
+          if (euid == 0) {
-	  /* Super-user can read/write anything, and can
+            /* Super-user can read/write anything, and can
-	     execute anything that someone can execute */
+               execute anything that someone can execute */
-	  read = 1;
+            read = 1;
-	  write = 1;
+            write = 1;
-	  execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
+            execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
-	} else if (buf.st_uid == euid) {
+          } else if (buf.st_uid == euid) {
-	  read = !!(buf.st_mode & S_IRUSR);
+            read = !!(buf.st_mode & S_IRUSR);
-	  write = !!(buf.st_mode & S_IWUSR);
+            write = !!(buf.st_mode & S_IWUSR);
-	  execute = !!(buf.st_mode & S_IXUSR);
+            execute = !!(buf.st_mode & S_IXUSR);
-	} else if ((egid == buf.st_gid) || user_in_group(euid, buf.st_gid)) {
+          } else if ((egid == buf.st_gid) || user_in_group(euid, buf.st_gid)) {
-	  read = !!(buf.st_mode & S_IRGRP);
+            read = !!(buf.st_mode & S_IRGRP);
-	  write = !!(buf.st_mode & S_IWGRP);
+            write = !!(buf.st_mode & S_IWGRP);
-	  execute = !!(buf.st_mode & S_IXGRP);
+            execute = !!(buf.st_mode & S_IXGRP);
-	} else {
+          } else {
-	  read = !!(buf.st_mode & S_IROTH);
+            read = !!(buf.st_mode & S_IROTH);
-	  write = !!(buf.st_mode & S_IWOTH);
+            write = !!(buf.st_mode & S_IWOTH);
-	  execute = !!(buf.st_mode & S_IXOTH);
+            execute = !!(buf.st_mode & S_IXOTH);
-	}
+          }
 #   else
-	read = !!(buf.st_mode & (S_IRUSR | S_IRGRP | S_IROTH));
+          read = !!(buf.st_mode & (S_IRUSR | S_IRGRP | S_IROTH));
-	write = !!(buf.st_mode & (S_IWUSR | S_IWGRP | S_IWOTH));
+          write = !!(buf.st_mode & (S_IWUSR | S_IWGRP | S_IWOTH));
-	execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
+          execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
 #   endif
 	
-	if (read)
+          if (read)
-	  l = scheme_make_pair(read_symbol, l);
+            l = scheme_make_pair(read_symbol, l);
-	if (write)
+          if (write)
-	  l = scheme_make_pair(write_symbol, l);
+            l = scheme_make_pair(write_symbol, l);
-	if (execute)
+          if (execute)
-	  l = scheme_make_pair(execute_symbol, l);
+            l = scheme_make_pair(execute_symbol, l);
+        }
       }
     }
+  if (!l)
+    err_val = errno;
 #  endif  
 #  ifdef DOS_FILE_SYSTEM
   {
     int len = strlen(filename);
     int flags;
-    
+
-    if (UNC_stat(filename, len, &flags, NULL, NULL, NULL)) {
+    if (set_bits) {
-      if (flags & MZ_UNC_READ)
+      int ALWAYS_SET_BITS = ((MZ_UNC_READ | MZ_UNC_EXEC)
-	l = scheme_make_pair(read_symbol, l);
+                             | ((MZ_UNC_READ | MZ_UNC_EXEC) << 3)
-      if (flags & MZ_UNC_WRITE)
+                             | ((MZ_UNC_READ | MZ_UNC_EXEC) << 6));
-	l = scheme_make_pair(write_symbol, l);
+      if (((new_bits & ALWAYS_SET_BITS) != ALWAYS_SET_BITS)
-      if (flags & MZ_UNC_EXEC)
+          || ((new_bits & MZ_UNC_WRITE) != ((new_bits & (MZ_UNC_WRITE << 3)) >> 3))
-	l = scheme_make_pair(execute_symbol, l);
+          || ((new_bits & MZ_UNC_WRITE) != ((new_bits & (MZ_UNC_WRITE << 6)) >> 6))
+          || (new_bits >= (1 << 9)))
+        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                         "file-or-directory-permissions: update of \"%q\" failed:"
+                         " unsupported bit combination in %d",
+                         filename_for_error(argv[0]),
+                         new_bits);
+      l = scheme_void;
     } else
+      new_bits = -1;
+    
+    if (UNC_stat(filename, len, &flags, NULL, NULL, NULL, new_bits)) {
+      if (set_bits)
+	l = scheme_void;
+      else if (as_bits)
+        l = scheme_make_integer(flags | (flags << 3) | (flags << 6));
+      else {
+        if (flags & MZ_UNC_READ)
+          l = scheme_make_pair(read_symbol, l);
+        if (flags & MZ_UNC_WRITE)
+          l = scheme_make_pair(write_symbol, l);
+        if (flags & MZ_UNC_EXEC)
+          l = scheme_make_pair(execute_symbol, l);
+      }
+    } else {
       l = NULL;
+      err_val = GetLastError();
+    }
   }
 #  endif
 # endif
   
   if (!l) {
     scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
-		     "file-or-directory-permissions: file or directory not found: \"%q\"",
+		     "file-or-directory-permissions: %s of \"%q\" failed: %e",
-		     filename_for_error(argv[0]));
+                     set_bits ? "update" : "access",
+		     filename_for_error(argv[0]),
+                     err_val);
   }
 
   return l;
@@ -5531,7 +5620,7 @@ static Scheme_Object *file_size(int argc, Scheme_Object *argv[])
 
 #ifdef DOS_FILE_SYSTEM
  {
-   if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, &len)) {
+   if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, &len, -1)) {
      return scheme_make_integer_value_from_long_long(len);
    }
  }

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.1.0.3"
+#define MZSCHEME_VERSION "5.1.0.4"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)