~ chicken-core (chicken-5) 92f023f28aa9b0455218ff8b92df92f043a8a81d
commit 92f023f28aa9b0455218ff8b92df92f043a8a81d
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Jun 14 21:34:58 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 2 10:28:41 2017 +1200
Move several procedures from "posix" to "file"
- delete-directory
- glob
- find-files
This also moves the dependency on irregex from posix to file, since
only these three procedures used irregex helpers.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/file.scm b/file.scm
index c1768afa..cd0f6012 100644
--- a/file.scm
+++ b/file.scm
@@ -35,7 +35,7 @@
(declare
(unit file)
- (uses extras pathname posix)
+ (uses extras irregex pathname posix)
(fixnum)
(disable-interrupts)
(foreign-declare #<<EOF
@@ -47,6 +47,8 @@
#else
# define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
#endif
+
+#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
EOF
))
@@ -83,6 +85,7 @@ EOF
(import chicken scheme
chicken.foreign
chicken.io
+ chicken.irregex
chicken.pathname
chicken.posix)
@@ -90,6 +93,16 @@ EOF
(define-foreign-variable strerror c-string "strerror(errno)")
+;; TODO: Some duplication from POSIX, to give better error messages.
+;; This really isn't so much posix-specific, and code like this is
+;; also in library.scm. This should be deduplicated across the board.
+(define posix-error
+ (let ([strerror (foreign-lambda c-string "strerror" int)]
+ [string-append string-append] )
+ (lambda (type loc msg . args)
+ (let ([rn (##sys#update-errno)])
+ (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+
;;; Like `delete-file', but does nothing if the file doesn't exist:
@@ -98,6 +111,30 @@ EOF
(and (file-exists? file) (delete-file file))))
+;;; Directory management:
+
+(define delete-directory
+ (lambda (name #!optional recursive)
+ (define (rmdir dir)
+ (let ((sname (##sys#make-c-string dir)))
+ (unless (fx= 0 (##core#inline "C_rmdir" sname))
+ (posix-error #:file-error 'delete-directory "cannot delete directory" dir))))
+ (##sys#check-string name 'delete-directory)
+ (if recursive
+ (let ((files (find-files ; relies on `find-files' to list dir-contents before dir
+ name
+ dotfiles: #t
+ follow-symlinks: #f)))
+ (for-each
+ (lambda (f)
+ ((cond ((symbolic-link? f) delete-file)
+ ((directory? f) rmdir)
+ (else delete-file))
+ f))
+ files)
+ (rmdir name))
+ (rmdir name))))
+
;;; file-copy and file-move : they do what you'd think.
(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
@@ -220,4 +257,66 @@ EOF
(##sys#string-append "cannot create temporary directory - " strerror)
pn)))))))))
+
+;;; Filename globbing:
+
+(define glob
+ (lambda paths
+ (let conc-loop ((paths paths))
+ (if (null? paths)
+ '()
+ (let ((path (car paths)))
+ (let-values (((dir fil ext) (decompose-pathname path)))
+ (let ((rx (##sys#glob->regexp (make-pathname #f (or fil "*") ext))))
+ (let loop ((fns (directory (or dir ".") #t)))
+ (cond ((null? fns) (conc-loop (cdr paths)))
+ ((irregex-match rx (car fns)) =>
+ (lambda (m)
+ (cons (make-pathname dir (irregex-match-substring m))
+ (loop (cdr fns)))))
+ (else (loop (cdr fns))))))))))))
+
+
+;;; Find matching files:
+
+(define (find-files dir #!key (test (lambda _ #t))
+ (action (lambda (x y) (cons x y)))
+ (seed '())
+ (limit #f)
+ (dotfiles #f)
+ (follow-symlinks #f))
+ (##sys#check-string dir 'find-files)
+ (let* ((depth 0)
+ (lproc
+ (cond ((not limit) (lambda _ #t))
+ ((fixnum? limit) (lambda _ (fx< depth limit)))
+ (else limit)))
+ (pproc
+ (if (procedure? test)
+ test
+ (let ((test (irregex test))) ; force compilation
+ (lambda (x) (irregex-match test x))))))
+ (let loop ((dir dir)
+ (fs (directory dir dotfiles))
+ (r seed))
+ (if (null? fs)
+ r
+ (let* ((filename (##sys#slot fs 0))
+ (f (make-pathname dir filename))
+ (rest (##sys#slot fs 1)))
+ (cond ((directory? f)
+ (cond ((member filename '("." "..")) (loop dir rest r))
+ ((and (symbolic-link? f) (not follow-symlinks))
+ (loop dir rest (if (pproc f) (action f r) r)))
+ ((lproc f)
+ (loop dir
+ rest
+ (fluid-let ((depth (fx+ depth 1)))
+ (loop f
+ (directory f dotfiles)
+ (if (pproc f) (action f r) r)))))
+ (else (loop dir rest (if (pproc f) (action f r) r)))))
+ ((pproc f) (loop dir rest (action f r)))
+ (else (loop dir rest r))))))))
+
)
diff --git a/posix-common.scm b/posix-common.scm
index 3543e6bd..ca8136a8 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -507,28 +507,6 @@ EOF
#:file-error
'current-directory "cannot retrieve current directory") ) ) ) )
-(define delete-directory
- (lambda (name #!optional recursive)
- (define (rmdir dir)
- (let ((sname (##sys#make-c-string dir)))
- (unless (fx= 0 (##core#inline "C_rmdir" sname))
- (posix-error #:file-error 'delete-directory "cannot delete directory" dir) )))
- (##sys#check-string name 'delete-directory)
- (if recursive
- (let ((files (find-files ; relies on `find-files' to list dir-contents before dir
- name
- dotfiles: #t
- follow-symlinks: #f)))
- (for-each
- (lambda (f)
- ((cond ((symbolic-link? f) delete-file)
- ((directory? f) rmdir)
- (else delete-file))
- f))
- files)
- (rmdir name))
- (rmdir name))))
-
(define-inline (*create-directory loc name)
(unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
(posix-error #:file-error loc "cannot create directory" name)) )
@@ -575,72 +553,6 @@ EOF
(loop)
(cons file (loop)) ) ) ) ) ) ) ) )
-;;; Filename globbing:
-
-(define glob
- (lambda paths
- (let conc-loop ((paths paths))
- (if (null? paths)
- '()
- (let ((path (car paths)))
- (let-values (((dir fil ext) (decompose-pathname path)))
- (let ((rx (##sys#glob->regexp (make-pathname #f (or fil "*") ext))))
- (let loop ((fns (directory (or dir ".") #t)))
- (cond ((null? fns) (conc-loop (cdr paths)))
- ((irregex-match rx (car fns))
- => (lambda (m)
- (cons
- (make-pathname dir (irregex-match-substring m))
- (loop (cdr fns)))) )
- (else (loop (cdr fns))) ) ) ) ) ) ) ) ) )
-
-
-;;; Find matching files:
-
-(define (##sys#find-files dir pred action id limit follow dot loc)
- (##sys#check-string dir loc)
- (let* ((depth 0)
- (lproc
- (cond ((not limit) (lambda _ #t))
- ((fixnum? limit) (lambda _ (fx< depth limit)))
- (else limit) ) )
- (pproc
- (if (procedure? pred)
- pred
- (let ((pred (irregex pred))) ; force compilation
- (lambda (x) (irregex-match pred x))))))
- (let loop ((dir dir)
- (fs (directory dir dot))
- (r id))
- (if (null? fs)
- r
- (let* ((filename (##sys#slot fs 0))
- (f (make-pathname dir filename))
- (rest (##sys#slot fs 1)))
- (cond ((directory? f)
- (cond ((member filename '("." "..")) (loop dir rest r))
- ((and (symbolic-link? f) (not follow))
- (loop dir rest (if (pproc f) (action f r) r)))
- ((lproc f)
- (loop dir
- rest
- (fluid-let ((depth (fx+ depth 1)))
- (loop f
- (directory f dot)
- (if (pproc f) (action f r) r)))))
- (else (loop dir rest (if (pproc f) (action f r) r)))))
- ((pproc f) (loop dir rest (action f r)))
- (else (loop dir rest r))))))))
-
-(define (find-files dir #!key (test (lambda _ #t))
- (action (lambda (x y) (cons x y)))
- (seed '())
- (limit #f)
- (dotfiles #f)
- (follow-symlinks #f))
- (##sys#find-files dir test action seed limit follow-symlinks dotfiles 'find-files))
-
-
;;; umask
(define file-creation-mode
diff --git a/posix.scm b/posix.scm
index b93d7bbe..d4815ff7 100644
--- a/posix.scm
+++ b/posix.scm
@@ -35,7 +35,7 @@
(declare
(unit posix)
- (uses scheduler irregex pathname extras port lolevel)
+ (uses scheduler pathname extras port lolevel)
(disable-interrupts)
(not inline ##sys#interrupt-hook ##sys#user-interrupt-hook))
@@ -46,7 +46,7 @@
create-session create-symbolic-link current-directory
current-effective-group-id current-effective-user-id
current-effective-user-name current-group-id current-process-id
- current-user-id current-user-name delete-directory directory
+ current-user-id current-user-name directory
directory? duplicate-fileno emergency-exit fcntl/dupfd fcntl/getfd
fcntl/getfl fcntl/setfd fcntl/setfl fifo? fifo? file-access-time
file-change-time file-close file-control file-creation-mode
@@ -55,8 +55,8 @@
file-owner file-permissions file-position file-read file-read-access?
file-select file-size file-stat file-test-lock file-truncate
file-type file-unlock file-write file-write-access? fileno/stderr
- fileno/stdin fileno/stdout find-files get-environment-variables
- get-host-name glob local-time->seconds local-timezone-abbreviation
+ fileno/stdin fileno/stdout get-environment-variables
+ get-host-name local-time->seconds local-timezone-abbreviation
open-input-file* open-input-pipe open-output-file* open-output-pipe
open/append open/binary open/creat open/excl open/fsync open/noctty
open/noinherit open/nonblock open/rdonly open/rdwr open/read
@@ -87,7 +87,6 @@
(import scheme chicken)
(import chicken.bitwise
chicken.foreign
- chicken.irregex
chicken.memory
chicken.pathname
chicken.port
diff --git a/posixunix.scm b/posixunix.scm
index 1a8902db..63f0f891 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -115,7 +115,6 @@ static C_TLS struct stat C_statbuf;
#define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))
#define C_chdir(str) C_fix(chdir(C_c_string(str)))
-#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))
#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
diff --git a/posixwin.scm b/posixwin.scm
index fec8759f..b6c6ff0b 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -117,7 +117,6 @@ static C_TLS TCHAR C_username[255 + 1] = "";
#define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
#define C_chdir(str) C_fix(chdir(C_c_string(str)))
-#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
/* DIRENT stuff */
struct dirent
diff --git a/rules.make b/rules.make
index 418eb09a..14212cbc 100644
--- a/rules.make
+++ b/rules.make
@@ -702,7 +702,6 @@ posixunix.c: posixunix.scm \
chicken.bitwise.import.scm \
chicken.condition.import.scm \
chicken.foreign.import.scm \
- chicken.irregex.import.scm \
chicken.memory.import.scm \
chicken.pathname.import.scm \
chicken.platform.import.scm \
@@ -712,7 +711,6 @@ posixwin.c: posixwin.scm \
chicken.condition.import.scm \
chicken.bitwise.import.scm \
chicken.foreign.import.scm \
- chicken.irregex.import.scm \
chicken.memory.import.scm \
chicken.pathname.import.scm \
chicken.platform.import.scm \
@@ -742,6 +740,7 @@ repl.c: repl.scm \
chicken.eval.import.scm
file.c: file.scm \
chicken.io.import.scm \
+ chicken.irregex.import.scm \
chicken.foreign.import.scm \
chicken.pathname.import.scm \
chicken.posix.import.scm
diff --git a/tests/test-find-files.scm b/tests/test-find-files.scm
index 62fe5a0a..30405fde 100644
--- a/tests/test-find-files.scm
+++ b/tests/test-find-files.scm
@@ -1,4 +1,4 @@
-(use data-structures posix)
+(use (chicken file) (chicken process-context) data-structures)
(include "test.scm")
(handle-exceptions exn
@@ -21,7 +21,7 @@
"find-files-test-dir/dir-link-target/foo"
"find-files-test-dir/dir-link-target/bar"))
-(change-directory "find-files-test-dir")
+(current-directory "find-files-test-dir")
(cond-expand
((and windows (not cygwin)) ; Cannot handle symlinks
@@ -209,5 +209,5 @@
(test-end "find-files")
-(change-directory "..")
+(current-directory "..")
(delete-directory "find-files-test-dir" #t)
diff --git a/types.db b/types.db
index 8aeaf28c..0b3077e6 100644
--- a/types.db
+++ b/types.db
@@ -1588,9 +1588,13 @@
(chicken.file#create-temporary-directory (#(procedure #:clean #:enforce) chicken.file#create-temporary-directory () string))
(chicken.file#create-temporary-file (#(procedure #:clean #:enforce) chicken.file#create-temporary-file (#!optional string) string))
+(chicken.file#delete-directory (#(procedure #:clean #:enforce) chicken.file#delete-directory (string #!optional *) string))
(chicken.file#delete-file* (#(procedure #:clean #:enforce) chicken.file#delete-file* (string) *))
(chicken.file#file-copy (#(procedure #:clean #:enforce) chicken.file#file-copy (string string #!optional * fixnum) fixnum))
(chicken.file#file-move (#(procedure #:clean #:enforce) chicken.file#file-move (string string #!optional * fixnum) fixnum))
+(chicken.file#find-files (#(procedure #:enforce) chicken.file#find-files (string #!rest) list))
+(chicken.file#glob (#(procedure #:clean #:enforce) chicken.file#glob (#!rest string) list))
+
;; pathname
@@ -1933,7 +1937,6 @@
(chicken.posix#current-process-id (#(procedure #:clean) chicken.posix#current-process-id () fixnum))
(chicken.posix#current-user-id (#(procedure #:clean) chicken.posix#current-user-id () fixnum))
(chicken.posix#current-user-name (#(procedure #:clean) chicken.posix#current-user-name () string))
-(chicken.posix#delete-directory (#(procedure #:clean #:enforce) chicken.posix#delete-directory (string #!optional *) string))
(chicken.posix#directory (#(procedure #:clean #:enforce) chicken.posix#directory (#!optional string *) (list-of string)))
(chicken.posix#directory? (#(procedure #:clean #:enforce) chicken.posix#directory? ((or string fixnum)) boolean))
(chicken.posix#duplicate-fileno (#(procedure #:clean #:enforce) chicken.posix#duplicate-fileno (fixnum #!optional fixnum) fixnum))
@@ -1972,9 +1975,7 @@
(chicken.posix#fileno/stderr fixnum)
(chicken.posix#fileno/stdin fixnum)
(chicken.posix#fileno/stdout fixnum)
-(chicken.posix#find-files (#(procedure #:enforce) chicken.posix#find-files (string #!rest) list))
(chicken.posix#get-host-name (#(procedure #:clean) chicken.posix#get-host-name () string))
-(chicken.posix#glob (#(procedure #:clean #:enforce) chicken.posix#glob (#!rest string) list))
(chicken.posix#local-time->seconds (#(procedure #:clean #:enforce) chicken.posix#local-time->seconds ((vector fixnum fixnum fixnum fixnum fixnum fixnum fixnum fixnum boolean fixnum)) integer))
(chicken.posix#local-timezone-abbreviation (#(procedure #:clean) chicken.posix#local-timezone-abbreviation () string))
(chicken.posix#open-input-file* (#(procedure #:clean #:enforce) chicken.posix#open-input-file* (fixnum #!optional symbol) input-port))
Trap