Hi,
Attached you can find two patches: one to add a small test suite for
find-files and another one that makes find-files use `directory' instead
of `glob' to list files (for performance).
These patches can also be applied to the chicken-5 branch.
Best wishes,
Mario
--
http://parenteses.org/mario
>From f249e21a051db63565f3332c82deea476e5f1543 Mon Sep 17 00:00:00 2001
From: Mario Domenech Goulart <mario.goul...@gmail.com>
Date: Tue, 2 Jun 2015 22:07:27 -0300
Subject: [PATCH 1/2] Add test suite for find-files
---
distribution/manifest | 1 +
tests/runtests.bat | 4 ++
tests/runtests.sh | 3 +
tests/test-find-files.scm | 160 ++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 168 insertions(+)
create mode 100644 tests/test-find-files.scm
diff --git a/distribution/manifest b/distribution/manifest
index 1285858..4ef3d1d 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -140,6 +140,7 @@ tests/module-tests.scm
tests/module-tests-2.scm
tests/test-finalizers.scm
tests/test-finalizers-2.scm
+tests/test-find-files.scm
tests/module-tests-compiled.scm
tests/scrutiny-tests.scm
tests/scrutiny-tests-strict.scm
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 942e234..b6ef378 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -418,6 +418,10 @@ echo 0 >tmpdir\.dotfile
%interpret% -R posix -e "(delete-directory \"tmpdir\" #t)"
if errorlevel 1 exit /b 1
+echo ======================================== find-files tests ...
+%interpret% -bnq test-find-files.scm
+if errorlevel 1 exit /b 1
+
echo ======================================== regular expression tests ...
%interpret% -bnq test-irregex.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index ba4449e..7e078ff 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -344,6 +344,9 @@ rm -fr tmpdir
mkdir tmpdir
touch tmpdir/.dotfile
+echo "======================================== find-files tests ..."
+$interpret -bnq test-find-files.scm
+
if test -z "$MSYSTEM"; then
ln -s /usr tmpdir/symlink
fi
diff --git a/tests/test-find-files.scm b/tests/test-find-files.scm
new file mode 100644
index 0000000..1053768
--- /dev/null
+++ b/tests/test-find-files.scm
@@ -0,0 +1,160 @@
+(use posix)
+(include "test.scm")
+
+(handle-exceptions exn
+ 'ignore
+ (delete-directory "find-files-test-dir" #t))
+
+(for-each (lambda (d)
+ (create-directory d #t))
+ '("find-files-test-dir/foo/bar/baz/.quux"
+ "find-files-test-dir/dir-link-target"
+ "find-files-test-dir/foo/.x"))
+
+(for-each (lambda (f)
+ (with-output-to-file f (cut display "")))
+ '("find-files-test-dir/file1"
+ "find-files-test-dir/file2"
+ "find-files-test-dir/dir-link-target/foo"
+ "find-files-test-dir/dir-link-target/bar"))
+
+(change-directory "find-files-test-dir")
+
+(create-symbolic-link "dir-link-target" "dir-link-name")
+
+(test-begin "find-files")
+
+(test-equal "no keyword args"
+ (find-files ".")
+ '("./foo/bar/baz"
+ "./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "dotfiles: #t"
+ (find-files "." dotfiles: #t)
+ '("./foo/bar/baz/.quux"
+ "./foo/bar/baz"
+ "./foo/bar"
+ "./foo/.x"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "follow-symlinks: #t"
+ (find-files "." follow-symlinks: #t)
+ '("./foo/bar/baz"
+ "./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "limit: 1"
+ (find-files "." limit: 1)
+ '("./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "limit: 1 follow-symlinks: #t"
+ (find-files "." limit: 1 follow-symlinks: #t)
+ '("./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "limit: 2"
+ (find-files "." limit: 2)
+ '("./foo/bar/baz"
+ "./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "limit: 2 follow-symlinks: #t"
+ (find-files "." limit: 2 follow-symlinks: #t)
+ '("./foo/bar/baz"
+ "./foo/bar"
+ "./foo"
+ "./dir-link-target/foo"
+ "./dir-link-target/bar"
+ "./dir-link-target"
+ "./file1"
+ "./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name"
+ "./file2"))
+
+(test-equal "test: (lambda (f) (directory? f))"
+ (find-files "." test: (lambda (f) (directory? f)))
+ '("./foo/bar/baz"
+ "./foo/bar"
+ "./foo"
+ "./dir-link-target"
+ "./dir-link-name"))
+
+(test-equal "test: (lambda (f) (directory? f)) action: (lambda (f p) (cons (string-append \"--\" f) p))"
+ (find-files "."
+ test: (lambda (f) (directory? f))
+ action: (lambda (f p) (cons (string-append "--" f) p)))
+ '("--./foo/bar/baz"
+ "--./foo/bar"
+ "--./foo"
+ "--./dir-link-target"
+ "--./dir-link-name"))
+
+(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t"
+ (find-files "." dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t)
+ '("./foo/bar/baz/.quux"
+ "./foo/bar/baz"
+ "./foo/bar"
+ "./foo/.x"
+ "./foo"
+ "./dir-link-target"
+ "./dir-link-name"))
+
+(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t limit: 1"
+ (find-files "."
+ dotfiles: #t
+ test: (lambda (f) (directory? f))
+ follow-symlinks: #t
+ limit: 1)
+ '("./foo/bar"
+ "./foo/.x"
+ "./foo"
+ "./dir-link-target"
+ "./dir-link-name"))
+
+(test-end "find-files")
+
+(change-directory "..")
+(delete-directory "find-files-test-dir" #t)
--
2.1.4
>From b216b5ac548cd67d6874d6e20ea9b0865b74be6a Mon Sep 17 00:00:00 2001
From: Mario Domenech Goulart <mario.goul...@gmail.com>
Date: Tue, 2 Jun 2015 22:08:17 -0300
Subject: [PATCH 2/2] posix-common: find-files: use `directory' instead of
`glob'
Using `directory' instead of `glob' gives a nice speed boost:
With `glob':
(time (find-files "."))
2.1s CPU time, 0.164s GC time (major), 2759998/21115 mutations (total/tracked), 4/15016 GCs (major/minor)
With `directory`:
(time (find-files "."))
0.58s CPU time, 0.092s GC time (major), 220194/12135 mutations (total/tracked), 3/2633 GCs (major/minor)
Timings for `(find-files ".")' on a directory containing the Linux
source code.
---
posix-common.scm | 65 +++++++++++++++++++++++++++++---------------------------
1 file changed, 34 insertions(+), 31 deletions(-)
diff --git a/posix-common.scm b/posix-common.scm
index 69b625d..0d3638e 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -495,37 +495,40 @@ EOF
;;; Find matching files:
-(define ##sys#find-files
- (lambda (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 ((fs (glob (make-pathname dir (if dot "?*" "*"))))
- (r id) )
- (if (null? fs)
- r
- (let ((f (##sys#slot fs 0))
- (rest (##sys#slot fs 1)) )
- (cond ((directory? f)
- (cond ((member (pathname-file f) '("." "..")) (loop rest r))
- ((and (symbolic-link? f) (not follow))
- (loop rest (if (pproc f) (action f r) r)))
- ((lproc f)
- (loop rest
- (fluid-let ((depth (fx+ depth 1)))
- (loop (glob (make-pathname f (if dot "?*" "*")))
- (if (pproc f) (action f r) r)) ) ) )
- (else (loop rest (if (pproc f) (action f r) r))) ) )
- ((pproc f) (loop rest (action f r)))
- (else (loop rest r)) ) ) ) ) ) ) )
+(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)))
--
2.1.4
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
