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
  26 (defun is-cvs-managed (dir)
  27   (probe-directory (merge-pathnames
  28                     (make-pathname :directory '(:relative "CVS"))
  29                     dir)))
  30
  31 (defun is-svn-managed (dir)
  32   (probe-directory (merge-pathnames
  33                     (make-pathname :directory '(:relative ".svn"))
  34                     dir)))
  35
  36 (defun filter-tree (tree)
  37   "Called for a directory tree. First argument is name of current tree.
  38 Returns a list of directories managed by CVS or SVN."
  39   (when (and (listp tree) (not (is-vcs-directory (car tree))))
  40     (let* ((managed-pair
  41             (cond
  42              ((find ".svn" (cdr tree)
  43                     :key (lambda (x) (when (pathnamep (car x))
  44                                        (car (last (pathname-directory (car x))))))
  45                     :test 'equal)
  46               (cons (car tree) :svn))
  47              ((find "CVS" (cdr tree)
  48                     :key (lambda (x) (when (pathnamep (car x))
  49                                        (car (last (pathname-directory (car x))))))
  50                     :test 'equal)
  51               (cons (car tree) :cvs))))
  52            (managed (car managed-pair))
  53            (type (cdr managed-pair)))
  54       (let ((vcs-removed
  55              (do* ((pos (cdr tree) (cdr pos))
  56                    (curr (car pos) (car pos))
  57                    (res nil))
  58                  ((null pos) (nreverse res))
  59                (when (and (not (is-vcs-directory (car curr)))
  60                           (or (not managed)
  61                               (not (is-managed-dir (car curr) managed type))))
  62                  (push curr res)))))
  63         (if vcs-removed
  64             (if managed
  65                 (cons managed (flatten
  66                                (delete-if #'null
  67                                           (mapcar 'filter-tree vcs-removed))))
  68               (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
  69           managed))
  70       )))
  71
  72 (defun is-managed-dir (subdir dir type)
  73   (let* ((entries-path
  74           (merge-pathnames
  75            (ecase type
  76              (:svn
  77               (make-pathname :name "entries" :type nil
  78                              :directory '(:relative ".svn")))
  79              (:cvs
  80               (make-pathname :name "Entries" :type nil
  81                              :directory '(:relative "CVS"))))
  82            dir))
  83          (entries (read-file-to-strings entries-path))
  84          (dir-name (car (last (pathname-directory subdir))))
  85          (match (case type
  86                   (:svn
  87                    (concatenate 'string "name=\"" dir-name "\""))
  88                   (:cvs
  89                    (concatenate 'string "D/" dir-name "////")))))
  90     (case type
  91       (:svn
  92        (some (lambda (line) (string= match (string-trim-whitespace line)))
  93              entries))
  94       (:cvs
  95        (or
  96         (some (lambda (line) (string= match (string-trim-whitespace line)))
  97               entries)
  98         (is-cvs-managed subdir))))))
  99
 100
 101 (defun process-vcs-directory (dir action options)
 102   (flet ((process (dir type-name)
 103            (let* ((vcs-cmd
 104                    (ecase action
 105                      (:update
 106                       (format nil "~A update" type-name))
 107                      (:status
 108                       (format nil "~A status" type-name))
 109                      (:commit
 110                       (format nil "~A commit~A" type-name
 111                               (aif (find "m" options :key #'car :test 'string=)
 112                                    (format nil " -m \"~A\"" (cdr it))
 113                                    "")))))
 114                   (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
 115              (format t "~A ~A:~%" vcs-cmd (namestring dir))
 116              (multiple-value-bind (output error status)
 117                  (shell-command-output cmd :directory dir :whole t)
 118                (if (zerop status)
 119                    (format t "~A~%" output)
 120                    (format t "Exit status ~D: ~A ~A~%" status output error))))))
 121     (cond
 122       ((is-cvs-managed dir)
 123        (process dir "cvs"))
 124      ((is-svn-managed dir)
 125       (process dir "svn"))
 126      (t
 127       (format *error-output*
 128               "INTERAL ERROR: not a version control system directory ~A" dir)
 129       (quit 1)))))
 130
 131 (defvar *progname* "")
 132
 133 (defun usage (&optional msg &rest msg-args)
 134   (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
 135   (if msg
 136       (progn
 137         (apply #'format *error-output* msg msg-args)
 138         (write-char #\Newline *error-output*))
 139       (format *error-output*
 140               "Processes a source-control managed directory tree~%"))
 141   (format *error-output* "Action: update, commit, or status~%")
 142   (format *error-output* "OPTIONS~%")
 143   (format *error-output* "   -m <str>    Set commit string~%"))
 144
 145 (defun parse-action-arg (arg)
 146   (cond
 147     ((string= arg "ci")
 148      :commit)
 149     (t
 150      (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
 151        (cond
 152          ((eql pos 0) :update)
 153          ((eql pos 1) :commit)
 154          ((eql pos 2) :status)
 155          (t
 156           (usage "Unknown action: ~A" arg)
 157           (quit 1)))))))
 158
 159
 160 (defun main (&optional (argv (command-line-arguments)))
 161   (let ((*progname* (car argv)))
 162     (multiple-value-bind (args options errors)
 163         (getopt (cdr argv) '(("m" :required)))
 164       (when (or errors (/= 1 (length args)))
 165         (usage)
 166         (quit 1))
 167       (let ((action (parse-action-arg (first args))))
 168         (unless action
 169           (usage "Invalid action ~A" (first args))
 170           (quit 1))
 171         (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
 172           (process-vcs-directory dir action options))))
 173     (quit 0)))
 174
 175 ;;(main)
 176 ;;(quit 0)
 177
 178