diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 532203421..00354ac73 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -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)) diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 5f6115427..96422b5e4 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -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,57 +430,60 @@ 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 - (let liip ((entry (readdir dir)) - (result (down full-name dir-stat result)) - (subdirs '())) - (cond ((eof-object? entry) - (begin - (closedir dir) - (let ((r+v - (fold (lambda (subdir result+visited) - (call-with-values - (lambda () - (loop (car subdir) - full-name - (cdr subdir) - (car result+visited) - (cdr result+visited))) - cons)) - (cons result visited) - subdirs))) - (values (up full-name dir-stat (car r+v)) - (cdr r+v))))) - ((or (string=? entry ".") - (string=? entry "..")) - (liip (readdir dir) - result - subdirs)) - (else - (let* ((child (string-append full-name "/" entry)) - (st (false-if-exception (stat child)))) - (if (and st (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))) + (cond + ((directory-stream? dir) + (let liip ((entry (readdir dir)) + (result (down full-name dir-stat result)) + (subdirs '())) + (cond ((eof-object? entry) + (begin + (closedir dir) + (let ((r+v + (fold (lambda (subdir result+visited) + (call-with-values + (lambda () + (loop (car subdir) + full-name + (cdr subdir) + (car result+visited) + (cdr result+visited))) + cons)) + (cons result visited) + subdirs))) + (values (up full-name dir-stat (car r+v)) + (cdr r+v))))) + ((or (string=? entry ".") + (string=? entry "..")) + (liip (readdir dir) + result + subdirs)) + (else + (let* ((child (string-append full-name "/" entry)) + (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)))))))) + (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 (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))) + + (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: