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 -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @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 Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2009,
@c Free Software Foundation, Inc. @c 2010, 2011, 2012 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@node Pretty Printing @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, directly as a directory tree is traversed; in fact,
@code{file-system-tree} is implemented in terms of it. @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 Traverse the directory at @var{file-name}, recursively, and return the
result of the successive applications of the @var{leaf}, @var{down}, result of the successive applications of the @var{leaf}, @var{down},
@var{up}, and @var{skip} procedures as described below. @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} When @var{file-name} names a flat file, @code{(@var{leaf} @var{path}
@var{stat} @var{init})} is returned. @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 The special @file{.} and @file{..} entries are not passed to these
procedures. The @var{path} argument to the procedures is a full file 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 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. ;; Likewise for skipped directories.
(define (skip name stat result) result) (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 0 ; initial counter is zero bytes
file-name)) file-name))

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

@ -1,6 +1,6 @@
;;;; ftw.scm --- file system tree walk ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -389,7 +389,14 @@
;;; `file-system-fold' & co. ;;; `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)) #:optional (stat lstat))
"Traverse the directory at FILE-NAME, recursively. Enter "Traverse the directory at FILE-NAME, recursively. Enter
sub-directories only when (ENTER? PATH STAT RESULT) returns true. When 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 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, 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 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. When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned.
The optional STAT parameter defaults to `lstat'." The optional STAT parameter defaults to `lstat'."
@ -409,7 +420,7 @@ The optional STAT parameter defaults to `lstat'."
(let loop ((name file-name) (let loop ((name file-name)
(path "") (path "")
(dir-stat (false-if-exception (stat file-name))) (dir-stat (errno-if-exception (stat file-name)))
(result init) (result init)
(visited vlist-null)) (visited vlist-null))
@ -419,57 +430,60 @@ The optional STAT parameter defaults to `lstat'."
(string-append path "/" name))) (string-append path "/" name)))
(cond (cond
((not dir-stat) ((integer? dir-stat)
;; FILE-NAME is not readable. ;; FILE-NAME is not readable.
(leaf full-name dir-stat result)) (error full-name #f dir-stat result))
((visited? visited dir-stat) ((visited? visited dir-stat)
(values result visited)) (values result visited))
((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time ((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time
(if (enter? full-name dir-stat result) (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))) (visited (mark visited dir-stat)))
(if dir (cond
(let liip ((entry (readdir dir)) ((directory-stream? dir)
(result (down full-name dir-stat result)) (let liip ((entry (readdir dir))
(subdirs '())) (result (down full-name dir-stat result))
(cond ((eof-object? entry) (subdirs '()))
(begin (cond ((eof-object? entry)
(closedir dir) (begin
(let ((r+v (closedir dir)
(fold (lambda (subdir result+visited) (let ((r+v
(call-with-values (fold (lambda (subdir result+visited)
(lambda () (call-with-values
(loop (car subdir) (lambda ()
full-name (loop (car subdir)
(cdr subdir) full-name
(car result+visited) (cdr subdir)
(cdr result+visited))) (car result+visited)
cons)) (cdr result+visited)))
(cons result visited) cons))
subdirs))) (cons result visited)
(values (up full-name dir-stat (car r+v)) subdirs)))
(cdr r+v))))) (values (up full-name dir-stat (car r+v))
((or (string=? entry ".") (cdr r+v)))))
(string=? entry "..")) ((or (string=? entry ".")
(liip (readdir dir) (string=? entry ".."))
result (liip (readdir dir)
subdirs)) result
(else subdirs))
(let* ((child (string-append full-name "/" entry)) (else
(st (false-if-exception (stat child)))) (let* ((child (string-append full-name "/" entry))
(if (and st (eq? (stat:type st) 'directory)) (st (errno-if-exception (stat child))))
(liip (readdir dir) (if (integer? st) ; CHILD is a dangling symlink?
result (liip (readdir dir)
(alist-cons entry st subdirs)) (error child #f st result)
(liip (readdir dir) subdirs)
(leaf child st result) (if (eq? (stat:type st) 'directory)
subdirs)))))) (liip (readdir dir)
result
;; Directory FULL-NAME not readable. (alist-cons entry st subdirs))
;; XXX: It's up to the user to distinguish between not (liip (readdir dir)
;; readable and not ENTER?. (leaf child st result)
(values (skip full-name dir-stat result) subdirs))))))))
visited))) (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) (values (skip full-name dir-stat result)
(mark visited dir-stat)))) (mark visited dir-stat))))
(else (else
@ -480,13 +494,14 @@ The optional STAT parameter defaults to `lstat'."
#:optional (enter? (lambda (n s) #t)) #:optional (enter? (lambda (n s) #t))
(stat lstat)) (stat lstat))
"Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is "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 each file contained in FILE-NAME when it designates a directory. The
optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should
return true to allow recursion into directory NAME; the default value is return true to allow recursion into directory NAME; the default value is
a procedure that always returns #t. When a directory does not match a procedure that always returns #t. When a directory does not match
ENTER?, it nonetheless appears in the resulting tree, only with zero 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) (define (enter?* name stat result)
(enter? name stat)) (enter? name stat))
(define (leaf name stat result) (define (leaf name stat result)
@ -504,8 +519,15 @@ children. The optional STAT parameter defaults to `lstat'."
rest)))) rest))))
(define skip ; keep an entry for skipped directories (define skip ; keep an entry for skipped directories
leaf) 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)) (define* (scandir name #:optional (select? (const #t))
(entry<? string-locale<?)) (entry<? string-locale<?))
@ -532,7 +554,12 @@ of file names is sorted according to ENTRY<?, which defaults to
;; All the sub-directories are skipped. ;; All the sub-directories are skipped.
(cons (basename name) result)) (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) (lambda (files)
(sort files entry<?)))) (sort files entry<?))))

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

