summaryrefslogtreecommitdiffstats
path: root/cvs.scm
diff options
context:
space:
mode:
Diffstat (limited to 'cvs.scm')
-rw-r--r--cvs.scm140
1 files changed, 140 insertions, 0 deletions
diff --git a/cvs.scm b/cvs.scm
new file mode 100644
index 0000000..f1c853c
--- /dev/null
+++ b/cvs.scm
@@ -0,0 +1,140 @@
+;;;;"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 and all its subdirectories.
+(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
+;;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"))