/usr/share/slib/cvs.scm is in slib 3b1-3.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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"))
|