1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Main functions for vcs-tree
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2003
10 ;;;; Process all subdirectories that are managed by either CVS or SVN
13 ;;;; *************************************************************************
18 (defun is-vcs-directory (x)
22 (car (last (pathname-directory x))))
24 (car (last (pathname-directory x))))
26 (car (last (pathname-directory x)))))))
28 (defun is-cvs-managed (dir)
29 (probe-directory (merge-pathnames
30 (make-pathname :directory '(:relative "CVS"))
33 (defun is-svn-managed (dir)
34 (probe-directory (merge-pathnames
35 (make-pathname :directory '(:relative ".svn"))
38 (defun is-git-managed (dir)
39 (probe-directory (merge-pathnames
40 (make-pathname :directory '(:relative ".git"))
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))))
49 ((find ".svn" (cdr tree)
50 :key (lambda (x) (when (pathnamep (car x))
51 (car (last (pathname-directory (car x))))))
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))))))
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))))))
63 (cons (car tree) :cvs))))
64 (managed (car managed-pair))
65 (type (cdr managed-pair)))
67 (do* ((pos (cdr tree) (cdr pos))
68 (curr (car pos) (car pos))
70 ((null pos) (nreverse res))
71 (when (and (not (is-vcs-directory (car curr)))
73 (not (is-managed-dir (car curr) managed type))))
77 (cons managed (flatten
79 (mapcar 'filter-tree vcs-removed))))
80 (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
84 (defun is-managed-dir (subdir dir type)
89 (make-pathname :name "entries" :type nil
90 :directory '(:relative ".svn")))
92 (make-pathname :name "HEAD" :type nil
93 :directory '(:relative ".git")))
95 (make-pathname :name "Entries" :type nil
96 :directory '(:relative "CVS"))))
98 (entries (read-file-to-strings entries-path))
99 (dir-name (car (last (pathname-directory subdir))))
102 (concatenate 'string "name=\"" dir-name "\""))
104 (concatenate 'string "D/" dir-name "////")))))
107 (some (lambda (line) (string= match (string-trim-whitespace line)))
111 (some (lambda (line) (string= match (string-trim-whitespace line)))
113 (is-cvs-managed subdir))))))
116 (defun process-vcs-directory (dir action options)
117 (flet ((process (dir type-name)
122 ((equal type-name "git")
123 (format nil "~A pull" type-name))
125 (format nil "~A update" type-name))))
127 (format nil "~A status" type-name))
129 (format nil "~A commit~A" type-name
130 (aif (find "m" options :key #'car :test 'string=)
131 (format nil " -m \"~A\"" (cdr it))
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)
138 (format t "~A~%" output)
139 (format t "Exit status ~D: ~A ~A~%" status output error))))))
141 ((is-cvs-managed dir)
143 ((is-svn-managed dir)
145 ((is-git-managed dir)
148 (format *error-output*
149 "INTERAL ERROR: not a version control system directory ~A" dir)
152 (defvar *progname* "")
154 (defun usage (&optional msg &rest msg-args)
155 (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
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~%"))
166 (defun parse-action-arg (arg)
171 (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
173 ((eql pos 0) :update)
174 ((eql pos 1) :commit)
175 ((eql pos 2) :status)
177 (usage "Unknown action: ~A" arg)
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)))
188 (let ((action (parse-action-arg (first args))))
190 (usage "Invalid action ~A" (first args))
192 (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
193 (process-vcs-directory dir action options))))