1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
;;;;"cvs.scm" enumerate files under CVS control.
;;; Copyright 2002 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'scanf)
(require 'line-i/o)
(require 'string-search)
;;@body Returns a list of the local pathnames (with prefix @1) of all
;;CVS controlled files in @1 and in @1's subdirectories.
(define (cvs-files directory/)
(cvs:entries directory/ #t))
;;@body Returns a list of all of @1 and all @1's CVS controlled
;;subdirectories.
(define (cvs-directories directory/)
(and (file-exists? (in-vicinity directory/ "CVS/Entries"))
(cons directory/ (cvs:entries directory/ #f))))
(define (cvs:entries directory do-files?)
(define files '())
(define cvse (in-vicinity directory "CVS/Entries"))
(define cvsel (in-vicinity directory "CVS/Entries.Log"))
(set! directory (substring directory
(if (eqv? 0 (substring? "./" directory)) 2 0)
(string-length directory)))
(if (file-exists? cvse)
(call-with-input-file cvse
(lambda (port)
(do ((line (read-line port) (read-line port)))
((eof-object? line))
(let ((fname #f))
(cond ((eqv? 1 (sscanf line "/%[^/]" fname))
(and do-files?
(set! files
(cons (in-vicinity directory fname) files))))
((eqv? 1 (sscanf line "D/%[^/]" fname))
(set! files
(append (cvs:entries (sub-vicinity directory fname)
do-files?)
(if do-files? '()
(list (sub-vicinity directory fname)))
files))))))))
(slib:warn 'cvs:entries 'missing cvse))
(set! files (reverse files))
(if (file-exists? cvsel)
(call-with-input-file cvsel
(lambda (port)
(do ((line (read-line port) (read-line port)))
((eof-object? line) files)
(let ((fname #f))
(cond ((eqv? 1 (sscanf line "A D/%[^/]/" fname))
(set! files
(append files
(if do-files? '()
(list (sub-vicinity directory fname)))
(cvs:entries (sub-vicinity directory fname)
do-files?)))))))))
files))
;;@body Returns the (string) contents of @var{path/}CVS/Root;
;;or @code{(getenv "CVSROOT")} if Root doesn't exist.
(define (cvs-root path/)
(if (not (vicinity:suffix? (string-ref path/ (+ -1 (string-length path/)))))
(slib:error 'missing 'vicinity-suffix path/))
(let ((rootpath (string-append path/ "CVS/Root")))
(if (file-exists? rootpath)
(call-with-input-file rootpath read-line)
(getenv "CVSROOT"))))
;;@body Returns the (string) contents of @var{directory/}CVS/Root appended
;;with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository
;;doesn't exist.
(define (cvs-repository directory/)
(let ((root (cvs-root directory/))
(repath (in-vicinity (sub-vicinity directory/ "CVS/") "Repository")))
(define root/idx (substring? "/" root))
(define rootlen (string-length root))
(and
root/idx
(file-exists? repath)
(let ((repos (call-with-input-file repath read-line)))
(define replen (and (string? repos) (string-length repos)))
(cond ((not (and replen (< 1 replen))) #f)
((not (char=? #\/ (string-ref repos 0)))
(string-append root "/" repos))
((eqv? 0 (substring? (substring root root/idx rootlen) repos))
(string-append
root
(substring repos (- rootlen root/idx) replen)))
(else (slib:error 'mismatched root repos)))))))
;;@body
;;Writes @1 to file CVS/Root of @2.
(define (cvs-set-root! new-root directory/)
(define root (cvs-root directory/))
(define repos (cvs-repository directory/))
(if (not repos) (slib:error 'not 'cvs directory/))
(if (not (eqv? 0 (substring? root repos)))
(slib:error 'bad 'cvs root repos))
(call-with-output-file
(in-vicinity (sub-vicinity directory/ "CVS") "Root")
(lambda (port) (write-line new-root port)))
(call-with-output-file
(in-vicinity (sub-vicinity directory/ "CVS") "Repository")
(lambda (port)
(write-line
(substring repos (+ 1 (string-length root)) (string-length repos))
port))))
;;@body
;;Writes @1 to file CVS/Root of @2 and all its CVS subdirectories.
(define (cvs-set-roots! new-root directory/)
(for-each (lambda (dir/) (cvs-set-root! new-root dir/))
(cvs-directories directory/)))
;;@body
;;Signals an error if CVS/Repository or CVS/Root files in @1 or any
;;subdirectory do not match.
(define (cvs-vet directory/)
(define diroot (cvs-root directory/))
(for-each
(lambda (path/)
(define path/CVS (sub-vicinity path/ "CVS/"))
(cond ((not (cvs-repository path/))
(slib:error 'bad (in-vicinity path/CVS "Repository")))
((not (equal? diroot (cvs-root path/)))
(slib:error 'mismatched 'root (in-vicinity path/CVS "Root")))))
(or (cvs-directories directory/) (slib:error 'not 'cvs directory/))))
;;(define cvs-rsh (or (getenv "CVS_RSH") "rsh"))
|
