#!/bin/sh
string=? ; exec mzscheme -l cmdline.ss -r $0 "$@"

(define PROG 'changecvsroot)

(define new-rp "/cvs")
(define new-host "anoncvs.plt-scheme.org") ; #f => remove any existing host spec
(define new-mode "pserver")
(define new-user "anonymous")
(define dir "plt")
(define prefix #f)

(define (check-format str what)
  ; Avoid disterous mistakes
  (let ([l (string->list str)])
    (when (or (memq #\: l)
	      (memq #\@ l))
      (error 'changecvsroot "bad ~a: ~a" what str))))

(parse-command-line
 (symbol->string PROG)
 argv
 `([once-each
    [("--host") 
     ,(lambda (_ host)
	(check-format host "host")
	(set! new-host host))
     (,(format "Set the host; default: ~a" new-host) "host")]
    [("--root") 
     ,(lambda (_ root) 
	(check-format root "root directory")
	(set! new-rp root))
     (,(format "Set the CVS root directory; default: ~a" new-rp) "dir")]
    [("--mode") 
     ,(lambda (_ mode) 
	(check-format mode "connection mode")
	(set! new-mode mode))
     (,(format "Set the CVS root directory; default: ~a" new-mode) "dir")]
    [("--user") 
     ,(lambda (_ user) 
	(check-format user "user")
	(set! new-user user))
     (,(format "Set the CVS user; default: ~a" (or new-user "<no change>")) "user")]
    [("++local")
     ,(lambda (_)
	(set! new-host #f)
	(set! new-mode #f))
     ("Remove :mode:user@host")]
    [("--dir")
     ,(lambda (_ d)
	(set! dir d))
     (,(format "Set the starting directory for conversion (sanity check convention); default: ~a" dir) "dir")]
    [("--prefix")
    ,(lambda (_ p)
       (set! prefix p))
    ("Set a CVS module path prefix and skip the sanity check; no trailing / in <path>" "path")]])
 (lambda (flags) (void))
 '())

; Strip trailing dir sperators on new-rp (just in case this script is modified)
(let loop ()
  (when (char=? #\/ (string-ref new-rp (sub1 (string-length new-rp))))
    (set! new-rp (substring new-rp 0 (sub1 (string-length new-rp))))
    (loop)))

(unless (directory-exists? dir)
  (error PROG "no ~s directory in the current directory; cd or use the --dir flag" dir))

(define re:colon (regexp "^(.*:)[^:]*$"))
(define re:at-colon (regexp "^(.*@)[^:]*(:.*)$"))
(define re:colon-and-at (regexp "^(:[^:]*:).*(@[^:]*:.*)$"))
(define re:colon-colon (regexp "^:[^:]*:(.*)$"))
(define re:served-root (regexp "^:[^:]*:[^:]*:[^:]*$"))
(define re:unserved-root (regexp "^[^:]*$"))

(define (build-unix-path b d)
  (string-append b "/" d))

(let loop ([d (build-path (current-directory) dir)][rd (if prefix (build-unix-path prefix dir) dir)])
  (let* ([cvs (build-path d "CVS")]
	 [root (build-path cvs "Root")]
	 [repository (build-path cvs "Repository")])
    (when (directory-exists? cvs)
      (printf "Changing ~a~n" cvs)
      (unless (file-exists? root)
	(error PROG "can't find ~a" root))
      (unless (file-exists? repository)
	(error PROG "can't find ~a" reposiory))
      (let ([read-one
	     (lambda (f)
	       (with-input-from-file f
		 (lambda ()
		   (let ([v (read-line)])
		     (when (eof-object? v)
		       (error PROG "can't read line from ~a" f))
		     (unless (eof-object? (read-char))
		       (error PROG "unexpected extra data in ~a" f))
		     v))
		 'text))]
	    [write-one
	     (lambda (f s)
	       (with-output-to-file f
		 (lambda ()
		   (printf "~a~n" s))
		 'truncate/replace 'text))]
	    [check-end
	     (lambda (got want where)
	       (let ([gl (string-length got)]
		     [wl (string-length want)])
		 (unless (and (>= gl wl)
			      (string=? want (substring got (- gl wl) gl)))
		   (error PROG "value ~s in ~s does not end with ~s as expected"
			  got where want))))]
	    [replace-after-colon
	     (lambda (s new)
	       (let ([m (regexp-match re:colon s)])
		 (if m
		     (string-append (cadr m) new)
		     new)))]
	    [replace-between-colon-and-at
	     (lambda (s new)
	       (if new
		   (let ([m (regexp-match re:colon-and-at s)])
		     (if m
			 (string-append (cadr m) new (caddr m))
			 s))
		   s))]
	    [replace-between-at-and-colon
	     (lambda (s new)
	       (let ([m (regexp-match re:at-colon s)])
		 (if m
		     (string-append (cadr m) new (caddr m))
		     s)))]
	    [replace-between-initial-colons
	     (lambda (s new)
	       (let ([m (regexp-match re:colon-colon s)])
		 (if m
		     (string-append ":" new ":" (cadr m))
		     s)))])
	(let ([rt (read-one root)]
	      [rp (read-one repository)])
	  (unless prefix
	    (check-end rp rd repository))
	  (write-one repository (build-unix-path new-rp rd))
	  (write-one root (cond
			   [(not new-host)
			    (let ([m (regexp-match re:served-root rt)])
			      (if m
				  new-rp
				  rt))]
			   [(regexp-match re:unserved-root rt)
			    (if new-user
				(format ":~a:~a@~a:~a"
					new-mode
					new-user
					new-host
					new-rp)
				(error 'changecvsroot "no server path to change: ~s for: ~s and no user specified"
				       rt
				       root))]
			   [else (replace-between-at-and-colon 
				  (replace-between-colon-and-at
				   (replace-after-colon 
				    (replace-between-initial-colons
				     rt 
				     new-mode)
				    new-rp)
				   new-user)
				  new-host)]))))
      (for-each
       (lambda (sd)
	 (let ([d2 (build-path d sd)])
	   (when (and (not (link-exists? d2))
		      (directory-exists? d2))
	     (loop d2 (build-unix-path rd sd)))))
       (directory-list d)))))