From a5a7076fe0eec2ac85009d22e8d75f5aea8a612f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Mar 2011 15:49:11 -0600 Subject: [PATCH] `file-or-directory-permissions': expose more info, add write mode and add `user-read-bit', etc., to `racket/file' --- collects/racket/file.rkt | 23 +- .../scribblings/reference/filesystem.scrbl | 64 +++++- collects/tests/racket/file.rktl | 6 + doc/release-notes/racket/HISTORY.txt | 5 + src/racket/src/file.c | 217 ++++++++++++------ src/racket/src/schvers.h | 4 +- 6 files changed, 244 insertions(+), 75 deletions(-) diff --git a/collects/racket/file.rkt b/collects/racket/file.rkt index d3e4cea6b3..f8fec8bbc7 100644 --- a/collects/racket/file.rkt +++ b/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) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index ad26f166aa..e32bb4ee87 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/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], -@indexed-racket['write], and/or @indexed-racket['execute] for the -given file or directory path. On error (e.g., if no such file exists), -the @exnraise[exn:fail:filesystem]. Under @|AllUnix|, permissions are -checked for the current effective user instead of the real user.} +When given one argument or @racket[#f] as the second argument, returns +a list containing @indexed-racket['read], @indexed-racket['write], +and/or @indexed-racket['execute] to indicate permission the given file +or directory path by the current user and group. Under @|AllUnix|, +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)) diff --git a/collects/tests/racket/file.rktl b/collects/tests/racket/file.rktl index e27d22cffa..622982787c 100644 --- a/collects/tests/racket/file.rktl +++ b/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)) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 18e7f1057f..bd4df035c7 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/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? diff --git a/src/racket/src/file.c b/src/racket/src/file.c index 41f2f10bb8..fa6a79a6a1 100644 --- a/src/racket/src/file.c +++ b/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)) - return 0; - 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; + if (set_flags != -1) { + DWORD attrs = GET_FF_ATTRIBS(fd); + + if (!(set_flags & MZ_UNC_WRITE)) + attrs |= FF_A_RDONLY; + else if (attrs & FF_A_RDONLY) + attrs -= FF_A_RDONLY; + + if (!SetFileAttributesW(WIDE_PATH(copy), attrs)) { + errno = -1; + return 0; + } + } else { + if (must_be_dir && !(GET_FF_ATTRIBS(fd) & FF_A_DIR)) + return 0; + 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) { - /* Super-user can read/write anything, and can - execute anything that someone can execute */ - read = 1; - write = 1; - execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH)); - } else if (buf.st_uid == euid) { - read = !!(buf.st_mode & S_IRUSR); - write = !!(buf.st_mode & S_IWUSR); - execute = !!(buf.st_mode & S_IXUSR); - } else if ((egid == buf.st_gid) || user_in_group(euid, buf.st_gid)) { - read = !!(buf.st_mode & S_IRGRP); - write = !!(buf.st_mode & S_IWGRP); - execute = !!(buf.st_mode & S_IXGRP); - } else { - read = !!(buf.st_mode & S_IROTH); - write = !!(buf.st_mode & S_IWOTH); - execute = !!(buf.st_mode & S_IXOTH); - } + if (euid == 0) { + /* Super-user can read/write anything, and can + execute anything that someone can execute */ + read = 1; + write = 1; + execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH)); + } else if (buf.st_uid == euid) { + read = !!(buf.st_mode & S_IRUSR); + write = !!(buf.st_mode & S_IWUSR); + execute = !!(buf.st_mode & S_IXUSR); + } else if ((egid == buf.st_gid) || user_in_group(euid, buf.st_gid)) { + read = !!(buf.st_mode & S_IRGRP); + write = !!(buf.st_mode & S_IWGRP); + execute = !!(buf.st_mode & S_IXGRP); + } else { + read = !!(buf.st_mode & S_IROTH); + write = !!(buf.st_mode & S_IWOTH); + execute = !!(buf.st_mode & S_IXOTH); + } # else - read = !!(buf.st_mode & (S_IRUSR | S_IRGRP | S_IROTH)); - write = !!(buf.st_mode & (S_IWUSR | S_IWGRP | S_IWOTH)); - execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH)); + read = !!(buf.st_mode & (S_IRUSR | S_IRGRP | S_IROTH)); + write = !!(buf.st_mode & (S_IWUSR | S_IWGRP | S_IWOTH)); + execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH)); # endif - if (read) - l = scheme_make_pair(read_symbol, l); - if (write) - l = scheme_make_pair(write_symbol, l); - if (execute) - l = scheme_make_pair(execute_symbol, l); + if (read) + l = scheme_make_pair(read_symbol, l); + if (write) + l = scheme_make_pair(write_symbol, l); + if (execute) + 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 (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); + + if (set_bits) { + int ALWAYS_SET_BITS = ((MZ_UNC_READ | MZ_UNC_EXEC) + | ((MZ_UNC_READ | MZ_UNC_EXEC) << 3) + | ((MZ_UNC_READ | MZ_UNC_EXEC) << 6)); + if (((new_bits & ALWAYS_SET_BITS) != ALWAYS_SET_BITS) + || ((new_bits & MZ_UNC_WRITE) != ((new_bits & (MZ_UNC_WRITE << 3)) >> 3)) + || ((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\"", - filename_for_error(argv[0])); + "file-or-directory-permissions: %s of \"%q\" failed: %e", + 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); } } diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 3c428bcea4..3c2d1dd4b4 100644 --- a/src/racket/src/schvers.h +++ b/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)