mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

ftw: Add an error' parameter to file-system-fold'.

Browse source 
* module/ice-9/ftw.scm (errno-if-exception): New macro.
  (file-system-fold): Add an `error' parameter.  Wrap `opendir' and STAT
  calls in `errno-if-exception' and call ERROR when appropriate.
  (file-system-tree): Provide an `error' procedure.  Return #f when
  FILE-NAME is unreadable.
  (scandir): Provide an `error' procedure.

* test-suite/tests/ftw.test (%top-builddir): New variable.
  (make-file-tree, delete-file-tree): New procedures.
  (with-file-tree): New macro.
  ("file-system-fold"): Update tests to add an `error' procedure.
  ["ENOENT", "EACCES", "dangling symlink and lstat", "dangling symlink
  and stat"]: New tests.
  ("file-system-tree")["ENOENT"]: New test.
  ("scandir")["EACCES"]: New test.

* doc/ref/misc-modules.texi (File Tree Walk): Update `file-system-fold'
  documentation.
This commit is contained in:
Ludovic Courtès 2012-01-08 16:06:35 +01:00
parent 9a38439301
commit be96155b50
3 changed files with 234 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

20
doc/ref/misc-modules.texi
View file

@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2009, 2010, 2011
@c Free Software Foundation, Inc.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2009,
@c 2010, 2011, 2012 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Pretty Printing
@ -1180,7 +1180,7 @@ than building up a tree of entries in memory, like
directly as a directory tree is traversed; in fact,
@code{file-system-tree} is implemented in terms of it.
@deffn {Scheme Procedure} file-system-fold enter? leaf down up skip init file-name [stat]
@deffn {Scheme Procedure} file-system-fold enter? leaf down up skip error init file-name [stat]
Traverse the directory at @var{file-name}, recursively, and return the
result of the successive applications of the @var{leaf}, @var{down},
@var{up}, and @var{skip} procedures as described below.
@ -1202,6 +1202,12 @@ encountered, call @code{(@var{skip} @var{path} @var{stat}
When @var{file-name} names a flat file, @code{(@var{leaf} @var{path}
@var{stat} @var{init})} is returned.
When an @code{opendir} or @var{stat} call fails, call @code{(@var{error}
@var{path} @var{stat} @var{errno} @var{result})}, with @var{errno} being
the operating system error number that was raised---e.g.,
@code{EACCES}---and @var{stat} either @code{#f} or the result of the
@var{stat} call for that entry, when available.
The special @file{.} and @file{..} entries are not passed to these
procedures. The @var{path} argument to the procedures is a full file
name---e.g., @code{"../foo/bar/gnu"}; if @var{file-name} is an absolute
@ -1235,7 +1241,13 @@ to `du --apparent-size' with GNU Coreutils.)"
;; Likewise for skipped directories.
(define (skip name stat result) result)
(file-system-fold enter? leaf down up skip
;; Ignore unreadable files/directories but warn the user.
(define (error name stat errno result)
(format (current-error-port) "warning: ~a: ~a~%"
name (strerror errno))
result)
(file-system-fold enter? leaf down up skip error
0 ; initial counter is zero bytes
file-name))

69
module/ice-9/ftw.scm
View file

@ -1,6 +1,6 @@
;;;; ftw.scm --- file system tree walk
;;;; Copyright (C) 2002, 2003, 2006, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -389,7 +389,14 @@
;;; `file-system-fold' & co.
;;;
(define* (file-system-fold enter? leaf down up skip init file-name
(define-syntax-rule (errno-if-exception expr)
(catch 'system-error
(lambda ()
expr)
(lambda args
(system-error-errno args))))
(define* (file-system-fold enter? leaf down up skip error init file-name
#:optional (stat lstat))
"Traverse the directory at FILE-NAME, recursively. Enter
sub-directories only when (ENTER? PATH STAT RESULT) returns true. When
@ -397,7 +404,11 @@ a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is
the path of the sub-directory and STAT the result of (stat PATH); when
it is left, call (UP PATH STAT RESULT). For each file in a directory,
call (LEAF PATH STAT RESULT). When ENTER? returns false, call (SKIP
PATH STAT RESULT). Return the result of these successive applications.
PATH STAT RESULT). When an `opendir' or STAT call raises an exception,
call (ERROR PATH STAT ERRNO RESULT), with ERRNO being the operating
system error number that was raised.
Return the result of these successive applications.
When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned.
The optional STAT parameter defaults to `lstat'."
@ -409,7 +420,7 @@ The optional STAT parameter defaults to `lstat'."
(let loop ((name file-name)
(path "")
(dir-stat (false-if-exception (stat file-name)))
(dir-stat (errno-if-exception (stat file-name)))
(result init)
(visited vlist-null))
@ -419,16 +430,17 @@ The optional STAT parameter defaults to `lstat'."
(string-append path "/" name)))
(cond
((not dir-stat)
((integer? dir-stat)
;; FILE-NAME is not readable.
(leaf full-name dir-stat result))
(error full-name #f dir-stat result))
((visited? visited dir-stat)
(values result visited))
((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time
(if (enter? full-name dir-stat result)
(let ((dir (false-if-exception (opendir full-name)))
(let ((dir (errno-if-exception (opendir full-name)))
(visited (mark visited dir-stat)))
(if dir
(cond
((directory-stream? dir)
(let liip ((entry (readdir dir))
(result (down full-name dir-stat result))
(subdirs '()))
@ -456,20 +468,22 @@ The optional STAT parameter defaults to `lstat'."
subdirs))
(else
(let* ((child (string-append full-name "/" entry))
(st (false-if-exception (stat child))))
(if (and st (eq? (stat:type st) 'directory))
(st (errno-if-exception (stat child))))
(if (integer? st) ; CHILD is a dangling symlink?
(liip (readdir dir)
(error child #f st result)
subdirs)
(if (eq? (stat:type st) 'directory)
(liip (readdir dir)
result
(alist-cons entry st subdirs))
(liip (readdir dir)
(leaf child st result)
subdirs))))))
;; Directory FULL-NAME not readable.
;; XXX: It's up to the user to distinguish between not
;; readable and not ENTER?.
(values (skip full-name dir-stat result)
visited)))
subdirs))))))))
(else
;; Directory FULL-NAME not readable, but it is stat'able.
(values (error full-name dir-stat dir result)
visited))))
(values (skip full-name dir-stat result)
(mark visited dir-stat))))
(else
@ -480,13 +494,14 @@ The optional STAT parameter defaults to `lstat'."
#:optional (enter? (lambda (n s) #t))
(stat lstat))
"Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is
the result of (stat FILE-NAME) and CHILDREN are similar structures for
the result of (STAT FILE-NAME) and CHILDREN are similar structures for
each file contained in FILE-NAME when it designates a directory. The
optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should
return true to allow recursion into directory NAME; the default value is
a procedure that always returns #t. When a directory does not match
ENTER?, it nonetheless appears in the resulting tree, only with zero
children. The optional STAT parameter defaults to `lstat'."
children. The optional STAT parameter defaults to `lstat'. Return #f
when FILE-NAME is not readable."
(define (enter?* name stat result)
(enter? name stat))
(define (leaf name stat result)
@ -504,8 +519,15 @@ children. The optional STAT parameter defaults to `lstat'."
rest))))
(define skip ; keep an entry for skipped directories
leaf)
(define (error name stat errno result)
(if (string=? name file-name)
result
(leaf name stat result)))
(caar (file-system-fold enter?* leaf down up skip '(()) file-name stat)))
(match (file-system-fold enter?* leaf down up skip error '(())
file-name stat)
(((tree)) tree)
((()) #f))) ; FILE-NAME is unreadable
(define* (scandir name #:optional (select? (const #t))
(entry<? string-locale<?))
@ -532,7 +554,12 @@ of file names is sorted according to ENTRY<?, which defaults to
;; All the sub-directories are skipped.
(cons (basename name) result))
(and=> (file-system-fold enter? leaf down up skip #f name stat)
(define (error name* stat errno result)
(if (string=? name name*) ; top-level NAME is unreadable
result
(cons (basename name*) result)))
(and=> (file-system-fold enter? leaf down up skip error #f name stat)
(lambda (files)
(sort files entry<?))))

147
test-suite/tests/ftw.test
View file

@ -1,6 +1,6 @@
;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
;;;;
;;;; Copyright 2006, 2011 Free Software Foundation, Inc.
;;;; Copyright 2006, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -81,12 +81,71 @@
;;; `file-system-fold' & co.
;;;
(define %top-builddir
(canonicalize-path (getcwd)))
(define %top-srcdir
(assq-ref %guile-build-info 'top_srcdir))
(define %test-dir
(string-append %top-srcdir "/test-suite"))
(define (make-file-tree dir tree)
"Make file system TREE at DIR."
(define (touch file)
(call-with-output-file file
(cut display "" <>)))
(let loop ((dir dir)
(tree tree))
(define (scope file)
(string-append dir "/" file))
(match tree
(('directory name (body ...))
(mkdir (scope name))
(for-each (cute loop (scope name) <>) body))
(('directory name (? integer? mode) (body ...))
(mkdir (scope name))
(for-each (cute loop (scope name) <>) body)
(chmod (scope name) mode))
((file)
(touch (scope file)))
((file (? integer? mode))
(touch (scope file))
(chmod (scope file) mode))
((from '-> to)
(symlink to (scope from))))))
(define (delete-file-tree dir tree)
"Delete file TREE from DIR."
(let loop ((dir dir)
(tree tree))
(define (scope file)
(string-append dir "/" file))
(match tree
(('directory name (body ...))
(for-each (cute loop (scope name) <>) body)
(rmdir (scope name)))
(('directory name (? integer? mode) (body ...))
(chmod (scope name) #o755) ; make sure it can be entered
(for-each (cute loop (scope name) <>) body)
(rmdir (scope name)))
((from '-> _)
(delete-file (scope from)))
((file _ ...)
(delete-file (scope file))))))
(define-syntax-rule (with-file-tree dir tree body ...)
(dynamic-wind
(lambda ()
(make-file-tree dir tree))
(lambda ()
body ...)
(lambda ()
(delete-file-tree dir tree))))
(with-test-prefix "file-system-fold"
(pass-if "test-suite"
@ -98,10 +157,11 @@
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r))))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r))))
(define seq
(reverse
(file-system-fold enter? leaf down up skip '() %test-dir)))
(file-system-fold enter? leaf down up skip error '() %test-dir)))
(match seq
((('down (? (cut string=? <> %test-dir)))
@ -123,8 +183,9 @@
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r))))
(equal? (file-system-fold enter? leaf down up skip '() %test-dir)
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r))))
(equal? (file-system-fold enter? leaf down up skip error '() %test-dir)
`((skip , %test-dir)))))
(pass-if "test-suite/lib.scm (flat file)"
@ -133,9 +194,67 @@
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r)))
(name (string-append %test-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip '() name)
`((leaf ,name))))))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,name)))))
(pass-if "ENOENT"
(let ((enter? (lambda (n s r) #t))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n ,e) r)))
(name "/.does-not-exist."))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((error ,name ,ENOENT)))))
(pass-if "EACCES"
(with-file-tree %top-builddir '(directory "test-EACCES" #o000
(("a") ("b")))
(let ((enter? (lambda (n s r) #t))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n ,e) r)))
(name (string-append %top-builddir "/test-EACCES")))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((error ,name ,EACCES))))))
(pass-if "dangling symlink and lstat"
(with-file-tree %top-builddir '(directory "test-dangling"
(("dangling" -> "xxx")))
(let ((enter? (lambda (n s r) #t))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n ,e) r)))
(name (string-append %top-builddir "/test-dangling")))
(equal? (file-system-fold enter? leaf down up skip error '()
name)
`((up ,name)
(leaf ,(string-append name "/dangling"))
(down ,name))))))
(pass-if "dangling symlink and stat"
;; Same as above, but using `stat' instead of `lstat'.
(with-file-tree %top-builddir '(directory "test-dangling"
(("dangling" -> "xxx")))
(let ((enter? (lambda (n s r) #t))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n ,e) r)))
(name (string-append %top-builddir "/test-dangling")))
(equal? (file-system-fold enter? leaf down up skip error '()
name stat)
`((up ,name)
(error ,(string-append name "/dangling") ,ENOENT)
(down ,name)))))))
(with-test-prefix "file-system-tree"
@ -165,7 +284,10 @@
(lset-intersection string=? files expected)
expected)))
(_ #f))
children)))))
children))))
(pass-if "ENOENT"
(not (file-system-tree "/.does-not-exist."))))
(with-test-prefix "scandir"
@ -188,4 +310,11 @@
#t))))
(pass-if "flat file"
(not (scandir (string-append %test-dir "/Makefile.am")))))
(not (scandir (string-append %test-dir "/Makefile.am"))))
(pass-if "EACCES"
(not (scandir "/.does-not-exist."))))
;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End: