;;;; vfs.scm (module vfs (export vfs:current-file-system vfs:handle-operation vfs:open-file vfs:open-input-file vfs:open-output-file vfs:file-exists? vfs:rename-file vfs:delete-file vfs:register-file-system vfs:unregister-file-system ) (import scheme chicken data-structures) (use tinyclos srfi-1 regex-case) ;;; Global hooks and parameters. (declare (hide resolve-prefix)) (define vfs:current-file-system (make-parameter #f)) (define vfs:handle-operation (make-generic "vfs:handle-operation")) (define vfs:open-file (make-generic "vfs:open-file")) (define vfs:open-input-file (make-generic "vfs:open-input-file")) (define vfs:open-output-file (make-generic "vfs:open-output-file")) (define vfs:file-exists? (make-generic "vfs:file-exists?")) (define vfs:rename-file (make-generic "vfs:rename-file")) (define vfs:delete-file (make-generic "vfs:delete-file")) (set! ##sys#pathname-resolution (lambda (name thunk #!optional op #!rest args) (let-values (((prefix path fs) (resolve-prefix name))) (vfs:handle-operation fs op thunk prefix name args) ) ) ) (define resolve-prefix (let ((cfs vfs:current-file-system)) (lambda (name) (regex-case name ("([^:]+)://(.*)" (_ scheme path) (values scheme path (or (alist-ref scheme *file-systems* string-ci=?) (error "unknown file-system scheme" scheme name) ) ) ) (else (values #f name (cfs))) ) ) ) ) ;;; General file-system superclass. (define-class () ()) (define-method (vfs:handle-operation (fs ) op thunk prefix path args) (case op ((open:) (apply vfs:open-file fs path args)) ((exists?:) (apply vfs:file-exists? fs path args)) ((delete:) (apply vfs:delete-file fs path args)) ((rename:) (let-values (((tprefix tpath tfs) (resolve-prefix (car args)))) (cond ((not (instance-of? tfs )) (error 'rename-file "bad argument type - not a file system" tfs)) ((not (eq? fs tfs)) (error 'rename-file "can not rename file between different file systems" fs tfs path) ) (else (vfs:rename-file fs path tpath)) ) ) ) (else (error "invalid file operation" fs op path args)))) (define-method (vfs:open-file (fs ) name output? modes) ;; modes: binary: text: append: ((if output? vfs:open-output-file vfs:open-input-file) fs name modes) ) (define-method (vfs:open-input-file (fs ) name modes) (error 'vfs:open-input-file "method not implemented" fs) ) (define-method (vfs:open-output-file (fs ) name modes) (error 'vfs:open-output-file "method not implemented" fs) ) (define-method (vfs:file-exists? (fs ) name) (error 'vfs:file-exists? "method not implemented" fs) ) (define-method (vfs:delete-file (fs ) name) (error 'vfs:delete-file "method not implemented" fs) ) (define-method (vfs:rename-file (fs ) old new) (error 'vfs:rename-file "method not implemented" old new) ) ;;; URI-Schemes. (declare (hide *file-systems*)) (define *file-systems* '()) (define (vfs:register-file-system name fs) (set! *file-systems* (alist-update! (->string name) (ensure (cut instance-of? <> ) fs) *file-systems* string-ci=?)) ) (define (vfs:unregister-file-system name) (let ((nameci (->string name))) (set! *file-systems* (remove (lambda (a) (string-ci=? (car a) nameci)) *file-systems*) ) ) ) ;;; Local file sytem (default). (declare (hide local-file-op)) (define-class () ()) (define (local-file-op name thunk) (thunk (##sys#expand-home-path name)) ) (define-method (vfs:handle-operation (fs ) op thunk prefix path args) (local-file-op path thunk) ) (vfs:current-file-system (make )) )