puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch vfs): support symlinks

Browse source 
Change-Id: I6a6a69647b11d85f5440262c8e5e27cc220aefb8
This commit is contained in:
puck 2025-05-11 22:21:07 +00:00
parent db3b2316f0
commit e08558456a
1 changed files with 10 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

14
core/src/vfs.sld
View file

@ -3,7 +3,7 @@
(define-library (zilch vfs)
(import
(scheme base) (scheme file)
(chicken file)
(chicken file) (chicken file posix)
(zilch magic) (zilch file) (zilch zexpr)
(srfi 4) (srfi 113) (srfi 128) (srfi 146) (srfi 152))
@ -118,12 +118,18 @@
(define contents (directory reldir))
(for-each
(lambda (name)
(define full-path (string-append reldir "/" name))
(unless (string=? (string-copy name 0 1) ".")
(if (directory-exists? (string-append reldir "/" name))
(case (file-type full-path #t #f)
((directory)
(begin
(iter-dir (if (string=? dirpath "") name (string-append dirpath "/" name)))
(set! out (mapping-set! out (cons dirpath name) 'directory)))
(set! out (mapping-set! out (cons dirpath name) (zfile (zexp ,(call-with-input-file (string-append reldir "/" name) read-full-file)) (file-executable? (string-append reldir "/" name))))))))
(set! out (mapping-set! out (cons dirpath name) 'directory))))
((symbolic-link)
(set! out (mapping-set! out (cons dirpath name) (zsymlink (read-symbolic-link full-path)))))
((regular-file)
(set! out (mapping-set! out (cons dirpath name) (zfile (zexp ,(call-with-input-file full-path read-full-file)) (file-executable? full-path)))))
(else (error "Cannot vfsify path" (cons full-path (file-type full-path #t)))))))
contents))
(iter-dir "")
(make-vfs out))