diff --git a/Makefile b/Makefile index 2b7923ed..686436ea 100644 --- a/Makefile +++ b/Makefile @@ -427,7 +427,7 @@ debian: # Libraries in the standard distribution we want to make available to # other Scheme implementations. Note this is run with my own -# ~/.snow/config.scm, which specifies myself own settings regarding +# ~/.snow/config.scm, which specifies my own settings regarding # author, license, extracting docs from scribble, etc. snowballs: $(SNOW_CHIBI) package --license public-domain lib/chibi/char-set/boundary.sld @@ -437,11 +437,13 @@ snowballs: $(SNOW_CHIBI) package -r lib/chibi/show.sld lib/chibi/show/pretty.sld $(SNOW_CHIBI) package lib/srfi/115.sld $(SNOW_CHIBI) package lib/chibi/app.sld + $(SNOW_CHIBI) package lib/chibi/binary-record.sld $(SNOW_CHIBI) package lib/chibi/bytevector.sld $(SNOW_CHIBI) package lib/chibi/config.sld $(SNOW_CHIBI) package lib/chibi/crypto/md5.sld $(SNOW_CHIBI) package lib/chibi/crypto/rsa.sld $(SNOW_CHIBI) package lib/chibi/crypto/sha2.sld + $(SNOW_CHIBI) package lib/chibi/filesystem.sld $(SNOW_CHIBI) package lib/chibi/math/prime.sld $(SNOW_CHIBI) package lib/chibi/monad/environment.sld $(SNOW_CHIBI) package lib/chibi/optional.sld @@ -451,6 +453,7 @@ snowballs: $(SNOW_CHIBI) package lib/chibi/scribble.sld $(SNOW_CHIBI) package lib/chibi/string.sld $(SNOW_CHIBI) package lib/chibi/sxml.sld + $(SNOW_CHIBI) package lib/chibi/tar.sld $(SNOW_CHIBI) package lib/chibi/term/ansi.sld $(SNOW_CHIBI) package lib/chibi/term/edit-line.sld $(SNOW_CHIBI) package lib/chibi/test.sld diff --git a/lib/chibi/filesystem-test.sld b/lib/chibi/filesystem-test.sld index 83bad803..e43d4bf5 100644 --- a/lib/chibi/filesystem-test.sld +++ b/lib/chibi/filesystem-test.sld @@ -1,7 +1,13 @@ (define-library (chibi filesystem-test) (export run-tests) - (import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33)) + (import (scheme base) (scheme file) (scheme write) + (chibi filesystem) (chibi test)) + (cond-expand + ((library (srfi 33)) (import (srfi 33))) + (else (import (srfi 60)))) (begin + (define (port->string in) + (read-string 1024 in)) (define (run-tests) (define tmp-file "/tmp/chibi-fs-test-0123456789") (define tmp-file2 "/tmp/chibi-fs-test-0123456789-2") diff --git a/lib/chibi/filesystem.sld b/lib/chibi/filesystem.sld index d1b7a8bd..23a35232 100644 --- a/lib/chibi/filesystem.sld +++ b/lib/chibi/filesystem.sld @@ -33,15 +33,18 @@ open/append open/non-block file-lock file-truncate file-is-readable? file-is-writable? file-is-executable? - lock/shared lock/exclusive lock/non-blocking lock/unlock chmod is-a-tty?) - (import (chibi string)) (cond-expand (chibi - (import (chibi)) - (include-shared "filesystem")) + (export lock/shared lock/exclusive lock/non-blocking lock/unlock) + (import (chibi) (chibi string)) + (include-shared "filesystem") + (include "filesystem.scm")) (chicken - (import (scheme base) (library) (posix)) + (import (scheme base) (srfi 1) + (only (chicken) delete-file rename-file file-exists?) + (rename (posix) (file-truncate %file-trunc)) + (chibi string)) (begin (define file-status file-stat) (define (file-link-status x) (file-stat x #t)) @@ -58,6 +61,14 @@ (define (stat-atime x) (vector-ref x 6)) (define (stat-mtime x) (vector-ref x 7)) (define (stat-ctime x) (vector-ref x 8)) + (define (file-mode x) (stat-mode (if (vector? x) x (file-stat x)))) + (define (file-num-links x) (stat-nlinks (if (vector? x) x (file-stat x)))) + (define (file-group x) (stat-gid (if (vector? x) x (file-stat x)))) + (define (file-inode x) (stat-ino (if (vector? x) x (file-stat x)))) + (define (file-device x) (stat-dev (if (vector? x) x (file-stat x)))) + (define (file-represented-device x) (if (vector? x) x (file-stat x))) + (define (file-block-size x) (stat-blksize (if (vector? x) x (file-stat x)))) + (define (file-num-blocks x) (stat-blocks (if (vector? x) x (file-stat x)))) (define duplicate-file-descriptor duplicate-fileno) (define duplicate-file-descriptor-to duplicate-fileno) (define close-file-descriptor file-close) @@ -94,6 +105,44 @@ (define open/non-block open/nonblock) (define chmod change-file-mode) (define is-a-tty? terminal-port?) + (define (file-truncate port len) + (%file-trunc (if (integer? port) port (port->fileno port)) len)) + (define (create-directory* dir) + (create-directory dir #t)) + (define (directory-files dir) + (cons "." (cons ".." (directory dir #t)))) + (define (directory-fold dir kons knil) + (fold kons knil (directory-files dir))) + (define (directory-fold-tree file down up here . o) + (let ((knil (and (pair? o) (car o))) + (down (or down (lambda (f acc) acc))) + (up (or up (lambda (f acc) acc))) + (here (or here (lambda (f acc) acc)))) + (let fold ((file file) (acc knil)) + (cond + ((file-directory? file) + (let lp ((ls (directory-files file)) (acc (down file acc))) + (cond + ((null? ls) (up file acc)) + ((member (car ls) '("." "..")) (lp (cdr ls) acc)) + (else + (lp (cdr ls) (fold (string-append file "/" (car ls)) acc)))))) + (else + (here file acc)))))) + (define (delete-file-hierarchy dir . o) + (delete-directory dir #t)) + (define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + (define (with-directory dir thunk) + (let ((pwd (current-directory))) + (dynamic-wind + (lambda () (change-directory dir)) + thunk + (lambda () (change-directory pwd))))) + (define (file-modification-time/safe file) + (guard (exn (else #f)) + (file-modification-time file))) )) (sagittarius (import (scheme base) (sagittarius)) @@ -120,5 +169,4 @@ duplicate-file-descriptor duplicate-file-descriptor-to close-file-descriptor open-input-file-descriptor open-output-file-descriptor) - ))) - (include "filesystem.scm")) + )))) diff --git a/lib/chibi/tar.sld b/lib/chibi/tar.sld index 4c335ed9..4a9b5e52 100644 --- a/lib/chibi/tar.sld +++ b/lib/chibi/tar.sld @@ -2,13 +2,20 @@ (define-library (chibi tar) (import (scheme base) (scheme file) (scheme time) (srfi 1) (chibi string) (chibi binary-record) (chibi pathname) - (chibi filesystem) - (chibi system)) + (chibi filesystem)) (cond-expand ((library (srfi 33)) (import (srfi 33))) (else (import (srfi 60)))) + (cond-expand + (chibi + (import (chibi system))) + (chicken + (import posix) + (begin + (define user-name car) + (define group-name car)))) (export ;; basic tar make-tar tar? read-tar write-tar