51 lines
1.6 KiB
Scheme
51 lines
1.6 KiB
Scheme
(define-record-type fs-object :fs-object
|
|
(really-make-fs-object name path info)
|
|
fs-object?
|
|
(name fs-object-name)
|
|
(path fs-object-path)
|
|
(info really-fs-object-info))
|
|
|
|
(define (fs-object-info fso)
|
|
(force (really-fs-object-info fso)))
|
|
|
|
(define (make-fs-object name path)
|
|
;; TODO check path for being absolute, name for being relative
|
|
;; and slashless
|
|
(if (not (file-name-absolute? path))
|
|
(error "path argument of make-fs-object not absolute" path))
|
|
(really-make-fs-object
|
|
name path
|
|
;; TODO: this delay is rather useless, we need the info anyway
|
|
(delay
|
|
(with-fatal-error-handler
|
|
(lambda (condition more)
|
|
(format #t "condition while fs-object-info: ~a" condition)
|
|
#f)
|
|
(file-info (combine-path path name) #f)))))
|
|
|
|
(define-record-discloser :fs-object
|
|
(lambda (r)
|
|
`(fs-object ,(fs-object-path r) ,(fs-object-name r))))
|
|
|
|
(define (combine-path parent name)
|
|
(if (string=? parent "")
|
|
name
|
|
(string-append parent
|
|
"/"
|
|
name)))
|
|
|
|
(define (fs-object-complete-path fs-object)
|
|
(absolute-file-name
|
|
(fs-object-name fs-object)
|
|
(fs-object-path fs-object)))
|
|
|
|
(define (file-name->fs-object file-name)
|
|
(if (file-name-absolute? file-name)
|
|
(make-fs-object (file-name-nondirectory file-name)
|
|
(file-name-directory file-name))
|
|
(let ((rest-dirs (file-name-directory file-name)))
|
|
(make-fs-object (file-name-nondirectory file-name)
|
|
(string-append (cwd)
|
|
"/"
|
|
rest-dirs)))))
|