scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Introduced new predicates working on file-info records.

This commit is contained in:
mainzelm 2002-09-25 06:26:19 +00:00
parent 96238c00c8
commit 6bb8778437
1 changed files with 86 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
scsh/fileinfo.scm
View File

@ -36,8 +36,7 @@
;;; ;;;
;;; Otherwise, signals an error. ;;; Otherwise, signals an error.
(define (file-not-accessible? perms fd/port/fname) (define (fd/port/fname-not-accessible? perms fd/port/fname)
(let ((uid (user-effective-uid)))
(with-errno-handler ((err data) (with-errno-handler ((err data)
((errno/acces) 'search-denied) ((errno/acces) 'search-denied)
((errno/notdir) 'no-directory) ((errno/notdir) 'no-directory)
@ -54,13 +53,17 @@
(not (string? fd/port/fname)) (not (string? fd/port/fname))
;; OK, check to see if we can create ;; OK, check to see if we can create
;; files in the directory. ;; files in the directory.
(file-not-accessible? 2 (fd/port/fname-not-accessible?
2
(directory-as-file-name (directory-as-file-name
(file-name-directory fd/port/fname)))) (file-name-directory fd/port/fname))))
'nonexistent))) 'nonexistent)))
(file-info-not-accessible? perms
(file-info fd/port/fname))))
(and (let* ((info (file-info fd/port/fname)) (define (file-info-not-accessible? perms info)
(acc (file-info:mode info))) (let ((uid (user-effective-uid)))
(and (let ((acc (file-info:mode info)))
(cond ((zero? uid) #f) ; Root can do as he wishes. (cond ((zero? uid) #f) ; Root can do as he wishes.
((= (file-info:uid info) (user-effective-uid)) ; User ((= (file-info:uid info) (user-effective-uid)) ; User
@ -72,17 +75,31 @@
(else ; Other (else ; Other
(zero? (bitwise-and acc perms))))) (zero? (bitwise-and acc perms)))))
'permission)))) 'permission)))
;;;;;; ;;;;;;
(define (file-not-readable? fd/port/fname) (file-not-accessible? 4 fd/port/fname)) (define (file-not-readable? fd/port/fname)
(define (file-not-writable? fd/port/fname) (file-not-accessible? 2 fd/port/fname)) (fd/port/fname-not-accessible? 4 fd/port/fname))
(define (file-not-executable? fd/port/fname) (file-not-accessible? 1 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-readable? fd/port/fname)
(define (file-writable? fd/port/fname) (not (file-not-writable? fd/port/fname))) (not (file-not-readable? fd/port/fname)))
(define (file-executable? fd/port/fname) (not (file-not-executable? 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. ;;; Spelling corrected.
(define file-not-writeable? (define file-not-writeable?
@ -131,21 +148,39 @@
(define-stat-proc file-owner file-info:uid) (define-stat-proc file-owner file-info:uid)
(define-stat-proc file-size file-info:size) (define-stat-proc file-size file-info:size)
(define (file-directory? fname/fd/port . maybe-chase?) (define (file-info-to-fname/fd/port predicate)
(eq? 'directory (apply file-type fname/fd/port maybe-chase?))) (lambda (fname/fd/port . maybe-chase?)
(apply file-info fname/fd/port maybe-chase?)))
(define (file-fifo? fname/fd/port . maybe-chase?) (define (file-info-directory? file-info)
(eq? 'fifo (apply file-type fname/fd/port maybe-chase?))) (eq? 'directory (file-type file-info)))
(define (file-regular? fname/fd/port . maybe-chase?) (define file-directory?
(eq? 'regular (apply file-type fname/fd/port maybe-chase?))) (file-info-to-fname/fd/port file-info-directory?))
(define (file-socket? fname/fd/port . maybe-chase?) (define (file-info-fifo? file-info)
(eq? 'socket (apply file-type fname/fd/port maybe-chase?))) (eq? 'fifo (file-type file-info)))
(define (file-special? fname/fd/port . maybe-chase?) (define file-fifo? (file-info-to-fname/fd/port file-info-fifo?))
(let ((type (apply file-type fname/fd/port maybe-chase?)))
(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)))) (or (eq? 'block-special type) (eq? 'char-special type))))
(define (file-symlink? fname/fd/port) ; No MAYBE-CHASE?, of course. (define file-special? (file-info-to-fname/fd/port file-info-special?))
(eq? 'symlink (file-type fname/fd/port #f)))
(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)))