[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-118-g20c36
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-118-g20c360b |
|
Date: |
Sun, 08 Jan 2012 15:19:17 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=20c360b298dd9d29d0b1a6301f43ff6da4968908
The branch, stable-2.0 has been updated
via 20c360b298dd9d29d0b1a6301f43ff6da4968908 (commit)
via be96155b508d220efe6f419d7743cf39744ee47c (commit)
from 9a38439301aac35961e8f7e316cd02a589b5956f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 20c360b298dd9d29d0b1a6301f43ff6da4968908
Author: Ludovic Courtès <address@hidden>
Date: Sun Jan 8 16:08:45 2012 +0100
Fix typo in `test-num2integral.c'.
* test-suite/standalone/test-num2integral.c (out_of_range_handler): Use
`scm_is_eq' when comparing KEY.
commit be96155b508d220efe6f419d7743cf39744ee47c
Author: Ludovic Courtès <address@hidden>
Date: Sun Jan 8 16:06:35 2012 +0100
ftw: Add an `error' parameter to `file-system-fold'.
* 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.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/misc-modules.texi | 20 +++-
module/ice-9/ftw.scm | 133 ++++++++++++++++----------
test-suite/standalone/test-num2integral.c | 5 +-
test-suite/tests/ftw.test | 147 +++++++++++++++++++++++++++--
4 files changed, 237 insertions(+), 68 deletions(-)
diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index 5322034..00354ac 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.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2009, 2010, 2011
address@hidden Free Software Foundation, Inc.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2009,
address@hidden 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.
address@hidden {Scheme Procedure} file-system-fold enter? leaf down up skip
init file-name [stat]
address@hidden {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}
address@hidden @var{stat} @var{errno} @var{result})}, with @var{errno} being
+the operating system error number that was raised---e.g.,
address@hidden @var{stat} either @code{#f} or the result of the
address@hidden 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 5f61154..96422b5 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<? 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<?))))
diff --git a/test-suite/standalone/test-num2integral.c
b/test-suite/standalone/test-num2integral.c
index 6a44fb7..0246a33 100644
--- a/test-suite/standalone/test-num2integral.c
+++ b/test-suite/standalone/test-num2integral.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008, 2010 Free Software
Foundation, Inc.
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+ * 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 License
@@ -33,7 +34,7 @@ SCM call_num2ulong_long_body (void *data);
SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
- assert (scm_equal_p (key, scm_from_locale_symbol ("out-of-range")));
+ assert (scm_is_eq (key, scm_from_locale_symbol ("out-of-range")));
return SCM_BOOL_T;
}
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index fa179d4..be983a1 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -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:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-118-g20c360b,
Ludovic Courtès <=