← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/rcs/logmer.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rcs/logmer.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: logmer.scm,v 1.27 2000/08/20 04:08:56 cph Exp $
 
4
 
 
5
Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
|#
 
21
 
 
22
;;;; RCS Log Merge
 
23
 
 
24
(declare (usual-integrations))
 
25
 
 
26
(define (rcs-directory-log directory #!optional options)
 
27
  (let ((options (if (default-object? options) '() options))
 
28
        (port (notification-output-port)))
 
29
    (let ((changelog? (find-option options 'CHANGELOG? #f)))
 
30
      (let ((output-file
 
31
             (merge-pathnames (or (find-option options 'OUTPUT-FILE #f)
 
32
                                  (if changelog? "ChangeLog" "RCS.log"))
 
33
                              (pathname-as-directory directory))))
 
34
        (fresh-line port)
 
35
        (write-string "regenerating log for directory: " port)
 
36
        (write (->namestring directory))
 
37
        (write-string "..." port)
 
38
        (let ((pathnames (rcs-directory-read directory)))
 
39
          (if (let ((time (file-modification-time-indirect output-file)))
 
40
                (or (not time)
 
41
                    (there-exists? pathnames
 
42
                      (lambda (w.r)
 
43
                        (> (file-modification-time-indirect (cdr w.r))
 
44
                           time)))))
 
45
              (begin
 
46
                (newline port)
 
47
                (write-string "total files: " port)
 
48
                (write (length pathnames) port)
 
49
                (newline port)
 
50
                (let ((entries (read-entries pathnames port)))
 
51
                  (write-string "total entries: " port)
 
52
                  (write (length entries) port)
 
53
                  (newline port)
 
54
                  (let ((entries
 
55
                         (if changelog?
 
56
                             (sort-entries-for-changelog entries)
 
57
                             (sort-entries-for-rcs.log entries))))
 
58
                    (write-string "sorting finished" port)
 
59
                    (newline port)
 
60
                    (call-with-output-file output-file
 
61
                      (lambda (port)
 
62
                        (if changelog?
 
63
                            (format-changelog entries options port)
 
64
                            (format-rcs.log entries options port)))))))
 
65
              (begin
 
66
                (write-string " log is up to date" port)
 
67
                (newline port))))))))
 
68
 
 
69
(define (find-option options key default)
 
70
  (let loop ((options options))
 
71
    (if (pair? options)
 
72
        (if (eq? key (caar options))
 
73
            (cadar options)
 
74
            (loop (cdr options)))
 
75
        default)))
 
76
 
 
77
;;;; RCS.log format
 
78
 
 
79
(define (format-rcs.log entries options port)
 
80
  options
 
81
  (let ((groups (group-entries-by-log entries))
 
82
        (format-group
 
83
         (lambda (group)
 
84
           (for-each (lambda (entry)
 
85
                       (let ((delta (car entry))
 
86
                             (filename (cdr entry)))
 
87
                         (write-string "file: " port)
 
88
                         (write-string filename port)
 
89
                         (write-string ";  revision: " port)
 
90
                         (write-string (delta/number delta) port)
 
91
                         (write-string "\ndate: " port)
 
92
                         (write-string (date->string (delta/date delta)) port)
 
93
                         (write-string ";  author: " port)
 
94
                         (write-string (delta/author delta) port)
 
95
                         (newline port)))
 
96
                     group)
 
97
           (newline port)
 
98
           (write-string (delta/log (car (car group))) port)
 
99
           (newline port))))
 
100
    (if (pair? groups)
 
101
        (begin
 
102
          (format-group (car groups))
 
103
          (for-each (lambda (group)
 
104
                      (write-string "----------------------------" port)
 
105
                      (newline port)
 
106
                      (format-group group))
 
107
                    (cdr groups))))))
 
108
 
 
109
(define (sort-entries-for-rcs.log entries)
 
110
  (sort entries
 
111
    (lambda (x y)
 
112
      (date<? (delta/date (car y)) (delta/date (car x))))))
 
113
 
 
114
;;;; ChangeLog format
 
115
 
 
116
(define (format-changelog entries options port)
 
117
  (let ((groups
 
118
         (group-entries-by-author&day
 
119
          (list-transform-negative entries
 
120
            (lambda (entry)
 
121
              (string-prefix? "#" (delta/log (car entry))))))))
 
122
    (if (pair? groups)
 
123
        (let ((changelog-map
 
124
               (or (find-option options 'CHANGELOG-MAP #f)
 
125
                   (list (os/hostname)))))
 
126
          (format-changelog-group (car groups) changelog-map options port)
 
127
          (for-each (lambda (group)
 
128
                      (newline port)
 
129
                      (format-changelog-group group changelog-map options
 
130
                                              port))
 
131
                    (cdr groups))))))
 
132
 
 
133
(define (format-changelog-group entries changelog-map options port)
 
134
  (write-string (format-date-for-changelog (delta/date (caar entries))) port)
 
135
  (write-string "  " port)
 
136
  (let ((author (delta/author (caar entries))))
 
137
    (let ((mentry (assoc author (cdr changelog-map))))
 
138
      (write-string (if mentry (cadr mentry) author) port)
 
139
      (write-string " <" port)
 
140
      (if (and mentry (pair? (cddr mentry)))
 
141
          (write-string (caddr mentry) port)
 
142
          (begin
 
143
            (write-string author port)
 
144
            (write-string "@" port)
 
145
            (write-string (car changelog-map) port)))
 
146
      (write-string ">" port)))
 
147
  (newline port)
 
148
  (for-each
 
149
   (lambda (entries)
 
150
     (newline port)
 
151
     (write-char #\tab port)
 
152
     (write-string "* " port)
 
153
     (let ((filenames
 
154
            (if (find-option options 'SHOW-VERSIONS #t)
 
155
                (map (lambda (entry)
 
156
                       (string-append (cdr entry)
 
157
                                      "[" (delta/number (car entry)) "]"))
 
158
                     (sort-group-by-name&date entries))
 
159
                (remove-duplicate-strings (sort (map cdr entries) string<?)))))
 
160
       (write-string (car filenames) port)
 
161
       (let loop
 
162
           ((filenames (cdr filenames))
 
163
            (column (fix:+ 11 (string-length (car filenames)))))
 
164
         (if (pair? filenames)
 
165
             (let ((filename (car filenames)))
 
166
               (let ((column* (+ column 2 (string-length filename))))
 
167
                 (if (fix:>= column* 80)
 
168
                     (begin
 
169
                       (write-string "," port)
 
170
                       (newline port)
 
171
                       (write-char #\tab port)
 
172
                       (write-string "  " port)
 
173
                       (write-string filename port)
 
174
                       (loop (cdr filenames)
 
175
                             (fix:+ 11 (string-length filename))))
 
176
                     (begin
 
177
                       (write-string ", " port)
 
178
                       (write-string filename port)
 
179
                       (loop (cdr filenames) column*))))))))
 
180
     (write-string ":" port)
 
181
     (newline port)
 
182
     (format-log-for-changelog (delta/log (caar entries)) port))
 
183
   (sort-groups-by-date (group-entries-by-log entries))))
 
184
 
 
185
(define (sort-entries-for-changelog entries)
 
186
  (sort entries
 
187
    (lambda (x y)
 
188
      (or (day>? (delta/date (car x)) (delta/date (car y)))
 
189
          (and (day=? (delta/date (car x)) (delta/date (car y)))
 
190
               (or (string<? (delta/author (car x))
 
191
                             (delta/author (car y)))
 
192
                   (and (string=? (delta/author (car x))
 
193
                                  (delta/author (car y)))
 
194
                        (string<? (delta/log (car x))
 
195
                                  (delta/log (car y))))))))))
 
196
 
 
197
(define (sort-group-by-name&date entries)
 
198
  (sort entries
 
199
    (lambda (x y)
 
200
      (or (string<? (cdr x) (cdr y))
 
201
          (and (string=? (cdr x) (cdr y))
 
202
               (date>? (delta/date (car x)) (delta/date (car y))))))))
 
203
 
 
204
(define (format-date-for-changelog date)
 
205
  (let ((dt (date/decoded date)))
 
206
    (string-append
 
207
     (number->string (decoded-time/year dt))
 
208
     "-"
 
209
     (string-pad-left (number->string (decoded-time/month dt)) 2 #\0)
 
210
     "-"
 
211
     (string-pad-left (number->string (decoded-time/day dt)) 2 #\0))))
 
212
 
 
213
(define (format-log-for-changelog log port)
 
214
  (write-char #\tab port)
 
215
  (let ((end (string-length log)))
 
216
    (let loop ((start 0))
 
217
      (let ((index (substring-find-next-char log start end #\newline)))
 
218
        (if index
 
219
            (let ((index (fix:+ index 1)))
 
220
              (write-substring log start index port)
 
221
              (if (fix:< index end)
 
222
                  (begin
 
223
                    (write-char #\tab port)
 
224
                    (loop index))))
 
225
            (begin
 
226
              (write-substring log start end port)
 
227
              (newline port)))))))
 
228
 
 
229
(define (remove-duplicate-strings strings)
 
230
  ;; Assumes that STRINGS is sorted.
 
231
  (let loop ((strings strings) (result '()))
 
232
    (if (pair? strings)
 
233
        (loop (cdr strings)
 
234
              (if (and (pair? (cdr strings))
 
235
                       (string=? (car strings) (cadr strings)))
 
236
                  result
 
237
                  (cons (car strings) result)))
 
238
        (reverse! result))))
 
239
 
 
240
(define (sort-groups-by-date groups)
 
241
  (sort-groups groups
 
242
               (lambda (entries)
 
243
                 (let loop
 
244
                     ((entries (cdr entries))
 
245
                      (winner (caar entries)))
 
246
                   (if (pair? entries)
 
247
                       (loop (cdr entries)
 
248
                             (if (date<? (delta/date (caar entries))
 
249
                                         (delta/date winner))
 
250
                                 (caar entries)
 
251
                                 winner))
 
252
                       winner)))
 
253
               (lambda (x y)
 
254
                 (date>? (delta/date x) (delta/date y)))))
 
255
 
 
256
(define (sort-groups groups choose-representative predicate)
 
257
  (map cdr
 
258
       (sort (map (lambda (group)
 
259
                    (cons (choose-representative group) group))
 
260
                  groups)
 
261
         (lambda (x y)
 
262
           (predicate (car x) (car y))))))
 
263
 
 
264
(define (group-entries-by-author&day entries)
 
265
  (group-entries entries
 
266
    (lambda (x y)
 
267
      (and (string=? (delta/author (car x)) (delta/author (car y)))
 
268
           (day=? (delta/date (car x)) (delta/date (car y)))))))
 
269
 
 
270
(define (group-entries-by-log entries)
 
271
  (group-entries entries
 
272
    (lambda (x y)
 
273
      (string=? (delta/log (car x)) (delta/log (car y))))))
 
274
 
 
275
(define (group-entries entries predicate)
 
276
  (let outer ((entries entries) (groups '()))
 
277
    (if (pair? entries)
 
278
        (let ((entry (car entries)))
 
279
          (let inner ((entries (cdr entries)) (group (list entry)))
 
280
            (if (and (pair? entries)
 
281
                     (predicate entry (car entries)))
 
282
                (inner (cdr entries) (cons (car entries) group))
 
283
                (outer entries (cons (reverse! group) groups)))))
 
284
        (reverse! groups))))
 
285
 
 
286
(define (read-entries pairs notification-port)
 
287
  (let ((prefix (greatest-common-prefix (map car pairs))))
 
288
    (append-map!
 
289
     (lambda (w.r)
 
290
       (map (let ((filename (->namestring (enough-pathname (car w.r) prefix))))
 
291
              (lambda (delta)
 
292
                (cons delta filename)))
 
293
            (read-file (cdr w.r) notification-port)))
 
294
     pairs)))
 
295
 
 
296
(define (read-file pathname notification-port)
 
297
  (if notification-port
 
298
      (begin
 
299
        (write-string "read-file " notification-port)
 
300
        (write-string (->namestring pathname) notification-port)
 
301
        (newline notification-port)))
 
302
  (let ((deltas (rcstext->deltas (rcs/read-file pathname 'LOG-ONLY))))
 
303
    (for-each (lambda (delta)
 
304
                (set-delta/log! delta
 
305
                                (let ((log (string-trim (delta/log delta))))
 
306
                                  (if (string-null? log)
 
307
                                      empty-log-message
 
308
                                      log))))
 
309
              deltas)
 
310
    (list-transform-negative deltas delta/trivial-log?)))
 
311
 
 
312
(define (delta/trivial-log? delta)
 
313
  (string=? (delta/log delta) "Initial revision"))
 
314
 
 
315
(define empty-log-message "*** empty log message ***")
 
316
 
 
317
(define (rcstext->deltas rcstext)
 
318
  (let ((head (rcstext/head rcstext)))
 
319
    (if (not head)
 
320
        '()
 
321
        (let loop ((input (list head)) (output '()))
 
322
          (if (null? input)
 
323
              output
 
324
              (let ((input* (append (delta/branches (car input)) (cdr input))))
 
325
                (loop (if (delta/next (car input))
 
326
                          (cons (delta/next (car input)) input*)
 
327
                          input*)
 
328
                      (cons (car input) output))))))))
 
329
 
 
330
(define (rcs-directory-read pathname)
 
331
  (let ((files '()))
 
332
    (define (scan-directory cvs-mode? directory original-directory)
 
333
      (let ((directory (pathname-as-directory directory))
 
334
            (original-directory (pathname-as-directory original-directory)))
 
335
        (for-each (lambda (pathname)
 
336
                    (scan-file cvs-mode?
 
337
                               pathname
 
338
                               (merge-pathnames (file-pathname pathname)
 
339
                                                original-directory)))
 
340
                  (directory-read directory #f))))
 
341
 
 
342
    (define (scan-file cvs-mode? pathname original-pathname)
 
343
      (let ((attributes (file-attributes-direct pathname)))
 
344
        (if (not attributes)
 
345
            (warn "Cannot get attributes.  Path might contain stale symlink."
 
346
                  (error-irritant/noise "\n;   ")
 
347
                  original-pathname
 
348
                  (error-irritant/noise "\n; points to\n;   ")
 
349
                  pathname)
 
350
            (let ((type (file-attributes/type attributes)))
 
351
              (cond ((not type)
 
352
                     (if (not (or (ignored-file-name? cvs-mode? pathname)
 
353
                                  (ignored-file-name? cvs-mode?
 
354
                                                      original-pathname)))
 
355
                         (let ((file (rcs-files cvs-mode? pathname)))
 
356
                           (if file
 
357
                               (set! files (cons file files))))))
 
358
                    ((eq? type #t)
 
359
                     (if (not (member (file-namestring pathname)
 
360
                                      '("." ".." "CVS" "RCS")))
 
361
                         (scan-directory cvs-mode?
 
362
                                         pathname original-pathname)))
 
363
                    ((string? type)
 
364
                     (scan-file cvs-mode?
 
365
                                (merge-pathnames type
 
366
                                                 (directory-pathname pathname))
 
367
                                original-pathname)))))))
 
368
 
 
369
    (define (rcs-files cvs-mode? pathname)
 
370
      (let ((directory (directory-pathname pathname))
 
371
            (name (file-namestring pathname)))
 
372
        (if cvs-mode?
 
373
            (and (string-suffix? ",v" name)
 
374
                 (cons (merge-pathnames
 
375
                        (string-head name (- (string-length name) 2))
 
376
                        directory)
 
377
                       pathname))
 
378
            (let* ((name (string-append name ",v"))
 
379
                   (p
 
380
                    (merge-pathnames name (merge-pathnames "RCS/" directory))))
 
381
              (if (regular-file? p)
 
382
                  (cons pathname p)
 
383
                  (let ((p (merge-pathnames name directory)))
 
384
                    (and (regular-file? p)
 
385
                         (cons pathname p))))))))
 
386
 
 
387
    (define (regular-file? pathname)
 
388
      (let ((attributes (file-attributes pathname)))
 
389
        (and attributes
 
390
             (not (file-attributes/type attributes)))))
 
391
 
 
392
    (define (ignored-file-name? cvs-mode? pathname)
 
393
      (let ((name (file-namestring pathname)))
 
394
        (or (string-suffix? "~" name)
 
395
            (string-prefix? "#" name)
 
396
            (and (not cvs-mode?) (string-suffix? ",v" name)))))
 
397
 
 
398
    (let ((directory (pathname-as-directory pathname)))
 
399
      (let ((cvs (merge-pathnames "CVS/" directory)))
 
400
        (if (file-directory? cvs)
 
401
            (let ((pathname
 
402
                   (merge-pathnames
 
403
                    (read-one-line-file (merge-pathnames "Repository" cvs))
 
404
                    (pathname-as-directory
 
405
                     (strip-cvs-remote-prefix
 
406
                      (read-one-line-file (merge-pathnames "Root" cvs)))))))
 
407
              (scan-directory #t pathname pathname))
 
408
            (scan-directory #f pathname pathname))))
 
409
    files))
 
410
 
 
411
(define (strip-cvs-remote-prefix string)
 
412
  (let ((regs
 
413
         (re-string-match ":\\(\\(ext\\|.?server\\):[^:]+\\|local\\):"
 
414
                          string #t)))
 
415
    (if regs
 
416
        (string-tail string (re-match-end-index 0 regs))
 
417
        string)))
 
418
 
 
419
(define (read-one-line-file pathname)
 
420
  (call-with-input-file pathname read-line))
 
421
 
 
422
(define (greatest-common-prefix pathnames)
 
423
  (if (null? pathnames)
 
424
      (->pathname "")
 
425
      (let ((prefix 'NONE))
 
426
        (for-each (lambda (pathname)
 
427
                    (let ((directory (pathname-directory pathname)))
 
428
                      (set! prefix
 
429
                            (if (eq? prefix 'NONE)
 
430
                                directory
 
431
                                (let common-prefix ((x prefix) (y directory))
 
432
                                  (if (and (pair? x)
 
433
                                           (pair? y)
 
434
                                           (equal? (car x) (car y)))
 
435
                                      (cons (car x)
 
436
                                            (common-prefix (cdr x) (cdr y)))
 
437
                                      '()))))))
 
438
                  pathnames)
 
439
        (pathname-new-directory "" prefix))))
 
 
b'\\ No newline at end of file'