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 (defun is-cvs-managed (dir)
27 (probe-directory (merge-pathnames
28 (make-pathname :directory '(:relative "CVS"))
31 (defun is-svn-managed (dir)
32 (probe-directory (merge-pathnames
33 (make-pathname :directory '(:relative ".svn"))
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))))
42 ((find ".svn" (cdr tree)
43 :key (lambda (x) (when (pathnamep (car x))
44 (car (last (pathname-directory (car x))))))
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))))))
51 (cons (car tree) :cvs))))
52 (managed (car managed-pair))
53 (type (cdr managed-pair)))
55 (do* ((pos (cdr tree) (cdr pos))
56 (curr (car pos) (car pos))
58 ((null pos) (nreverse res))
59 (when (and (not (is-vcs-directory (car curr)))
61 (not (is-managed-dir (car curr) managed type))))
65 (cons managed (flatten
67 (mapcar 'filter-tree vcs-removed))))
68 (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
72 (defun is-managed-dir (subdir dir type)
77 (make-pathname :name "entries" :type nil
78 :directory '(:relative ".svn")))
80 (make-pathname :name "Entries" :type nil
81 :directory '(:relative "CVS"))))
83 (entries (read-file-to-strings entries-path))
84 (dir-name (car (last (pathname-directory subdir))))
87 (concatenate 'string "name=\"" dir-name "\""))
89 (concatenate 'string "D/" dir-name "////")))))
92 (some (lambda (line) (string= match (string-trim-whitespace line)))
96 (some (lambda (line) (string= match (string-trim-whitespace line)))
98 (is-cvs-managed subdir))))))
101 (defun process-vcs-directory (dir action options)
102 (flet ((process (dir type-name)
106 (format nil "~A update" type-name))
108 (format nil "~A status" type-name))
110 (format nil "~A commit~A" type-name
111 (aif (find "m" options :key #'car :test 'string=)
112 (format nil " -m \"~A\"" (cdr it))
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)
119 (format t "~A~%" output)
120 (format t "Exit status ~D: ~A ~A~%" status output error))))))
122 ((is-cvs-managed dir)
124 ((is-svn-managed dir)
127 (format *error-output*
128 "INTERAL ERROR: not a version control system directory ~A" dir)
131 (defvar *progname* "")
133 (defun usage (&optional msg &rest msg-args)
134 (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
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~%"))
145 (defun parse-action-arg (arg)
150 (let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
152 ((eql pos 0) :update)
153 ((eql pos 1) :commit)
154 ((eql pos 2) :status)
156 (usage "Unknown action: ~A" arg)
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)))
167 (let ((action (parse-action-arg (first args))))
169 (usage "Invalid action ~A" (first args))
171 (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
172 (process-vcs-directory dir action options))))