" cvs.scm " enumerate files under CVS control .
  Copyright 2002  
;
;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 " ) )


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.

in full.

this software will be error-free, and I am under no obligation to
provide any services, by way of maintenance, update, or otherwise.

material, there shall be no use of my name in any advertising,
promotional, or sales literature without prior written consent in
each case.
@body Returns a list of the local pathnames (with prefix @1) of all
subdirectories.

or @code{(getenv "CVSROOT")} if Root doesn't exist.
@body Returns the (string) contents of @var{directory/}CVS/Root appended
 or # f if @var{directory/}CVS / Repository
doesn't exist.
@body
@body
@body
subdirectory do not match.
" cvs.scm " enumerate files under CVS control .
  Copyright 2002  
1 .   Any copy made of this software must include this copyright notice
2 .   I have made no warranty or representation that the operation of
3 .   In conjunction with products arising from the use of this

(require 'scanf)
(require 'line-i/o)
(require 'string-search)

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
(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))

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

(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)))))))

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

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/)))

Signals an error if CVS / Repository or CVS / Root files in @1 or any
(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 " ) )
