From 243db01e51297cf7e165ee91e96221426b12b345 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 Dec 2011 23:54:26 +0100 Subject: Add `file-system-fold' and `file-system-tree' to (ice-9 ftw). * module/ice-9/ftw.scm (file-system-fold, file-system-tree): New procedures. * test-suite/tests/ftw.test (%top-srcdir, %test-dir): New variables. ("file-system-fold", "file-system-tree"): New test prefixes. * doc/ref/misc-modules.texi (File Tree Walk): Document `file-system-tree' and `file-system-fold'. --- module/ice-9/ftw.scm | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 128 insertions(+), 2 deletions(-) (limited to 'module') diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index e6ac0b462..539d80b5f 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 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011 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 @@ -190,7 +190,12 @@ ;;; Code: (define-module (ice-9 ftw) - :export (ftw nftw)) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:export (ftw nftw + file-system-fold + file-system-tree)) (define (directory-files dir) (let ((dir-stream (opendir dir))) @@ -377,4 +382,125 @@ (chdir od) ret)))) + +;;; +;;; `file-system-fold' & co. +;;; + +(define (file-system-fold enter? leaf down up skip init file-name) + "Traverse the directory at FILE-NAME, recursively. Enter +sub-directories only when (ENTER? PATH STAT RESULT) returns true. When +a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is +the path of the sub-directory and STAT the result of (lstat 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. +When FILE-NAME names a flat file,(LEAF PATH STAT INIT) is returned." + + (define (mark v s) + (vhash-cons (cons (stat:dev s) (stat:ino s)) #t v)) + + (define (visited? v s) + (vhash-assoc (cons (stat:dev s) (stat:ino s)) v)) + + (let loop ((name file-name) + (path "") + (dir-stat (false-if-exception (lstat file-name))) + (result init) + (visited vlist-null)) + + (define full-name + (if (string=? path "") + name + (string-append path "/" name))) + + (cond + ((not dir-stat) + ;; FILE-NAME is not readable. + (leaf full-name 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))) + (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)) + (stat (lstat child))) ; cannot fail + (cond + ((eq? (stat:type stat) 'directory) + (liip (readdir dir) + result + (alist-cons entry stat subdirs))) + (else + (liip (readdir dir) + (leaf child stat 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))) + (values (skip full-name dir-stat result) + (mark visited dir-stat)))) + (else + ;; Caller passed a FILE-NAME that names a flat file, not a directory. + (leaf full-name dir-stat result))))) + +(define* (file-system-tree file-name #:optional (enter? (lambda (n s) #t))) + "Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is +the result of (lstat 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." + (define (enter?* name stat result) + (enter? name stat)) + (define (leaf name stat result) + (match result + (((siblings ...) rest ...) + (cons (alist-cons (basename name) (cons stat '()) siblings) + rest)))) + (define (down name stat result) + (cons '() result)) + (define (up name stat result) + (match result + (((children ...) (siblings ...) rest ...) + (cons (alist-cons (basename name) (cons stat children) + siblings) + rest)))) + (define skip ; keep an entry for skipped directories + leaf) + + (caar (file-system-fold enter?* leaf down up skip '(()) file-name))) + ;;; ftw.scm ends here -- cgit v1.2.3