main.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          main.lisp
   6 ;;;; Purpose:       Main functions for vcs-tree
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; Process all subdirectories that are managed by either CVS or SVN
  11 ;;;;
  12 ;;;; $Id$
  13 ;;;; *************************************************************************
  14
  15
  16 (in-package vcs-tree)
  17
  18 (defun is-vcs-directory (x)
  19   (and (pathnamep x)
  20        (or
  21         (string= "CVS"
  22                  (car (last (pathname-directory x))))
  23         (string= ".svn"
  24                  (car (last (pathname-directory x))))
  25         (string= ".git"
  26                  (car (last (pathname-directory x)))))))
  27
  28 (defun is-cvs-managed (dir)
  29   (probe-directory (merge-pathnames
  30                     (make-pathname :directory '(:relative "CVS"))
  31                     dir)))
  32
  33 (defun is-svn-managed (dir)
  34   (probe-directory (merge-pathnames
  35                     (make-pathname :directory '(:relative ".svn"))
  36                     dir)))
  37
  38 (defun is-git-managed (dir)
  39   (probe-directory (merge-pathnames
  40                     (make-pathname :directory '(:relative ".git"))
  41                     dir)))
  42
  43 (defun filter-tree (tree)
  44   "Called for a directory tree. First argument is name of current tree.
  45 Returns a list of directories managed by CVS, SVN, or GIT."
  46   (when (and (listp tree) (not (is-vcs-directory (car tree))))
  47     (let* ((managed-pair
  48             (cond
  49              ((find ".svn" (cdr tree)
  50                     :key (lambda (x) (when (pathnamep (car x))
  51                                        (car (last (pathname-directory (car x))))))
  52                     :test 'equal)
  53               (cons (car tree) :svn))
  54              ((find ".git" (cdr tree)
  55                     :key (lambda (x) (when (pathnamep (car x))
  56                                        (car (last (pathname-directory (car x))))))
  57                     :test 'equal)
  58               (cons (car tree) :git))
  59              ((find "CVS" (cdr tree)
  60                     :key (lambda (x) (when (pathnamep (car x))
  61                                        (car (last (pathname-directory (car x))))))
  62                     :test 'equal)
  63               (cons (car tree) :cvs))))
  64            (managed (car managed-pair))
  65            (type (cdr managed-pair)))
  66       (let ((vcs-removed
  67              (do* ((pos (cdr tree) (cdr pos))
  68                    (curr (car pos) (car pos))
  69                    (res nil))
  70                  ((null pos) (nreverse res))
  71                (when (and (not (is-vcs-directory (car curr)))
  72                           (or (not managed)
  73                               (not (is-managed-dir (car curr) managed type))))
  74                  (push curr res)))))
  75         (if vcs-removed
  76             (if managed
  77                 (cons managed (flatten
  78                                (delete-if #'null
  79                                           (mapcar 'filter-tree vcs-removed))))
  80               (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
  81           managed))
  82       )))
  83
  84 (defun is-managed-dir (subdir dir type)
  85   (let* ((entries-path
  86           (merge-pathnames
  87            (ecase type
  88              (:svn
  89               (make-pathname :name "entries" :type nil
  90                              :directory '(:relative ".svn")))
  91              (:git
  92               (make-pathname :name "HEAD" :type nil
  93                              :directory '(:relative ".git")))
  94              (:cvs
  95               (make-pathname :name "Entries" :type nil
  96                              :directory '(:relative "CVS"))))
  97            dir))
  98          (entries (read-file-to-strings entries-path))
  99          (dir-name (car (last (pathname-directory subdir))))
 100          (match (case type
 101                   ((:svn :git)
 102                    (concatenate 'string "name=\"" dir-name "\""))
 103                   (:cvs
 104                    (concatenate 'string "D/" dir-name "////")))))
 105     (case type
 106       ((:svn :git)
 107        (some (lambda (line) (string= match (string-trim-whitespace line)))
 108              entries))
 109       (:cvs
 110        (or
 111         (some (lambda (line) (string= match (string-trim-whitespace line)))
 112               entries)
 113         (is-cvs-managed subdir))))))
 114
 115
 116 (defun process-vcs-directory (dir action options)
 117   (flet ((process (dir type-name)
 118            (let* ((vcs-cmd
 119                    (ecase action
 120                      (:update
 121                       (cond
 122                         ((equal type-name "git")
 123                          (format nil "~A pull" type-name))
 124                         (t
 125                          (format nil "~A update" type-name))))
 126                      (:status
 127                       (format nil "~A status" type-name))
 128                      (:commit
 129                       (format nil "~A commit~A" type-name
 130                               (aif (find "m" options :key #'car :test 'string=)
 131                                    (format nil " -m \"~A\"" (cdr it))
 132                                    "")))))
 133                   (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
 134              (format t "~A ~A:~%" vcs-cmd (namestring dir))
 135              (multiple-value-bind (output error status)
 136                  (shell-command-output cmd :directory dir :whole t)
 137                (if (zerop status)
 138                    (format t "~A~%" output)
 139                    (format t "Exit status ~D: ~A ~A~%" status output error))))))
 140     (cond
 141       ((is-cvs-managed dir)
 142        (process dir "cvs"))
 143      ((is-svn-managed dir)
 144       (process dir "svn"))
 145      ((is-git-managed dir)
 146       (process dir "git"))
 147      (t
 148       (format *error-output*
 149               "INTERAL ERROR: not a version control system directory ~A" dir)
 150       (quit 1)))))
 151
 152 (defvar *progname* "")
 153
 154 (defun usage (&optional msg &rest msg-args)
 155   (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
 156   (if msg
 157       (progn
 158         (apply #'format *error-output* msg msg-args)
 159         (write-char #\Newline *error-output*))
 160       (format *error-output*
 161               "Processes a source-control managed directory tree~%"))
 162   (format *error-output* "Action: update, commit, or status~%")
 163   (format *error-output* "OPTIONS~%")
 164   (format *error-output* "   -m <str>    Set commit string~%"))
 165
 166 (defun parse-action-arg (arg)
 167   (cond
 168     ((string= arg "ci")
 169      :commit)
 170     (t
 171      (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
 172        (cond
 173          ((eql pos 0) :update)
 174          ((eql pos 1) :commit)
 175          ((eql pos 2) :status)
 176          (t
 177           (usage "Unknown action: ~A" arg)
 178           (quit 1)))))))
 179
 180
 181 (defun main (&optional (argv (command-line-arguments)))
 182   (let ((*progname* (car argv)))
 183     (multiple-value-bind (args options errors)
 184         (getopt (cdr argv) '(("m" :required)))
 185       (when (or errors (/= 1 (length args)))
 186         (usage)
 187         (quit 1))
 188       (let ((action (parse-action-arg (first args))))
 189         (unless action
 190           (usage "Invalid action ~A" (first args))
 191           (quit 1))
 192         (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
 193           (process-vcs-directory dir action options))))
 194     (quit 0)))
 195
 196 ;;(main)
 197 ;;(quit 0)
 198
 199