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: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $
  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 ((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              (multiple-value-bind (output error status)
 115                (shell-command-output cmd :directory dir :whole t)
 116                (if (zerop status)
 117                    (format t "~A ~A: ~A~%" cmd (namestring dir) output)
 118                    (format t "~A ~A: ~A ~A ~A~%" cmd (namestring dir) output
 119                            error status))))))
 120     (cond
 121       ((is-cvs-managed dir)
 122        (process dir "cvs"))
 123      ((is-svn-managed dir)
 124       (process dir "svn"))
 125      (t
 126       (format *error-output*
 127               "INTERAL ERROR: not a version control system directory ~A" dir)
 128       (quit 1)))))
 129
 130 (defvar *progname* "")
 131
 132 (defun usage (&optional msg &rest msg-args)
 133   (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
 134   (if msg
 135       (progn
 136         (apply #'format *error-output* msg msg-args)
 137         (write-char #\Newline *error-output*))
 138       (format *error-output*
 139               "Processes a source-control managed directory tree~%"))
 140   (format *error-output* "Action: update, commit, or status~%")
 141   (format *error-output* "OPTIONS~%")
 142   (format *error-output* "   -m <str>    Set commit string~%"))
 143
 144 (defun parse-action-arg (arg)
 145   (cond
 146     ((string= arg "ci")
 147      :commit)
 148     (t
 149      (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
 150        (cond
 151          ((eql pos 0) :update)
 152          ((eql pos 1) :commit)
 153          ((eql pos 2) :status)
 154          (t
 155           (usage "Unknown action: ~A" arg)
 156           (quit 1)))))))
 157
 158
 159 (defun main (&optional (argv (command-line-arguments)))
 160   (let ((*progname* (car argv)))
 161     (multiple-value-bind (args options errors)
 162         (getopt (cdr argv) '(("m" :required)))
 163       (when (or errors (/= 1 (length args)))
 164         (usage)
 165         (quit 1))
 166       (let ((action (parse-action-arg (first args))))
 167         (unless action
 168           (usage "Invalid action ~A" (first args))
 169           (quit 1))
 170         (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
 171           (process-vcs-directory dir action options))))
 172     (quit 0)))
 173
 174 ;;(main)
 175 ;;(quit 0)
 176
 177