Introduced new predicates working on file-info records.
This commit is contained in:
mainzelm
parent
96238c00c8
commit
6bb8778437
|
|
@ -36,53 +36,70 @@
|
|||
;;;
|
||||
;;; Otherwise, signals an error.
|
||||
|
||||
(define (file-not-accessible? perms fd/port/fname)
|
||||
(define (fd/port/fname-not-accessible? perms fd/port/fname)
|
||||
(with-errno-handler ((err data)
|
||||
((errno/acces) 'search-denied)
|
||||
((errno/notdir) 'no-directory)
|
||||
|
||||
;; If the file doesn't exist, we usually return
|
||||
;; 'nonexistent, but we special-case writability
|
||||
;; for the directory check.
|
||||
((errno/noent)
|
||||
(and (or (zero? (bitwise-and perms 2))
|
||||
;; This string? test *has* to return #t.
|
||||
;; If fd/port/fname is an fd or a port,
|
||||
;; we wouldn't get an errno/noent error!
|
||||
;; Just being paranoid...
|
||||
(not (string? fd/port/fname))
|
||||
;; OK, check to see if we can create
|
||||
;; files in the directory.
|
||||
(fd/port/fname-not-accessible?
|
||||
2
|
||||
(directory-as-file-name
|
||||
(file-name-directory fd/port/fname))))
|
||||
'nonexistent)))
|
||||
(file-info-not-accessible? perms
|
||||
(file-info fd/port/fname))))
|
||||
|
||||
(define (file-info-not-accessible? perms info)
|
||||
(let ((uid (user-effective-uid)))
|
||||
(with-errno-handler ((err data)
|
||||
((errno/acces) 'search-denied)
|
||||
((errno/notdir) 'no-directory)
|
||||
(and (let ((acc (file-info:mode info)))
|
||||
(cond ((zero? uid) #f) ; Root can do as he wishes.
|
||||
|
||||
;; If the file doesn't exist, we usually return
|
||||
;; 'nonexistent, but we special-case writability
|
||||
;; for the directory check.
|
||||
((errno/noent)
|
||||
(and (or (zero? (bitwise-and perms 2))
|
||||
;; This string? test *has* to return #t.
|
||||
;; If fd/port/fname is an fd or a port,
|
||||
;; we wouldn't get an errno/noent error!
|
||||
;; Just being paranoid...
|
||||
(not (string? fd/port/fname))
|
||||
;; OK, check to see if we can create
|
||||
;; files in the directory.
|
||||
(file-not-accessible? 2
|
||||
(directory-as-file-name
|
||||
(file-name-directory fd/port/fname))))
|
||||
'nonexistent)))
|
||||
|
||||
(and (let* ((info (file-info fd/port/fname))
|
||||
(acc (file-info:mode info)))
|
||||
(cond ((zero? uid) #f) ; Root can do as he wishes.
|
||||
|
||||
((= (file-info:uid info) (user-effective-uid)) ; User
|
||||
(zero? (bitwise-and acc (arithmetic-shift perms 6))))
|
||||
((= (file-info:uid info) (user-effective-uid)) ; User
|
||||
(zero? (bitwise-and acc (arithmetic-shift perms 6))))
|
||||
|
||||
((or (= (file-info:gid info) (user-effective-gid)) ; Group
|
||||
(memv (file-info:gid info) (user-supplementary-gids)))
|
||||
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
|
||||
((or (= (file-info:gid info) (user-effective-gid)) ; Group
|
||||
(memv (file-info:gid info) (user-supplementary-gids)))
|
||||
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
|
||||
|
||||
(else ; Other
|
||||
(zero? (bitwise-and acc perms)))))
|
||||
'permission))))
|
||||
(else ; Other
|
||||
(zero? (bitwise-and acc perms)))))
|
||||
'permission)))
|
||||
|
||||
;;;;;;
|
||||
|
||||
(define (file-not-readable? fd/port/fname) (file-not-accessible? 4 fd/port/fname))
|
||||
(define (file-not-writable? fd/port/fname) (file-not-accessible? 2 fd/port/fname))
|
||||
(define (file-not-executable? fd/port/fname) (file-not-accessible? 1 fd/port/fname))
|
||||
(define (file-not-readable? fd/port/fname)
|
||||
(fd/port/fname-not-accessible? 4 fd/port/fname))
|
||||
(define (file-not-writable? fd/port/fname)
|
||||
(fd/port/fname-not-accessible? 2 fd/port/fname))
|
||||
(define (file-not-executable? fd/port/fname)
|
||||
(fd/port/fname-not-accessible? 1 fd/port/fname))
|
||||
|
||||
(define (file-readable? fd/port/fname) (not (file-not-readable? fd/port/fname)))
|
||||
(define (file-writable? fd/port/fname) (not (file-not-writable? fd/port/fname)))
|
||||
(define (file-executable? fd/port/fname) (not (file-not-executable? fd/port/fname)))
|
||||
(define (file-readable? fd/port/fname)
|
||||
(not (file-not-readable? fd/port/fname)))
|
||||
(define (file-writable? fd/port/fname)
|
||||
(not (file-not-writable? fd/port/fname)))
|
||||
(define (file-executable? fd/port/fname)
|
||||
(not (file-not-executable? fd/port/fname)))
|
||||
|
||||
(define (file-info-not-readable? info) (file-info-not-accessible? 4 info))
|
||||
(define (file-info-not-writable? info) (file-info-not-accessible? 2 info))
|
||||
(define (file-info-not-executable? info) (file-info-not-accessible? 1 info))
|
||||
|
||||
(define (file-info-readable? info) (not (file-info-not-readable? info)))
|
||||
(define (file-info-writable? info) (not (file-info-not-writable? info)))
|
||||
(define (file-info-executable? info) (not (file-info-not-executable? info)))
|
||||
|
||||
;;; Spelling corrected.
|
||||
(define file-not-writeable?
|
||||
|
|
@ -131,21 +148,39 @@
|
|||
(define-stat-proc file-owner file-info:uid)
|
||||
(define-stat-proc file-size file-info:size)
|
||||
|
||||
(define (file-directory? fname/fd/port . maybe-chase?)
|
||||
(eq? 'directory (apply file-type fname/fd/port maybe-chase?)))
|
||||
(define (file-info-to-fname/fd/port predicate)
|
||||
(lambda (fname/fd/port . maybe-chase?)
|
||||
(apply file-info fname/fd/port maybe-chase?)))
|
||||
|
||||
(define (file-fifo? fname/fd/port . maybe-chase?)
|
||||
(eq? 'fifo (apply file-type fname/fd/port maybe-chase?)))
|
||||
(define (file-info-directory? file-info)
|
||||
(eq? 'directory (file-type file-info)))
|
||||
|
||||
(define (file-regular? fname/fd/port . maybe-chase?)
|
||||
(eq? 'regular (apply file-type fname/fd/port maybe-chase?)))
|
||||
(define file-directory?
|
||||
(file-info-to-fname/fd/port file-info-directory?))
|
||||
|
||||
(define (file-socket? fname/fd/port . maybe-chase?)
|
||||
(eq? 'socket (apply file-type fname/fd/port maybe-chase?)))
|
||||
(define (file-info-fifo? file-info)
|
||||
(eq? 'fifo (file-type file-info)))
|
||||
|
||||
(define (file-special? fname/fd/port . maybe-chase?)
|
||||
(let ((type (apply file-type fname/fd/port maybe-chase?)))
|
||||
(define file-fifo? (file-info-to-fname/fd/port file-info-fifo?))
|
||||
|
||||
(define (file-info-regular? file-info)
|
||||
(eq? 'regular (file-type file-info)))
|
||||
|
||||
(define file-regular? (file-info-to-fname/fd/port file-info-regular?))
|
||||
|
||||
(define (file-info-socket? file-info)
|
||||
(eq? 'socket (file-type file-info)))
|
||||
|
||||
(define file-socket? (file-info-to-fname/fd/port file-info-socket?))
|
||||
|
||||
(define (file-info-special? file-info)
|
||||
(let ((type (file-type file-info)))
|
||||
(or (eq? 'block-special type) (eq? 'char-special type))))
|
||||
|
||||
(define (file-symlink? fname/fd/port) ; No MAYBE-CHASE?, of course.
|
||||
(eq? 'symlink (file-type fname/fd/port #f)))
|
||||
(define file-special? (file-info-to-fname/fd/port file-info-special?))
|
||||
|
||||
(define (file-info-symlink? file-info)
|
||||
(eq? 'symlink (file-type file-info)))
|
||||
|
||||
(define (file-symlink? fd/port/fname) ; No MAYBE-CHASE?, of course.
|
||||
(file-info-symlink? (file-info fd/port/fname #f)))
|
||||
Loading…
Reference in New Issue