CVS script

[Jim Blandy <jimb@red-bean.com>]

I had a lot of fun writing this.  Many of these functions ought to be
library functions --- you shouldn't have to cons them up each time you
write a script --- but I guess the best way to design them (other than
stealing them from SCSH) is to write them up.

I like for-each-file: `find' in 21 lines.

The command-line processing still sucks.  Does anyone have good
argument-parsing code for Scheme?


#!/usr/local/bin/guile \
-e main -s
!#
;;;; change-cvsroot --- change the repository of a CVS working directory
;;;; Jim Blandy <jimb@red-bean.com> --- July 1998

;;; Usage: change-cvsroot WORKING-DIR NEW-ROOT [NEW-MODULE]
;;;
;;; Change the repository of the CVS working directory WORKING-DIR to
;;; NEW-ROOT.  This is useful if the repository has moved, and you
;;; have working directories containing uncommitted changes, or don't
;;; want to check the whole working directory out afresh.  This script
;;; edits the information in the `CVS' directories of WORKING-DIR.
;;;
;;; Note that the base revisions of the working files must be
;;; identical in the old and new repositories, or else chaos will
;;; result.  This command is really only useful after copying a
;;; repository; it is not useful for reconciling results between
;;; independent repositories of the same project.
;;;
;;; NEW-ROOT should be a CVS root specification; it may
;;; include a full access method, like this:
;;;     :ext:jimb@egcs.cygnus.com:/egcs/carton/cvsfiles
;;; 
;;; This command can also shift a working directory within a
;;; repository.  The optional third argument NEW-MODULE gives the
;;; relative directory within NEW-ROOT that WORKING-DIR should
;;; correspond to.  If omitted, the working directory's position
;;; within the repository is left unchanged.

(use-modules (ice-9 string-fun))


;;;; Utility functions, which should probably be in some library somewhere.

