From ee6672c0308e54f47526ce32a0e4ed87bd722e86 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
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 #<<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,28 @@ EOF
     (and (file-exists? file) (delete-file file))))
 
 
+(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 +255,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 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