From ee6672c0308e54f47526ce32a0e4ed87bd722e86 Mon Sep 17 00:00:00 2001
From: Peter Bex
Date: Wed, 14 Jun 2017 21:34:58 +0200
Subject: [PATCH] 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.
---
file.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++-
posix-common.scm | 88 -----------------------------------------
posix.scm | 9 ++---
posixunix.scm | 1 -
posixwin.scm | 1 -
rules.make | 3 +-
tests/test-find-files.scm | 6 +--
types.db | 7 ++--
8 files changed, 110 insertions(+), 104 deletions(-)
diff --git a/file.scm b/file.scm
index c1768af..b5c1661 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 #<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 3543e6b..ca8136a 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 b93d7bb..d4815ff 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 1a8902d..63f0f89 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 fec8759..b6c6ff0 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 954fde4..6447af1 100644
--- a/rules.make
+++ b/rules.make
@@ -700,7 +700,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 \
@@ -710,7 +709,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 \
@@ -738,6 +736,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 62fe5a0..30405fd 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 07258c4..5859156 100644
--- a/types.db
+++ b/types.db
@@ -1599,9 +1599,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
@@ -1944,7 +1948,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))
@@ -1983,9 +1986,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))
--
2.1.4