;;; Traverse the directory tree at ROOT, applying F to the name of
;;; each file in the tree, including ROOT itself.  For a subdirectory
;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
;;; symlinks.
(define (for-each-file f root)

  ;; A "hard directory" is a path that denotes a directory and is not a 
  ;; symlink.
  (define (file-is-hard-directory? filename)
    (eq? (stat:type (lstat filename)) 'directory))

  (let visit ((root root))
    (let ((should-recur (f root)))
      (if (and should-recur (file-is-hard-directory? root))
	  (let ((dir (opendir root)))
	    (let loop ()
	      (let ((entry (readdir dir)))
		(cond 
		 ((eof-object? entry) #f)
		 ((or (string=? entry ".")
		      (string=? entry ".."))
		  (loop))
		 (else
		  (visit (string-append root "/" entry))
		  (loop))))))))))

;;; Return the contents of FILE, as a string.
(define (file-contents file)
  (let* ((port (open-input-file file))
	 (contents (read-delimited "" port)))
    (close-port port)
    contents))

;;; Set the contents of FILE, in its entirety, to STRING.
(define (set-file-contents! file string)
  (let ((port (open-output-file file)))
    (display string port)
    (close-port port)
    #f))

(define (display-line . args)
  (for-each display args)
  (newline))


;;;; CVS helper functions


;;; Apply F to the name of each directory in the CVS working tree at
;;; WD.  This function does not apply F to the `CVS' directories,
;;; and does not recurse into directories that don't seem to be
;;; controlled by CVS (i.e., directories that lack CVS subdirs).
(define (for-each-cvs-directory f wd)

  (define (is-cvs-dir? dir)
    (let ((ctrl-dir (string-append dir "/CVS")))
      (and (file-exists? ctrl-dir)
	   (file-is-directory? ctrl-dir))))

  (for-each-file (lambda (file)
		   (and (is-cvs-dir? file)
			(begin (f file)
			       #t)))
		 wd))


;;; Make sure all CVS control files in the working tree WD are
;;; readable and writable.
(define (check-all-permissions wd)
  (for-each-cvs-directory
   (lambda (dir)
     (if (not (and (access? (string-append dir "/CVS/Root")
			    (logior R_OK W_OK))
		   (access? (string-append dir "/CVS/Repository")
			    (logior R_OK W_OK))))
	 (error "CVS control files not readable and writable:" dir)))
   wd))


;;; Split a CVS root into its access method and the repository path.
;;; (split-root ROOT string-append) => ROOT.
(define (split-root root k)
  (split-after-char-last #\: root k))


;;; Tail-call K with the root and module of the CVS working directory
;;; WD.  The module is the relative path from the repository root to
;;; the directory corresponding to WD.
(define (get-repository wd k)

  (define (ctrl part)
    (sans-surrounding-whitespace
     (file-contents (string-append wd "/CVS/" part))))

  ;; CVS stores the repository path as an absolute pathname, not
  ;; relative to the Root, so the local path to the repository appears
  ;; both in Root and Repository.  We want to cut out the duplicated
  ;; information, and just give the path of the repository directory
  ;; relative to the top of the repository.
  (let ((root (ctrl "Root"))
	(absolute-module (ctrl "Repository")))
    (split-root
     root
     (lambda (method repo)
       (let ((repo (string-append repo "/")))
	 (or (string-prefix=? repo absolute-module)
	     (error "error: Root and Repository files do not agree:" wd))
	 (k root (substring absolute-module (string-length repo))))))))


;;; Set the working directory WD to correspond to the subdirectory
;;; MODULE of the repository ROOT.  For example, 
;;; (set-repository! ":ext:you@host:/repository" "foo")
;;; would set WD to correspond to :ext:you@host:/repository/foo.
(define (set-repository! wd root module)
  
  (define (set-ctrl! file contents)
    (set-file-contents! (string-append wd "/CVS/" file)
			(string-append contents "\n")))

  (set-ctrl! "Root" root)
  (split-root root
	      (lambda (method repo)
		(set-ctrl! "Repository" (string-append repo "/" module)))))

;;; (display-line "Redefining set-repository!")
;;; (define (set-repository! wd root module)
;;;   (display-line "Changing repository: " wd)
;;;   (display-line "to " root " and " module))

;;; Change the CVS working directory CVS to use the new root ROOT.
;;; Also, if NEW-PREFIX is true and the directory within the
;;; repository used to be OLD-PREFIX/MUMBLE, change it to be
;;; NEW-PREFIX/MUMBLE.
(define (change-one-root cvs new-cvsroot old-prefix new-prefix)

  (define (change-prefix string old-prefix new-prefix)
    (if (string-prefix=? old-prefix string)
	(string-append new-prefix 
		       (substring string (string-length old-prefix)))
	string))

  (split-root
   new-cvsroot
   (lambda (new-method new-repo)
     (get-repository
      cvs
      (lambda (old-root old-module)

	;; Perhaps substitute the new module prefix for the old one.
	(let ((new-module
	       (if new-prefix (change-prefix old-module old-prefix new-prefix)
		   old-module)))

	  (set-repository! cvs new-cvsroot new-module)))))))

;;; Change the CVS files on the entire working tree WD to use NEW-ROOT.
(define (change-cvsroot wd new-root new-module)

  (check-all-permissions wd)

  (get-repository
   wd
   (lambda (root old-module)
     (for-each-cvs-directory
      (lambda (dir) (change-one-root dir new-root old-module new-module))
      wd))))


;;;; Entry point, and argument processing.

(define (main args)
  (let ((args (cdr args)))
    (or (= (length args) 2)
	(= (length args) 3)
	(error
	 "usage: change-cvsroot WORKING-DIR NEW-ROOT NEW-MODULE"))
    (let ((working-dir (car args))
	  (new-root (cadr args))
	  (new-module (if (= (length args) 3) (caddr args)
			#f)))
      (change-cvsroot working-dir new-root new-module))))