Change log merger to accept a single directory argument, and to scan

down that directory tree looking for files under RCS control.  It
additionally indirects through symbolic links, finding the RCS files
for the linked files in their home directories.

diff --git a/v7/src/rcs/logmer.scm b/v7/src/rcs/logmer.scm
index 24381cdb58ffbb713a3f34e257a27f0aa01a1d0b..14c8fdc3016aa866d9f317ef54580db29ad5fcfe 100644 (file)
--- a/v7/src/rcs/logmer.scm
+++ b/v7/src/rcs/logmer.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: logmer.scm,v 1.6 1995/07/29 16:55:56 adams Exp $
+$Id: logmer.scm,v 1.7 1995/11/11 07:24:17 cph Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,7 +38,7 @@ MIT in each case. |#
 \f
 (define trace-port false)
 
-(define (rcs-directory-log output-file . directories)
+(define (rcs-directory-log output-file directory)
   (format-to-file
    output-file
    (fluid-let ((trace-port (nearest-cmdl/port)))
@@ -46,8 +46,7 @@ MIT in each case. |#
            (sort-entries
             (let ((entries
                    (read-entries
-                    (let ((pathnames
-                           (append-map! rcs-directory-read directories)))
+                    (let ((pathnames (rcs-directory-read directory)))
                       (newline trace-port)
                       (write-string "total files: " trace-port)
                       (write (length pathnames) trace-port)
@@ -176,10 +175,53 @@ MIT in each case. |#
                          input*)
                      (cons (car input) output))))))))
 \f
-(define (rcs-directory-read filename)
-  (list-transform-positive (directory-read (pathname-as-directory filename))
-    (lambda (pathname)
-      (string-suffix? ",v" (file-namestring pathname)))))
+(define (rcs-directory-read pathname)
+  (let ((files '()))
+    (define (scan-directory pathname)
+      (for-each scan-file
+               (directory-read (pathname-as-directory pathname) #f)))
+
+    (define (scan-file pathname)
+      (let ((attributes (file-attributes-direct pathname)))
+       (let ((type (file-attributes/type attributes)))
+         (cond ((not type)
+                (maybe-add-file pathname))
+               ((eq? type #t)
+                (if (not (member (file-namestring pathname) '("." "..")))
+                    (scan-directory pathname)))
+               ((string? type)
+                (let ((pathname
+                       (merge-pathnames type (directory-pathname pathname))))
+                  (if (regular-file? pathname)
+                      (maybe-add-file (pathname-simplify pathname)))))))))
+
+    (define (maybe-add-file pathname)
+      (if (and (not (ignored-file-name? pathname))
+              (under-rcs-control? pathname))
+         (begin
+           (set! files (cons pathname files))
+           unspecific)))
+
+    (define (under-rcs-control? pathname)
+      (let ((directory (directory-pathname pathname))
+           (name (string-append (file-namestring pathname) ",v")))
+       (or (regular-file?
+            (merge-pathnames name (merge-pathnames "RCS/" directory)))
+           (regular-file? (merge-pathnames name directory)))))
+
+    (define (regular-file? pathname)
+      (let ((attributes (file-attributes pathname)))
+       (and attributes
+            (not (file-attributes/type attributes)))))
+
+    (define (ignored-file-name? pathname)
+      (let ((name (file-namestring pathname)))
+       (or (string-suffix? ",v" name)
+           (string-suffix? "~" name)
+           (string-prefix? "#" name))))
+
+    (scan-directory pathname)
+    files))
 
 (define (greatest-common-prefix pathnames)
   (if (null? pathnames)

diff --git a/v7/src/rcs/mklogs.scm b/v7/src/rcs/mklogs.scm
index c2b7f8bb3165f207ed938b04fa6c551a4b17f1cf..e7f0673f65b73d552f2024223ed7f665998e0e02 100644 (file)
--- a/v7/src/rcs/mklogs.scm
+++ b/v7/src/rcs/mklogs.scm
@@ -1,25 +1,17 @@
 ;;; -*-Scheme-*-
 (let ((rcs-directory-log (access rcs-directory-log (->environment '(RCS)))))
-  (define (make-log directory . subdirectories)
-    (with-working-directory-pathname directory
-      (lambda ()
-       (apply rcs-directory-log
-              "RCS.log"
-              (cons "RCS"
-                    (map (lambda (subdirectory)
-                           (string-append subdirectory "/RCS"))
-                         subdirectories))))))
-  (make-log "/scheme/src/6001")
-  (make-log "/scheme/src/compiler" "back" "base" "documentation" "etc" "fggen"
-           "fgopt" "machines/C" "machines/alpha" "machines/bobcat"
-           "machines/i386" "machines/mips" "machines/sparc"
-           "machines/spectrum" "machines/vax" "rtlbase" "rtlgen" "rtlopt")
-  (make-log "/scheme/src/cref")
-  (make-log "/scheme/src/edwin")
-  (make-log "/scheme/src/microcode" "cmpauxmd" "cmpintmd" "dosutl" "m" "ntutl"
-           "s" "unxutl")
-  (make-log "/scheme/src/rcs")
-  (make-log "/scheme/src/runtime")
-  (make-log "/scheme/src/sf")
-  (make-log "/scheme/src/sicp")
-  (make-log "/scheme/src/win32" "dibutils"))
\ No newline at end of file
+  (for-each (lambda (directory)
+             (rcs-directory-log
+              (merge-pathnames "RCS.log"
+                               (pathname-as-directory directory))
+              directory))
+           '("/scheme/src/6001"
+             "/scheme/src/compiler"
+             "/scheme/src/cref"
+             "/scheme/src/edwin"
+             "/scheme/src/microcode"
+             "/scheme/src/rcs"
+             "/scheme/src/runtime"
+             "/scheme/src/sf"
+             "/scheme/src/sicp"
+             "/scheme/src/win32")))
\ No newline at end of file