#| -*-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
(declare (usual-integrations))
\f
-(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))))))))
+\f
+;;;; 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))))))
+\f
+;;;; 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))))))
+\f
+(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)))))))
\f
-(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))))
(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
\f
(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."
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))
+\f
+(define (read-one-line-file pathname)
+ (call-with-input-file pathname read-line))
(define (greatest-common-prefix pathnames)
(if (null? pathnames)
(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
#| -*-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
(lambda (state delta)
(unparse-string state (delta/number delta)))))
\f
-(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
projects / mit-scheme.git / commitdiff