@ -1,6 +1,6 @@
;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -81,12 +81,71 @@
;;; `file-system-fold' & co. ;;; `file-system-fold' & co.
;;; ;;;
(define %top-builddir
(canonicalize-path (getcwd)))
(define %top-srcdir (define %top-srcdir
(assq-ref %guile-build-info 'top_srcdir)) (assq-ref %guile-build-info 'top_srcdir))
(define %test-dir (define %test-dir
(string-append %top-srcdir "/test-suite")) (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" (with-test-prefix "file-system-fold"
(pass-if "test-suite" (pass-if "test-suite"
@ -98,10 +157,11 @@
(leaf (lambda (n s r) (cons `(leaf ,n) r))) (leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r))) (down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,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 (define seq
(reverse (reverse
(file-system-fold enter? leaf down up skip '() %test-dir))) (file-system-fold enter? leaf down up skip error '() %test-dir)))
(match seq (match seq
((('down (? (cut string=? <> %test-dir))) ((('down (? (cut string=? <> %test-dir)))
@ -123,8 +183,9 @@
(leaf (lambda (n s r) (cons `(leaf ,n) r))) (leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r))) (down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,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)))
(equal? (file-system-fold enter? leaf down up skip '() %test-dir) (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))))) `((skip , %test-dir)))))
(pass-if "test-suite/lib.scm (flat file)" (pass-if "test-suite/lib.scm (flat file)"
@ -133,9 +194,67 @@
(down (lambda (n s r) (cons `(down ,n) r))) (down (lambda (n s r) (cons `(down ,n) r)))
(up (lambda (n s r) (cons `(up ,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)))
(name (string-append %test-dir "/lib.scm"))) (name (string-append %test-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip '() name) (equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,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" (with-test-prefix "file-system-tree"
@ -165,7 +284,10 @@
(lset-intersection string=? files expected) (lset-intersection string=? files expected)
expected))) expected)))
(_ #f)) (_ #f))
children))))) children))))
(pass-if "ENOENT"
(not (file-system-tree "/.does-not-exist."))))
(with-test-prefix "scandir" (with-test-prefix "scandir"
@ -188,4 +310,11 @@
#t)))) #t))))
(pass-if "flat file" (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: