;;> Interface to the filesystem and file descriptor objects.
;;> Note that file descriptors are currently represented as
;;> integers, but may be replaced with opaque (and gc-managed)
;;> objects in a future release.
(define-library (chibi filesystem)
(export duplicate-file-descriptor duplicate-file-descriptor-to
close-file-descriptor renumber-file-descriptor
open-input-file-descriptor open-output-file-descriptor
delete-file link-file symbolic-link-file rename-file
directory-files directory-fold directory-fold-tree
delete-file-hierarchy delete-directory
create-directory create-directory*
current-directory change-directory with-directory
open open-pipe make-fifo
read-link
file-status file-link-status
file-device file-inode
file-mode file-num-links
file-owner file-group
file-represented-device file-size
file-block-size file-num-blocks
file-access-time file-change-time
file-modification-time file-modification-time/safe
file-regular? file-directory? file-character?
file-block? file-fifo? file-link?
file-socket? file-exists?
get-file-descriptor-flags set-file-descriptor-flags!
get-file-descriptor-status set-file-descriptor-status!
open/read open/write open/read-write
open/create open/exclusive open/truncate
open/append open/non-block
file-lock file-truncate
file-is-readable? file-is-writable? file-is-executable?
chmod chown is-a-tty?)
(cond-expand
(chibi
(export lock/shared lock/exclusive lock/non-blocking lock/unlock)
(import (chibi) (chibi string))
(include-shared "filesystem")
(include "filesystem.scm"))
(chicken
(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))
(define (stat-dev x) (vector-ref x 9))
(define (stat-ino x) (vector-ref x 0))
(define (stat-mode x) (vector-ref x 1))
(define (stat-nlinks x) (vector-ref x 2))
(define (stat-uid x) (vector-ref x 3))
(define (stat-gid x) (vector-ref x 4))
(define (stat-rdev x) (vector-ref x 10))
(define (stat-size x) (vector-ref x 5))
(define (stat-blksize x) (vector-ref x 11))
(define (stat-blocks x) (vector-ref x 12))
(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)
(define open-input-file-descriptor open-input-file*)
(define open-output-file-descriptor open-output-file*)
(define link-file file-link)
(define symbolic-link-file create-symbolic-link)
(define read-link read-symbolic-link)
(define open file-open)
(define open-pipe create-pipe)
(define make-fifo create-fifo)
(define file-regular? regular-file?)
(define file-directory? directory?)
(define file-character? character-device?)
(define file-block? block-device?)
(define file-fifo? fifo?)
(define file-link? symbolic-link?)
(define file-socket? socket?)
(define file-is-readable? file-read-access?)
(define file-is-writable? file-write-access?)
(define file-is-executable? file-execute-access?)
(define (get-file-descriptor-flags fileno)
(file-control fileno fcntl/getfd))
(define (set-file-descriptor-flags! fileno x)
(file-control fileno fcntl/setfd x))
(define (get-file-descriptor-status fileno)
(file-control fileno fcntl/getfl))
(define (set-file-descriptor-status! fileno x)
(file-control fileno fcntl/setfl x))
(define open/read-write open/rdwr)
(define open/create open/creat)
(define open/exclusive open/excl)
(define open/truncate open/trunc)
(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))
(begin
(define (file-status x) x)
(define file-link-status file-status)
(define-syntax define-unimplemented
(syntax-rules ()
((define-unimplemented def ...)
(define (def . x) (error "unimplemented" 'def)) ...)))
(define-unimplemented
stat-dev stat-ino stat-mode stat-nlinks stat-uid stat-gid
stat-rdev stat-blksize stat-blocks)
(define (stat-size x) (file-size-in-bytes x))
(define (stat-atime x) (file-stat-atime x))
(define (stat-mtime x) (file-stat-mtime x))
(define (stat-ctime x) (file-stat-ctime x))
(define file-is-readable? file-readable?)
(define file-is-writable? file-writable?)
(define file-is-executable? file-executable?)
(define file-link? file-symbolic-link?)
(define-unimplemented
duplicate-file-descriptor duplicate-file-descriptor-to
close-file-descriptor open-input-file-descriptor
open-output-file-descriptor)
))))