67 lines
1.9 KiB
Scheme
67 lines
1.9 KiB
Scheme
|
;;; Directory stuff
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(define (directory-files . args)
|
||
|
|
(with-resources-aligned
|
||
|
|
(list cwd-resource euid-resource egid-resource)
|
||
|
|
(lambda ()
|
||
|
|
(let-optionals args ((dir ".")
|
||
|
|
(dotfiles? #f))
|
||
|
|
(check-arg string? dir directory-files)
|
||
|
|
(let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
|
||
|
|
(files-sorted ((structure-ref sort sort-list!) files filename<=)))
|
||
|
|
(if dotfiles?
|
||
|
|
files-sorted
|
||
|
|
(filter (lambda (f) (not (dotfile? f)))
|
||
|
|
files-sorted)))))))
|
||
|
|
|
||
|
|
(define (dotfile? f)
|
||
|
|
(char=? (string-ref f 0) #\.))
|
||
|
|
|
||
|
|
(define (filename<= f1 f2)
|
||
|
|
(if (dotfile? f1)
|
||
|
|
(if (dotfile? f2)
|
||
|
|
(string<= f1 f2)
|
||
|
|
#t)
|
||
|
|
(if (dotfile? f2)
|
||
|
|
#f
|
||
|
|
(string<= f1 f2))))
|
||
|
|
|
||
|
|
; A record for directory streams. It just has the name and a byte vector
|
||
|
|
; containing the C directory object. The name is used only for printing.
|
||
|
|
|
||
|
|
(define-record directory-stream
|
||
|
|
name
|
||
|
|
c-dir)
|
||
|
|
|
||
|
|
(define-record-discloser type/directory-stream
|
||
|
|
(lambda (ds)
|
||
|
|
(list 'directory-stream (directory-stream:name ds))))
|
||
|
|
|
||
|
|
; Directory streams are meaningless in a resumed image.
|
||
|
|
(define-record-resumer type/directory-stream #f)
|
||
|
|
|
||
|
|
(define (open-directory-stream name)
|
||
|
|
(let ((dir (make-directory-stream
|
||
|
|
name
|
||
|
|
(with-resources-aligned
|
||
|
|
(list cwd-resource euid-resource egid-resource)
|
||
|
|
(lambda ()
|
||
|
|
(open-dir name))))))
|
||
|
|
(add-finalizer! dir close-directory-stream)
|
||
|
|
dir))
|
||
|
|
|
||
|
|
(define (read-directory-stream dir-stream)
|
||
|
|
(read-dir (directory-stream:c-dir dir-stream)))
|
||
|
|
|
||
|
|
(define (close-directory-stream dir-stream)
|
||
|
|
(let ((c-dir (directory-stream:c-dir dir-stream)))
|
||
|
|
(if c-dir
|
||
|
|
(begin
|
||
|
|
(close-dir c-dir)
|
||
|
|
(set-directory-stream:c-dir dir-stream #f)))))
|
||
|
|
|
||
|
|
(import-os-error-syscall open-dir (name) "scm_opendir")
|
||
|
|
(import-os-error-syscall close-dir (dir-stream) "scm_closedir")
|
||
|
|
(import-os-error-syscall read-dir (dir-stream) "scm_readdir")
|