;;;;"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"))