Hi all, The attached patch moves glob, find-files and delete-directory from posix.scm to file.scm. I also tried to move "directory", and some of the "stat"-based file type predicates but that's just too hairy to move, at least for now.
What should we do with ##sys#glob->regex? I think it's useful enough to expose to the user, which conveniently allows us to get rid of the ##sys# prefix too. But in which unit does it belong the most? Personally, I think file might make more sense, as it's strictly not an irregex procedure, and it belongs with "glob". On the other hand, it doesn't actually hit the file system; it's an abstract operation over data-structures only, without any side effects. Cheers, Peter
From ee6672c0308e54f47526ce32a0e4ed87bd722e86 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> 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
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
