#!/bin/sh
exec ${GUILE-guile} -e "(ttn-do mmci)" -s $0 "$@" # -*- scheme -*-
!#
;;; mmci --- multi-method check-in

;; Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2009,
;;   2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: mmci --repo DIR [options] [NEWDIR]
;;
;; Abstract the "cvs add" procedure to also handle RCS files and
;; Emacs-style backup files.  Options is zero or more of:
;;
;;   -r, --repo RELDIR  NEWDIR/* should go into CVSROOT/RELDIR/*.
;;                      RELDIR can have multiple /-separated components.
;;                      This argument is required.
;;
;;   -n, --dry-run      Display commands mmci would do,
;;                      but don't actually do them.
;;
;;   -v, --verbose      Display commands as they are executed.
;;                      By default, mmci works quietly.
;;
;;   -d, --cvsroot DIR  Use DIR as CVSROOT.  If this is omitted, env
;;                      var CVSROOT must be set.  The CVSROOT must
;;                      point to a local dir (no ":" methods).
;;
;;   -x, --exclude RX   Ignore files that match regular expression RX.
;;                      Matching is done on the non-directory part of the
;;                      filename.  This option may be given multiple times.
;;
;;   -H, --symlinks-ok  Do not ignore symlinks.
;;
;; NEWDIR names a single relative directory of the current working
;; directory to be (recursively) processed.  If omitted, default is "."
;; (i.e., the current working directory).  Files already in CVS (as
;; evidenced by their name appearing in CVS/Entries) are ignored, as are
;; most files cvs normally ignores.  A notable exception is Emacs-style
;; backup files (foo, foo~, and foo.~N~), which are checked in with
;; successive revisions based on the files' mtimes.  Files under RCS
;; control (RCS/*,v) are copied directly.  New files are checked into
;; RCS temporarily and processed as such.
;;
;; Typically, you would use mmci like so:
;;
;;   mmci -n -r my-module/stuff stuff     # dry run ("would-do ...")
;;   mmci -v -r my-module/stuff stuff     # do it, verbosely
;;   mv stuff stuff.orig
;;   cvs co -d stuff my-module/stuff      # inspect for errors
;;   rm -rf stuff.orig
;;
;; Note that mmci will create directory ‘my-module/stuff’ for you.
;;
;; Although mmci tries not to disturb the original working directory,
;; for new files, the permissions may sometimes end up read-only.
;; It's a good idea to take a snapshot of the directory first.
;;
;;
;; Builtin Exclusions
;; ------------------
;; Here is the list of all the built-in regexps.  They were snarfed
;; from CVS info page and converted to Guile's regexp syntax, with
;; these removed removed: "*~", "core", "RCS" and "CVS"; and these
;; added: "*.lo" and ".deps".
;;
;; ^SCCS$
;; ^CVS.adm$
;; ^RCSLOG$
;; ^tags$
;; ^TAGS$
;; ^\.deps$
;; ^\.nse_depinfo$
;; ^\.make\.state$
;; .*\.old$
;; .*\.bak$
;; .*\.BAK$
;; .*\.orig$
;; .*\.rej$
;; .*\.a$
;; .*\.olb$
;; .*\.o$
;; .*\.obj$
;; .*\.so$
;; .*\.exe$
;; .*\.Z$
;; .*\.elc$
;; .*\.ln$
;; ^#.*
;; ^\.#.*
;; ^,.*
;; ^_\$.*
;; ^\.del-.*
;; ^cvslog\..*
;; .*\$$
;;
;; At this time, there is no way (aside from modifying the source code)
;; to reduce this list.  The ‘--exclude’ option appends to it.

;;; Code:

(define-module (ttn-do mmci)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz filesystem)
                #:select (directory-vicinity
                          (dir-exists? . directory-exists?)))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE HFE fs fso fse))
  #:use-module ((srfi srfi-13) #:select (string-tokenize
                                         substring/shared
                                         string-take
                                         string-prefix?))
  #:use-module ((srfi srfi-14) #:select (char-set-complement
                                         char-set))
  #:use-module ((ice-9 common-list) #:select (some
                                              find-if
                                              pick))
  #:use-module ((ice-9 and-let-star) #:select (and-let*))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module ((ice-9 ftw) #:select (nftw))
  #:use-module ((ice-9 regex) #:select (match:prefix
                                        match:substring)))

(define *myname* "mmci:")

(define (mmci-error fstr . args)
  (fse "~A " *myname*)
  (apply fse fstr args)
  (fse "~%")
  (error *myname* 'terminating))

;; configuration

(define CVSROOT #f)
(define under-CVSROOT #f)
(define (validate-CVSROOT!)
  (or (string? CVSROOT)
      (mmci-error "env var CVSROOT not set"))
  (and (member #\: (string->list CVSROOT))
       (mmci-error "sorry, remote CVSROOT ~A not (yet?) supported" CVSROOT)))

(define *repo* #f)
(define under-*repo* #f)
(define *dry-run* #f)
(define *verbose* #f)

(define repo-rel #f)                    ; init w/ make-repo-rel

(define (make-repo-rel newdir)
  (let ((len (string-length newdir))
        (sub substring/shared))
    (lambda (stem)
      (let ((stem-len (string-length stem)))
        (or (string-prefix? newdir stem)
            (mmci-error "newdir ~S but stem is only ~S" newdir stem))
        (under-CVSROOT (if (= len stem-len)
                           *repo*
                           (under-*repo* (sub stem (1+ len)))))))))

(define (sys! . args)
  ;; all filesystem modifications must go through this proc
  (let ((cmd (apply fs (apply string-append
                              "~A"
                              (make-list (1- (length args)) " ~A"))
                    args)))
    (or (and *dry-run* (fso "would-do: ~A\n" cmd))
        (let* ((default! (lambda ()
                           (system (string-append
                                    cmd
                                    (if *verbose* "" " >/dev/null 2>&1")))))
               (split-again (string-tokenize cmd (char-set-complement
                                                  (char-set #\space))))
               (handle-2 (if (= 3 (length split-again))
                             (lambda (proc)
                               (apply proc (cdr split-again)))
                             (lambda (x) (default!)))))
          (and *verbose* (fso "doing: ~A\n" cmd))
          (case (string->symbol (car split-again)) ; todo: tabulate
            ((cp) (handle-2 copy-file))
            ((mv) (handle-2 rename-file))
            ((rm) (delete-file (cadr split-again)))
            ((rmdir) (rmdir (cadr split-again)))
            ((mkdir) (mkdir (cadr split-again)))
            ((cd) (chdir (cadr split-again)))
            ((utime) (apply utime (cdr args)))
            (else (default!)))))))

;; file properties

(define (make-string-property)
  (let ((ht (make-hash-table)))
    (make-procedure-with-setter
     (lambda (s)     (hash-ref  ht s #f))
     (lambda (s val) (hash-set! ht s val)))))

(define f:vc       (make-string-property))
(define f:mtime    (make-string-property))
(define f:perms    (make-string-property))
(define f:data     (make-string-property))
(define f:entries  (make-string-property))

(define (additional-ignored-regexps) '())

(define (default-ignored-regexps)
  ;; snarfed from CVS info page, but w/ these removed:
  ;;  *~  core  RCS  CVS
  ;; and these added:
  ;;  *.lo  .deps
  (define (expand pattern ls)
    (map (lambda (x)
           (fs pattern x))
         ls))
  (append
   (expand "^~A$" '(SCCS CVS.adm RCSLOG tags TAGS
                         "\\.deps" "\\.nse_depinfo" "\\.make\\.state"))
   (expand ".*\\.~A$" '(old bak BAK orig rej a olb o obj so exe Z elc ln))
   (expand "^~A.*" '("#" "\\.#" "," "_\\$" "\\.del-" "cvslog\\."))
   (expand ".*~A$" '("\\$"))))

(define (make-ignore? symlinks-ok? regexps)
  (let ((ignored (map make-regexp regexps))
        (chksym (if symlinks-ok?
                    (lambda (filename) #f)
                    (lambda (filename)
                      (and (file-exists? filename)
                           (eq? 'symlink (stat:type (lstat filename))))))))
    ;; rv
    (lambda (filename)
      (or (chksym filename)
          (let ((base (basename filename)))
            (some (lambda (rx) (regexp-exec rx base)) ignored))))))

(define ignore? #f)

(define (tree-subdir-extract! rx tree)
  (and=> (find-if (lambda (elem)
                    (and (list? elem)
                         (regexp-exec rx (car elem))))
                  tree)
         (lambda (found)
           ;; Generally, we want to keep the ‘delq!’ return value, but
           ;; here the first element of ‘tree’ is the always parent dir
           ;; name (which should never be "found") effectively making
           ;; ‘tree’ a box, so this destructive operation is guaranteed
           ;; to DTRT, i.e., modify the shared structure by side-effect
           ;; for the caller's benefit.
           (delq! found tree)
           found)))

(define emacs-backup-base
  (let ((backup-ext-re (make-regexp "(~|(\\.~[0-9]+~))$")))
    (lambda (name)
      (let ((m (regexp-exec backup-ext-re name)))
        (and m (match:prefix m))))))

(define CVS-subdir-rx (make-regexp "/CVS$"))
(define RCS-subdir-rx (make-regexp "/RCS$"))

(define (canonicalize! tree)
  (or (list? tree)
      (mmci-error "bad tree: ~S" tree))
  (let ((cvs (and-let* ((d (tree-subdir-extract! CVS-subdir-rx tree)))
               (f:entries (car d))))
        (rcs (and-let* ((d (tree-subdir-extract! RCS-subdir-rx tree))
                        (gap-start (string-length (car tree)))
                        (gap-end (+ 4 gap-start)))
               (map (lambda (comma-v)
                      (string-append
                       (string-take comma-v gap-start)
                       (substring comma-v gap-end
                                  (- (string-length comma-v) 2))))
                    (cdr d))))
        (emacs-bases (make-hash-table 31))
        (ret '()))
    (FE tree (lambda (f)
               (cond ((list? f)
                      (let ((base (basename (car f))))
                        (or (ignore? base)
                            (let ((sub-canon (canonicalize! f)))
                              (or (equal? '() sub-canon)
                                  (set! ret (cons sub-canon ret)))))))
                     ((ignore? f))
                     ((emacs-backup-base f)
                      => (lambda (eb)
                           (hash-set! emacs-bases eb
                                      (cons f (or (hash-ref emacs-bases eb)
                                                  '())))))
                     ((and rcs (member f rcs))
                      (set! rcs (delete! f rcs))
                      (set! (f:vc f) handle-rcs)
                      (set! ret (cons f ret)))
                     ((and cvs (member f cvs))
                      (set! cvs (delete! f cvs))
                      (set! (f:vc f) handle-cvs)
                      (set! ret (cons f ret)))
                     (else
                      (set! (f:vc f) handle-new)
                      (set! ret (cons f ret))))))
    (HFE (eb kids emacs-bases)
      (and=> (and=> (member eb ret) car)
             (lambda (orig)
               (set! ret (delete orig ret))
               (set! kids (cons orig kids))))
      (set! (f:vc eb) handle-emacs)
      (set! (f:data eb) kids)
      (set! ret (cons eb ret)))
    (and rcs (FE rcs (lambda (unkept-rcs-f)
                       (set! (f:vc unkept-rcs-f) handle-rcs)
                       (set! ret (cons unkept-rcs-f ret)))))
    (set-cdr! tree ret))
  tree)

(define mkdir-p
  (let ((cache '()))
    (define (cache? filename)
      (member filename cache))
    (define (cache! filename)
      (set! cache (cons filename cache)))
    (define (dir-exists? filename)
      (or (cache? filename)
          (let ((answer (directory-exists? filename)))
            (and answer (cache! filename))
            answer)))
    ;; rv
    (lambda (dir)
      (let ((parent (dirname dir)))
        (or (dir-exists? parent)
            (mkdir-p parent)))
      (cond ((dir-exists? dir))
            (else (sys! "mkdir" dir)
                  (and *dry-run* (cache! dir)))))))

(define-macro (with-cwd dir . body)
  `(let ((cur (getcwd)))
     (sys! "cd" ,dir)
     ,@body
     (sys! "cd" cur)))

(define (make-comma-v name)
  (fs "~A,v" name))

(define (cvs-dir-entries cvs-dir)
  (let* ((entries-file (in-vicinity cvs-dir "Entries"))
         (p (if (file-exists? entries-file)
                (open-input-file entries-file)
                (error "CVS dir ‘%s’ has no Entries file!" cvs-dir)))
         (re (make-regexp "^/([^/]+)/" (logior regexp/icase
                                               regexp/newline)))
         (acc (accumulator)))
    (let loop ((line (read-line p)))
      (or (eof-object? line)
          (cond ((regexp-exec re line 0)
                 => (lambda (m)
                      (acc (match:substring m 1))
                      (loop (read-line p))))
                (else (loop (read-line p))))))
    (close-port p)
    (acc)))

(define under-RCS (directory-vicinity "RCS"))

(define (handle-rcs file)
  (let* ((dir (dirname file))
         (pre-made (make-comma-v (in-vicinity
                                  dir (under-RCS
                                       (basename file))))))
    (and *verbose* (fso "RCS: ~A\n" file))
    (and (eq? 'directory-processed (f:data file))
         (error "not a file (actually a directory):" file))
    ;; rv
    (lambda ()
      (or (file-exists? pre-made)
          (error "expected file does not exist:" pre-made))
      (mkdir-p (repo-rel dir))
      (sys! "cp" pre-made (repo-rel (make-comma-v file))))))

(define (handle-cvs file)
  (and *verbose* (fso "CVS: ~A\n" file))
  ;; rv
  (lambda () #t))

(define (handle-emacs file)
  (let* ((local-tmp-dir ".mmci")
         (base (in-vicinity local-tmp-dir (basename file)))
         (comma-v (make-comma-v base))
         (dir (dirname file)))
    (and *verbose* (fso "EMACS: emacs ~A\n" file))
    ;; rv
    (lambda ()
      (with-cwd dir
        (mkdir-p local-tmp-dir)
        (sys! "chmod 700" local-tmp-dir)
        (sys! "rcs -i -t-no-description" comma-v)
        (sys! "co -l -f" base comma-v)
        (FE (sort (f:data file)
                  (lambda (f1 f2)
                    (< (f:mtime f1) (f:mtime f2))))
            (lambda (twiddle)
              (let ((twiddle-base (basename twiddle)))
                (sys! "cp" twiddle-base base)
                (sys! "ci -l" (fs "-m'Originally ~S.'" twiddle-base)
                      base comma-v))))
        (sys! "ci -r" base comma-v)
        (sys! "cp" comma-v (repo-rel (make-comma-v file)))
        (sys! "rm" comma-v)
        (sys! "rmdir" local-tmp-dir)))))

(define (handle-new file)
  (let* ((dir? (eq? 'directory-processed (f:data file)))
         (rfull (repo-rel file)))
    (and *verbose* (fso "~A: ~A\n" (if dir? "NEWDIR" "NEW") file))
    (if dir?
        ;; rv for directory
        (lambda ()
          (mkdir-p rfull)
          (sys! "ls -ld" rfull))
        (let ((base (basename file))
              (dest (make-comma-v rfull))
              (orig-perms (f:perms file)))
          ;; rv for non-directory
          (lambda ()
            (with-cwd (dirname file)
              (mkdir-p (dirname dest))
              (sys! "rcs -i -t-no-description" base dest)
              (sys! "ci -u -m'Initial revision'" base dest)
              ;; restore any previous ugo+w permission
              (or (zero? (logand #o222 orig-perms))
                  (sys! "chmod" (number->string orig-perms 8) base))))))))

(define (figure-out-what-to-do tree)
  (let ((acc (accumulator)))
    (define (figure-action! file)
      (let ((vc (f:vc file)))
        (and (eq? handle-rcs vc)
             (or (f:mtime file)
                 (let ((pre-made (make-comma-v file)))
                   (fso "~A ~A: ~A ~A ~A ~A ~A ~A\n"
                        *myname* "WARNING"
                        pre-made "exists, but"
                        file "does not -- we will check in"
                        pre-made "anyway"))))
        (acc (vc file))))
    (define (process! tree)
      (let ((subs (pick list? tree))
            (files (pick string? (cdr tree))))
        (FE files figure-action!)
        (FE subs process!)
        ;; restore directory mtime
        (let* ((dir (car tree))
               (mt (f:mtime dir)))
          (acc (lambda ()
                 (let ((s (stat dir)))
                   (or (= mt (stat:mtime s))
                       (sys! "utime" dir (stat:atime s) mt))))))))
    (process! tree)
    (acc)))

(define (filesystem-tree->list filename node-proc . control-flags)

  (define (dfs-collect-proc last-one)
    (let ((dir (make-object-property))
          (ans '()))
      (define (zop obj) (set! (dir obj) #f) obj)
      (lambda (name statinfo flag base level)
        (let ((n (node-proc name statinfo flag base level)))
          (set! ans (cons n ans))
          (set! (dir ans) (string-take name base))
          (case flag
            ((directory-processed)
             (let ((as-parent (string-append name "/")))
               (let loop ((ls (cdr ans)) (in '()))
                 (if (or (null? ls)
                         (not (string=? (dir ls) as-parent)))
                     (let ((new (cons (cons n in) ls)))
                       (set! (dir new) (dir ans))
                       (set! ans new))
                     (loop (cdr ls) (cons (car (zop ls)) in)))))
             (if (= last-one (stat:ino statinfo))
                 (zop (car ans))
                 #t))
            (else
             #t))))))

  (apply nftw filename
         (let ((statinfo (stat filename)))
           (if (eq? 'directory (stat:type statinfo))
               (dfs-collect-proc (stat:ino statinfo))
               node-proc))
         'depth                         ; the d in "dfs-collect-proc"
         control-flags))

(define (mmci/qop qop)
  (set! ignore? (make-ignore? (qop 'symlinks-ok)
                              (append (default-ignored-regexps)
                                      (or (qop 'exclude) '()))))
  (set! CVSROOT (or (qop 'cvsroot) (getenv "CVSROOT")))
  (validate-CVSROOT!)
  (set! under-CVSROOT (directory-vicinity CVSROOT))
  (set! *repo* (qop 'repo))
  (set! under-*repo* (directory-vicinity *repo*))
  (set! *dry-run* (qop 'dry-run))
  (set! *verbose* (qop 'verbose))
  (let* ((rest (qop '()))
         (source-topdir (if (null? rest) "." (car rest)))
         (tree (filesystem-tree->list
                source-topdir
                (lambda (n s f b l)
                  (let ((r n))          ; todo (maybe): use string->symbol
                    (set! (f:data r) f)
                    (set! (f:mtime r) (stat:mtime s))
                    (set! (f:perms r) (stat:perms s))
                    (and (string=? "CVS" (basename r))
                         (set! (f:entries r) (cvs-dir-entries n)))
                    r)))))
    (set! repo-rel (make-repo-rel source-topdir))
    (canonicalize! tree)
    (FE (figure-out-what-to-do tree) (lambda (thunk) (thunk))))
  #t)

(define (main args)
  (check-hv args '((package . "ttn-do")
                   ;; 1.2.0 -- from standalone package MMCI
                   (version . "1.2.0")
                   (help . commentary)))
  (mmci/qop
   (qop<-args
    args '((cvsroot  (single-char #\d) (value #t))
           (repo     (single-char #\r) (value #t) (required? #t))
           (dry-run  (single-char #\n))
           (verbose  (single-char #\v))
           (exclude  (single-char #\x) (value #t) (merge-multiple? #t))
           (symlinks-ok (single-char #\H))))))

;;; mmci ends here