From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Mar 2000 22:52:51 +0000 (+0000)
Subject: Changes to generate ChangeLog-style output, and to support CVS in
X-Git-Tag: 20090517-FFI~4192
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=42538299d5253674cc45e5a4ffa49924a9d1f3a9;p=mit-scheme.git

Changes to generate ChangeLog-style output, and to support CVS in
addition to RCS.
---

diff --git a/v7/src/rcs/logmer.scm b/v7/src/rcs/logmer.scm
index f794c0ec1..658254ddf 100644
--- a/v7/src/rcs/logmer.scm
+++ b/v7/src/rcs/logmer.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: logmer.scm,v 1.19 2000/02/01 01:59:51 cph Exp $
+$Id: logmer.scm,v 1.20 2000/03/20 22:52:26 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -23,92 +23,220 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (declare (usual-integrations))
 
-(define (rcs-directory-log directory #!optional output-file)
-  (let ((output-file
-	 (merge-pathnames (if (or (default-object? output-file)
-				  (not output-file))
-			      "RCS.log"
-			      output-file)
-			  (pathname-as-directory directory)))
+(define (rcs-directory-log directory #!optional output-file
+			   changelog? changelog-map)
+  (let ((changelog? (if (default-object? changelog?) #f changelog?))
+	(changelog-map
+	 (if (default-object? changelog-map)
+	     (list (os/hostname))
+	     changelog-map))
 	(port (notification-output-port)))
-    (write-string "regenerating log for directory: " port)
-    (write (->namestring directory))
-    (write-string "..." port)
-    (let ((pathnames (rcs-directory-read directory)))
-      (if (let ((time (file-modification-time-indirect output-file)))
-	    (or (not time)
-		(there-exists? pathnames
-		  (lambda (w.r)
-		    (> (file-modification-time-indirect (cdr w.r)) time)))))
-	  (begin
-	    (newline port)
-	    (write-string "total files: " port)
-	    (write (length pathnames) port)
-	    (newline port)
-	    (let ((entries (read-entries pathnames port)))
-	      (write-string "total entries: " port)
-	      (write (length entries) port)
-	      (newline port)
-	      (let ((entries (sort-entries entries)))
-		(write-string "sorting finished" port)
+    (let ((output-file
+	   (merge-pathnames (if (or (default-object? output-file)
+				    (not output-file))
+				(if changelog? "ChangeLog" "RCS.log")
+				output-file)
+			    (pathname-as-directory directory))))
+      (fluid-let ((*date-rounds-to-day?* changelog?))
+	(write-string "regenerating log for directory: " port)
+	(write (->namestring directory))
+	(write-string "..." port)
+	(let ((pathnames (rcs-directory-read directory)))
+	  (if (let ((time (file-modification-time-indirect output-file)))
+		(or (not time)
+		    (there-exists? pathnames
+		      (lambda (w.r)
+			(> (file-modification-time-indirect (cdr w.r))
+			   time)))))
+	      (begin
 		(newline port)
-		(call-with-output-file output-file
-		  (lambda (port)
-		    (format/entries entries port))))))
-	  (begin
-	    (write-string " log is up to date" port)
-	    (newline port))))))
-
-(define (format/entries entries port)
-  (let ((groups (compress-entries entries)))
-    (if (not (null? groups))
+		(write-string "total files: " port)
+		(write (length pathnames) port)
+		(newline port)
+		(let ((entries (read-entries pathnames port)))
+		  (write-string "total entries: " port)
+		  (write (length entries) port)
+		  (newline port)
+		  (let ((entries
+			 (if changelog?
+			     (sort-entries-for-changelog entries)
+			     (sort-entries-for-rcs.log entries))))
+		    (write-string "sorting finished" port)
+		    (newline port)
+		    (call-with-output-file output-file
+		      (lambda (port)
+			(if changelog?
+			    (format-changelog entries changelog-map port)
+			    (format-rcs.log entries port)))))))
+	      (begin
+		(write-string " log is up to date" port)
+		(newline port))))))))
+
+;;;; RCS.log format
+
+(define (format-rcs.log entries port)
+  (let ((groups (group-entries-by-log entries))
+	(format-group
+	 (lambda (group)
+	   (for-each (lambda (entry)
+		       (let ((delta (car entry))
+			     (filename (cdr entry)))
+			 (write-string "file: " port)
+			 (write-string filename port)
+			 (write-string ";  revision: " port)
+			 (write-string (delta/number delta) port)
+			 (write-string "\ndate: " port)
+			 (write-string (date->string (delta/date delta)) port)
+			 (write-string ";  author: " port)
+			 (write-string (delta/author delta) port)
+			 (newline port)))
+		     group)
+	   (newline port)
+	   (write-string (delta/log (car (car group))) port)
+	   (newline port))))
+    (if (pair? groups)
 	(begin
-	  (format/group (car groups) port)
+	  (format-group (car groups))
 	  (for-each (lambda (group)
 		      (write-string "----------------------------" port)
 		      (newline port)
-		      (format/group group port))
+		      (format-group group))
+		    (cdr groups))))))
+
+(define (sort-entries-for-rcs.log entries)
+  (sort entries
+    (lambda (x y)
+      (date<? (delta/date (car y)) (delta/date (car x))))))
+
+;;;; ChangeLog format
+
+(define (format-changelog entries changelog-map port)
+  (let ((groups
+	 (group-entries-by-author&date
+	  (list-transform-negative entries
+	    (lambda (entry)
+	      (string-prefix? "#" (delta/log (car entry)))))))
+	(format-group
+	 (lambda (entries)
+	   (write-string
+	    (format-date-for-changelog (delta/date (caar entries)))
+	    port)
+	   (write-string "  " port)
+	   (let ((author (delta/author (caar entries))))
+	     (let ((mentry (assoc author (cdr changelog-map))))
+	       (write-string (if mentry (cadr mentry) author) port)
+	       (write-string " <" port)
+	       (if (and mentry (pair? (cddr mentry)))
+		   (write-string (caddr mentry) port)
+		   (begin
+		     (write-string author port)
+		     (write-string "@" port)
+		     (write-string (car changelog-map) port)))
+	       (write-string ">" port)))
+	   (newline port)
+	   (for-each (lambda (entries)
+		       (newline port)
+		       (write-char #\tab port)
+		       (write-string "* " port)
+		       (write-string (cdar entries) port)
+		       (let loop
+			   ((entries (cdr entries))
+			    (column (fix:+ 11 (string-length (cdar entries)))))
+			 (if (pair? entries)
+			     (let ((filename (cdar entries)))
+			       (let ((column*
+				      (+ column 2 (string-length filename))))
+				 (if (fix:>= column* 80)
+				     (begin
+				       (write-string "," port)
+				       (newline port)
+				       (write-char #\tab port)
+				       (write-string "  " port)
+				       (write-string filename port)
+				       (loop (cdr entries)
+					     (fix:+ 11
+						    (string-length filename))))
+				     (begin
+				       (write-string ", " port)
+				       (write-string filename port)
+				       (loop (cdr entries) column*)))))))
+		       (write-string ":" port)
+		       (newline port)
+		       (format-log-for-changelog (delta/log (caar entries))
+						 port))
+		     (group-entries-by-log entries)))))
+    (if (pair? groups)
+	(begin
+	  (format-group (car groups))
+	  (for-each (lambda (group)
+		      (newline port)
+		      (format-group group))
 		    (cdr groups))))))
+
+(define (sort-entries-for-changelog entries)
+  (sort entries
+    (lambda (x y)
+      (or (> (date/universal (delta/date (car x)))
+	     (date/universal (delta/date (car y))))
+	  (and (= (date/universal (delta/date (car x)))
+		  (date/universal (delta/date (car y))))
+	       (or (string<? (delta/author (car x))
+			     (delta/author (car y)))
+		   (and (string=? (delta/author (car x))
+				  (delta/author (car y)))
+			(string<? (delta/log (car x))
+				  (delta/log (car y))))))))))
+
+(define (format-date-for-changelog date)
+  (let ((dt (date/decoded date)))
+    (string-append
+     (number->string (decoded-time/year dt))
+     "-"
+     (string-pad-left (number->string (decoded-time/month dt)) 2 #\0)
+
+     "-"
+     (string-pad-left (number->string (decoded-time/day dt)) 2 #\0))))
 
-(define (format/group group port)
-  (for-each (lambda (entry)
-	      (format/entry (cdr entry) (car entry) port))
-	    group)
-  (newline port)
-  (write-string (delta/log (car (car group))) port)
-  (newline port))
-
-(define (format/entry filename delta port)
-  (write-string "file: " port)
-  (write-string filename port)
-  (write-string ";  revision: " port)
-  (write-string (delta/number delta) port)
-  (write-string "\ndate: " port)
-  (write-string (date->string (delta/date delta)) port)
-  (write-string ";  author: " port)
-  (write-string (delta/author delta) port)
-  (write-string ";  state: " port)
-  (write-string (delta/state delta) port)
-  (newline port))
+(define (format-log-for-changelog log port)
+  (write-char #\tab port)
+  (let ((end (string-length log)))
+    (let loop ((start 0))
+      (let ((index (substring-find-next-char log start end #\newline)))
+	(if index
+	    (let ((index (fix:+ index 1)))
+	      (write-substring log start index port)
+	      (if (fix:< index end)
+		  (begin
+		    (write-char #\tab port)
+		    (loop index))))
+	    (begin
+	      (write-substring log start end port)
+	      (newline port)))))))
 
-(define (compress-entries entries)
-  (if (null? entries)
-      '()
-      (let ((entry (car entries)))
-	(let loop
-	    ((entries (cdr entries))
-	     (receiver
-	      (lambda (similar entries)
-		(cons (cons entry similar)
-		      (compress-entries entries)))))
-	  (if (or (null? entries)
-		  (not (string=? (delta/log (car entry))
-				 (delta/log (car (car entries))))))
-	      (receiver '() entries)
-	      (loop (cdr entries)
-		    (lambda (similar entries*)
-		      (receiver (cons (car entries) similar)
-				entries*))))))))
+(define (group-entries-by-author&date entries)
+  (group-entries entries
+    (lambda (x y)
+      (and (string=? (delta/author (car x))
+		     (delta/author (car y)))
+	   (= (date/universal (delta/date (car x)))
+	      (date/universal (delta/date (car y))))))))
+
+(define (group-entries-by-log entries)
+  (group-entries entries
+    (lambda (x y)
+      (string=? (delta/log (car x))
+		(delta/log (car y))))))
+
+(define (group-entries entries predicate)
+  (let outer ((entries entries) (groups '()))
+    (if (pair? entries)
+	(let ((entry (car entries)))
+	  (let inner ((entries (cdr entries)) (group (list entry)))
+	    (if (and (pair? entries)
+		     (predicate entry (car entries)))
+		(inner (cdr entries) (cons (car entries) group))
+		(outer entries (cons (reverse! group) groups)))))
+	(reverse! groups))))
 
 (define (read-entries pairs notification-port)
   (let ((prefix (greatest-common-prefix (map car pairs))))
@@ -120,11 +248,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	    (read-file (cdr w.r) notification-port)))
      pairs)))
 
-(define (sort-entries entries)
-  (sort entries
-	(lambda (x y)
-	  (date<? (delta/date (car y)) (delta/date (car x))))))
-
 (define (read-file pathname notification-port)
   (if notification-port
       (begin
@@ -161,16 +284,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (rcs-directory-read pathname)
   (let ((files '()))
-    (define (scan-directory directory original-directory)
+    (define (scan-directory cvs-mode? directory original-directory)
       (let ((directory (pathname-as-directory directory))
 	    (original-directory (pathname-as-directory original-directory)))
 	(for-each (lambda (pathname)
-		    (scan-file pathname
+		    (scan-file cvs-mode?
+			       pathname
 			       (merge-pathnames (file-pathname pathname)
 						original-directory)))
 		  (directory-read directory #f))))
 
-    (define (scan-file pathname original-pathname)
+    (define (scan-file cvs-mode? pathname original-pathname)
       (let ((attributes (file-attributes-direct pathname)))
 	(if (not attributes)
 	    (warn "Cannot get attributes.  Path might contain stale symlink."
@@ -180,48 +304,66 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		  pathname)
 	    (let ((type (file-attributes/type attributes)))
 	      (cond ((not type)
-		     (if (not (or (ignored-file-name? pathname)
-				  (ignored-file-name? original-pathname)))
-			 (let ((control (rcs-control-file pathname)))
-			   (if control
-			       (begin
-				 (set! files
-				       (cons (cons original-pathname control)
-					     files))
-				 unspecific)))))
+		     (if (not (or (ignored-file-name? cvs-mode? pathname)
+				  (ignored-file-name? cvs-mode?
+						      original-pathname)))
+			 (let ((file (rcs-files cvs-mode? pathname)))
+			   (if file
+			       (set! files (cons file files))))))
 		    ((eq? type #t)
 		     (if (not (member (file-namestring pathname)
-				      '("." ".." "RCS")))
-			 (scan-directory pathname original-pathname)))
+				      '("." ".." "CVS" "RCS")))
+			 (scan-directory cvs-mode?
+					 pathname original-pathname)))
 		    ((string? type)
-		     (scan-file (merge-pathnames type
+		     (scan-file cvs-mode?
+				(merge-pathnames type
 						 (directory-pathname pathname))
 				original-pathname)))))))
 
-    (define (rcs-control-file pathname)
+    (define (rcs-files cvs-mode? pathname)
       (let ((directory (directory-pathname pathname))
-	    (name (string-append (file-namestring pathname) ",v")))
-	(let ((p (merge-pathnames name (merge-pathnames "RCS/" directory))))
-	  (if (regular-file? p)
-	      p
-	      (let ((p (merge-pathnames name directory)))
-		(if (regular-file? p)
-		    p
-		    #f))))))
+	    (name (file-namestring pathname)))
+	(if cvs-mode?
+	    (and (string-suffix? ",v" name)
+		 (cons (merge-pathnames
+			(string-head name (- (string-length name) 2))
+			directory)
+		       pathname))
+	    (let* ((name (string-append name ",v"))
+		   (p
+		    (merge-pathnames name (merge-pathnames "RCS/" directory))))
+	      (if (regular-file? p)
+		  (cons pathname p)
+		  (let ((p (merge-pathnames name directory)))
+		    (and (regular-file? p)
+			 (cons pathname p))))))))
 
     (define (regular-file? pathname)
       (let ((attributes (file-attributes pathname)))
 	(and attributes
 	     (not (file-attributes/type attributes)))))
 
-    (define (ignored-file-name? pathname)
+    (define (ignored-file-name? cvs-mode? pathname)
       (let ((name (file-namestring pathname)))
-	(or (string-suffix? ",v" name)
-	    (string-suffix? "~" name)
-	    (string-prefix? "#" name))))
+	(or (string-suffix? "~" name)
+	    (string-prefix? "#" name)
+	    (and (not cvs-mode?) (string-suffix? ",v" name)))))
 
-    (scan-directory pathname pathname)
+    (let ((directory (pathname-as-directory pathname)))
+      (let ((cvs (merge-pathnames "CVS/" directory)))
+	(if (file-directory? cvs)
+	    (let ((pathname
+		   (merge-pathnames
+		    (read-one-line-file (merge-pathnames "Repository" cvs))
+		    (pathname-as-directory
+		     (read-one-line-file (merge-pathnames "Root" cvs))))))
+	      (scan-directory #t pathname pathname))
+	    (scan-directory #f pathname pathname))))
     files))
+
+(define (read-one-line-file pathname)
+  (call-with-input-file pathname read-line))
 
 (define (greatest-common-prefix pathnames)
   (if (null? pathnames)
@@ -233,12 +375,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 			    (if (eq? prefix 'NONE)
 				directory
 				(let common-prefix ((x prefix) (y directory))
-				  (if (or (null? x)
-					  (null? y)
-					  (not (equal? (car x) (car y))))
-				      '()
+				  (if (and (pair? x)
+					   (pair? y)
+					   (equal? (car x) (car y)))
 				      (cons (car x)
-					    (common-prefix (cdr x)
-							   (cdr y)))))))))
+					    (common-prefix (cdr x) (cdr y)))
+				      '()))))))
 		  pathnames)
 	(pathname-new-directory "" prefix))))
\ No newline at end of file
diff --git a/v7/src/rcs/object.scm b/v7/src/rcs/object.scm
index 41096460b..2ff94d7bc 100644
--- a/v7/src/rcs/object.scm
+++ b/v7/src/rcs/object.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: object.scm,v 1.3 1999/01/02 06:11:34 cph Exp $
+$Id: object.scm,v 1.4 2000/03/20 22:52:51 cph Exp $
 
-Copyright (c) 1988, 1991, 1999 Massachusetts Institute of Technology
+Copyright (c) 1988, 1991, 1999, 2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -61,50 +61,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (lambda (state delta)
       (unparse-string state (delta/number delta)))))
 
-(define (date/make year month day hour minute second)
-  (vector
-   year month day hour minute second
-   (+ second
-      (* 60
-	 (+ minute
-	    (* 60
-	       (+ hour
-		  (* 24
-		     (+ (-1+ day)
-			(vector-ref
-			 (if (zero? (remainder year 4))
-			     '#(0 31 60 91 121 152 182 213 244 274 305 335)
-			     '#(0 31 59 90 120 151 181 212 243 273 304 334))
-			 (-1+ month))
-			(* 365 year)
-			(quotient year 4))))))))))
+(define *date-rounds-to-day?* #f)
 
-(define-integrable (date/year date) (vector-ref date 0))
-(define-integrable (date/month date) (vector-ref date 1))
-(define-integrable (date/day date) (vector-ref date 2))
-(define-integrable (date/hour date) (vector-ref date 3))
-(define-integrable (date/minute date) (vector-ref date 4))
-(define-integrable (date/second date) (vector-ref date 5))
-(define-integrable (date/total-seconds date) (vector-ref date 6))
+(define (date/make year month day hour minute second)
+  (let ((year (if (< year 100) (+ 1900 year) year)))
+    (let ((dt (make-decoded-time second minute hour day month year 0)))
+      (cons dt
+	    (decoded-time->universal-time
+	     (if *date-rounds-to-day?*
+		 (make-decoded-time 0 0 0 day month year 0)
+		 dt))))))
 
-(define (date->string date)
-  (string-append (date-component->string (date/year date))
-		 "/"
-		 (date-component->string (date/month date))
-		 "/"
-		 (date-component->string (date/day date))
-		 " "
-		 (date-component->string (date/hour date))
-		 ":"
-		 (date-component->string (date/minute date))
-		 ":"
-		 (date-component->string (date/second date))
-		 " GMT"))
+(define-integrable (date/decoded date) (car date))
+(define-integrable (date/universal date) (cdr date))
 
-(define (date-component->string number)
-  (cond ((zero? number) "00")
-	((< number 10) (string-append "0" (write-to-string number)))
-	(else (write-to-string number))))
+(define-integrable (date->string date)
+  (decoded-time->string (date/decoded date)))
 
 (define-integrable (date<? x y)
-  (< (date/total-seconds x) (date/total-seconds y)))
\ No newline at end of file
+  (< (date/universal x) (date/universal y)))
\ No newline at end of file