;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          main.lisp
;;;; Purpose:       Main functions for vcs-tree
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Sep 2003
;;;;
;;;; Process all subdirectories that are managed by either CVS or SVN
;;;;
;;;; $Id$
;;;; *************************************************************************


(in-package vcs-tree)

(defun is-vcs-directory (x)
  (and (pathnamep x)
       (or
        (string= "CVS"
                 (car (last (pathname-directory x))))
        (string= ".svn"
                 (car (last (pathname-directory x))))
        (string= ".git"
                 (car (last (pathname-directory x)))))))

(defun is-cvs-managed (dir)
  (probe-directory (merge-pathnames
                    (make-pathname :directory '(:relative "CVS"))
                    dir)))

(defun is-svn-managed (dir)
  (probe-directory (merge-pathnames
                    (make-pathname :directory '(:relative ".svn"))
                    dir)))

(defun is-git-managed (dir)
  (probe-directory (merge-pathnames
                    (make-pathname :directory '(:relative ".git"))
                    dir)))

(defun filter-tree (tree)
  "Called for a directory tree. First argument is name of current tree.
Returns a list of directories managed by CVS, SVN, or GIT."
  (when (and (listp tree) (not (is-vcs-directory (car tree))))
    (let* ((managed-pair
            (cond
             ((find ".svn" (cdr tree)
                    :key (lambda (x) (when (pathnamep (car x))
                                       (car (last (pathname-directory (car x))))))
                    :test 'equal)
              (cons (car tree) :svn))
             ((find ".git" (cdr tree)
                    :key (lambda (x) (when (pathnamep (car x))
                                       (car (last (pathname-directory (car x))))))
                    :test 'equal)
              (cons (car tree) :git))
             ((find "CVS" (cdr tree)
                    :key (lambda (x) (when (pathnamep (car x))
                                       (car (last (pathname-directory (car x))))))
                    :test 'equal)
              (cons (car tree) :cvs))))
           (managed (car managed-pair))
           (type (cdr managed-pair)))
      (let ((vcs-removed
             (do* ((pos (cdr tree) (cdr pos))
                   (curr (car pos) (car pos))
                   (res nil))
                 ((null pos) (nreverse res))
               (when (and (not (is-vcs-directory (car curr)))
                          (or (not managed)
                              (not (is-managed-dir (car curr) managed type))))
                 (push curr res)))))
        (if vcs-removed
            (if managed
                (cons managed (flatten
                               (delete-if #'null
                                          (mapcar 'filter-tree vcs-removed))))
              (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
          managed))
      )))

(defun is-managed-dir (subdir dir type)
  (let* ((entries-path
          (merge-pathnames
           (ecase type
             (:svn
              (make-pathname :name "entries" :type nil
                             :directory '(:relative ".svn")))
             (:git
              (make-pathname :name "HEAD" :type nil
                             :directory '(:relative ".git")))
             (:cvs
              (make-pathname :name "Entries" :type nil
                             :directory '(:relative "CVS"))))
           dir))
         (entries (read-file-to-strings entries-path))
         (dir-name (car (last (pathname-directory subdir))))
         (match (case type
                  ((:svn :git)
                   (concatenate 'string "name=\"" dir-name "\""))
                  (:cvs
                   (concatenate 'string "D/" dir-name "////")))))
    (case type
      ((:svn :git)
       (some (lambda (line) (string= match (string-trim-whitespace line)))
             entries))
      (:cvs
       (or
        (some (lambda (line) (string= match (string-trim-whitespace line)))
              entries)
        (is-cvs-managed subdir))))))


(defun process-vcs-directory (dir action options)
  (flet ((process (dir type-name)
           (let* ((vcs-cmd
                   (ecase action
                     (:update
                      (cond
                        ((equal type-name "git")
                         (format nil "~A pull" type-name))
                        (t
                         (format nil "~A update" type-name))))
                     (:status
                      (format nil "~A status" type-name))
                     (:commit
                      (format nil "~A commit~A" type-name
                              (aif (find "m" options :key #'car :test 'string=)
                                   (format nil " -m \"~A\"" (cdr it))
                                   "")))))
                  (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
             (format t "~A ~A:~%" vcs-cmd (namestring dir))
             (multiple-value-bind (output error status)
                 (shell-command-output cmd :directory dir :whole t)
               (if (zerop status)
                   (format t "~A~%" output)
                   (format t "Exit status ~D: ~A ~A~%" status output error))))))
    (cond
      ((is-cvs-managed dir)
       (process dir "cvs"))
     ((is-svn-managed dir)
      (process dir "svn"))
     ((is-git-managed dir)
      (process dir "git"))
     (t
      (format *error-output*
              "INTERAL ERROR: not a version control system directory ~A" dir)
      (quit 1)))))

(defvar *progname* "")

(defun usage (&optional msg &rest msg-args)
  (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
  (if msg
      (progn
        (apply #'format *error-output* msg msg-args)
        (write-char #\Newline *error-output*))
      (format *error-output*
              "Processes a source-control managed directory tree~%"))
  (format *error-output* "Action: update, commit, or status~%")
  (format *error-output* "OPTIONS~%")
  (format *error-output* "   -m <str>    Set commit string~%"))

(defun parse-action-arg (arg)
  (cond
    ((string= arg "ci")
     :commit)
    (t
     (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
       (cond
         ((eql pos 0) :update)
         ((eql pos 1) :commit)
         ((eql pos 2) :status)
         (t
          (usage "Unknown action: ~A" arg)
          (quit 1)))))))


(defun main (&optional (argv (command-line-arguments)))
  (let ((*progname* (car argv)))
    (multiple-value-bind (args options errors)
        (getopt (cdr argv) '(("m" :required)))
      (when (or errors (/= 1 (length args)))
        (usage)
        (quit 1))
      (let ((action (parse-action-arg (first args))))
        (unless action
          (usage "Invalid action ~A" (first args))
          (quit 1))
        (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
          (process-vcs-directory dir action options))))
    (quit 0)))

;;(main)
;;(quit 0)