;;;;
;;;; Process all subdirectories that are managed by either CVS or SVN
;;;;
-;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $
+;;;; $Id$
;;;; *************************************************************************
(defun is-vcs-directory (x)
(and (pathnamep x)
(or
- (string= "CVS"
- (car (last (pathname-directory x))))
- (string= ".svn"
- (car (last (pathname-directory x)))))))
+ (string= "CVS"
+ (car (last (pathname-directory x))))
+ (string= ".svn"
+ (car (last (pathname-directory x))))
+ (string= ".git"
+ (car (last (pathname-directory x)))))))
(defun is-cvs-managed (dir)
(probe-directory (merge-pathnames
- (make-pathname :directory '(:relative "CVS"))
- dir)))
+ (make-pathname :directory '(:relative "CVS"))
+ dir)))
(defun is-svn-managed (dir)
(probe-directory (merge-pathnames
- (make-pathname :directory '(:relative ".svn"))
- dir)))
+ (make-pathname :directory '(:relative ".svn"))
+ dir)))
+
+(defun is-git-managed (dir)
+ (probe-directory (merge-pathnames
+ (make-pathname :directory '(:relative ".git"))
+ dir)))
(defun filter-tree (tree)
"Called for a directory tree. First argument is name of current tree.
-Returns a list of directories managed by CVS or SVN."
+Returns a list of directories managed by CVS, SVN, or GIT."
(when (and (listp tree) (not (is-vcs-directory (car tree))))
(let* ((managed-pair
- (cond
- ((find ".svn" (cdr tree)
- :key (lambda (x) (when (pathnamep (car x))
- (car (last (pathname-directory (car x))))))
- :test 'equal)
- (cons (car tree) :svn))
- ((find "CVS" (cdr tree)
- :key (lambda (x) (when (pathnamep (car x))
- (car (last (pathname-directory (car x))))))
- :test 'equal)
- (cons (car tree) :cvs))))
- (managed (car managed-pair))
- (type (cdr managed-pair)))
+ (cond
+ ((find ".svn" (cdr tree)
+ :key (lambda (x) (when (pathnamep (car x))
+ (car (last (pathname-directory (car x))))))
+ :test 'equal)
+ (cons (car tree) :svn))
+ ((find ".git" (cdr tree)
+ :key (lambda (x) (when (pathnamep (car x))
+ (car (last (pathname-directory (car x))))))
+ :test 'equal)
+ (cons (car tree) :git))
+ ((find "CVS" (cdr tree)
+ :key (lambda (x) (when (pathnamep (car x))
+ (car (last (pathname-directory (car x))))))
+ :test 'equal)
+ (cons (car tree) :cvs))))
+ (managed (car managed-pair))
+ (type (cdr managed-pair)))
(let ((vcs-removed
- (do* ((pos (cdr tree) (cdr pos))
- (curr (car pos) (car pos))
- (res nil))
- ((null pos) (nreverse res))
- (when (and (not (is-vcs-directory (car curr)))
- (or (not managed)
- (not (is-managed-dir (car curr) managed type))))
- (push curr res)))))
- (if vcs-removed
- (if managed
- (cons managed (flatten
- (delete-if #'null
- (mapcar 'filter-tree vcs-removed))))
- (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
- managed))
+ (do* ((pos (cdr tree) (cdr pos))
+ (curr (car pos) (car pos))
+ (res nil))
+ ((null pos) (nreverse res))
+ (when (and (not (is-vcs-directory (car curr)))
+ (or (not managed)
+ (not (is-managed-dir (car curr) managed type))))
+ (push curr res)))))
+ (if vcs-removed
+ (if managed
+ (cons managed (flatten
+ (delete-if #'null
+ (mapcar 'filter-tree vcs-removed))))
+ (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
+ managed))
)))
(defun is-managed-dir (subdir dir type)
(let* ((entries-path
- (merge-pathnames
- (ecase type
- (:svn
- (make-pathname :name "entries" :type nil
- :directory '(:relative ".svn")))
- (:cvs
- (make-pathname :name "Entries" :type nil
- :directory '(:relative "CVS"))))
- dir))
- (entries (read-file-to-strings entries-path))
- (dir-name (car (last (pathname-directory subdir))))
- (match (case type
- (:svn
- (concatenate 'string "name=\"" dir-name "\""))
- (:cvs
- (concatenate 'string "D/" dir-name "////")))))
+ (merge-pathnames
+ (ecase type
+ (:svn
+ (make-pathname :name "entries" :type nil
+ :directory '(:relative ".svn")))
+ (:git
+ (make-pathname :name "HEAD" :type nil
+ :directory '(:relative ".git")))
+ (:cvs
+ (make-pathname :name "Entries" :type nil
+ :directory '(:relative "CVS"))))
+ dir))
+ (entries (read-file-to-strings entries-path))
+ (dir-name (car (last (pathname-directory subdir))))
+ (match (case type
+ ((:svn :git)
+ (concatenate 'string "name=\"" dir-name "\""))
+ (:cvs
+ (concatenate 'string "D/" dir-name "////")))))
(case type
- (:svn
+ ((:svn :git)
(some (lambda (line) (string= match (string-trim-whitespace line)))
- entries))
+ entries))
(:cvs
(or
- (some (lambda (line) (string= match (string-trim-whitespace line)))
- entries)
- (is-cvs-managed subdir))))))
+ (some (lambda (line) (string= match (string-trim-whitespace line)))
+ entries)
+ (is-cvs-managed subdir))))))
(defun process-vcs-directory (dir action options)
(flet ((process (dir type-name)
- (let* ((vcs-cmd
- (ecase action
- (:update
- (format nil "~A update" type-name))
- (:status
- (format nil "~A status" type-name))
- (:commit
- (format nil "~A commit~A" type-name
- (aif (find "m" options :key #'car :test 'string=)
- (format nil " -m \"~A\"" (cdr it))
- "")))))
- (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
- (multiple-value-bind (output error status)
- (shell-command-output cmd :directory dir :whole t)
- (if (zerop status)
- (format t "~A ~A: ~A~%" vcs-cmd (namestring dir) output)
- (format t "~A ~A: ~A ~A ~A~%" vcs-cmd (namestring dir) output
- error status))))))
+ (let* ((vcs-cmd
+ (ecase action
+ (:update
+ (cond
+ ((equal type-name "git")
+ (format nil "~A pull" type-name))
+ (t
+ (format nil "~A update" type-name))))
+ (:status
+ (format nil "~A status" type-name))
+ (:commit
+ (format nil "~A commit~A" type-name
+ (aif (find "m" options :key #'car :test 'string=)
+ (format nil " -m \"~A\"" (cdr it))
+ "")))))
+ (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
+ (format t "~A ~A:~%" vcs-cmd (namestring dir))
+ (multiple-value-bind (output error status)
+ (shell-command-output cmd :directory dir :whole t)
+ (if (zerop status)
+ (format t "~A~%" output)
+ (format t "Exit status ~D: ~A ~A~%" status output error))))))
(cond
((is-cvs-managed dir)
(process dir "cvs"))
((is-svn-managed dir)
(process dir "svn"))
+ ((is-git-managed dir)
+ (process dir "git"))
(t
(format *error-output*
- "INTERAL ERROR: not a version control system directory ~A" dir)
+ "INTERAL ERROR: not a version control system directory ~A" dir)
(quit 1)))))
(defvar *progname* "")
(format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
(if msg
(progn
- (apply #'format *error-output* msg msg-args)
- (write-char #\Newline *error-output*))
+ (apply #'format *error-output* msg msg-args)
+ (write-char #\Newline *error-output*))
(format *error-output*
- "Processes a source-control managed directory tree~%"))
+ "Processes a source-control managed directory tree~%"))
(format *error-output* "Action: update, commit, or status~%")
(format *error-output* "OPTIONS~%")
(format *error-output* " -m <str> Set commit string~%"))
(t
(let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
(cond
- ((eql pos 0) :update)
- ((eql pos 1) :commit)
- ((eql pos 2) :status)
- (t
- (usage "Unknown action: ~A" arg)
- (quit 1)))))))
+ ((eql pos 0) :update)
+ ((eql pos 1) :commit)
+ ((eql pos 2) :status)
+ (t
+ (usage "Unknown action: ~A" arg)
+ (quit 1)))))))
(defun main (&optional (argv (command-line-arguments)))
(let ((*progname* (car argv)))
(multiple-value-bind (args options errors)
- (getopt (cdr argv) '(("m" :required)))
+ (getopt (cdr argv) '(("m" :required)))
(when (or errors (/= 1 (length args)))
- (usage)
- (quit 1))
+ (usage)
+ (quit 1))
(let ((action (parse-action-arg (first args))))
- (unless action
- (usage "Invalid action ~A" (first args))
- (quit 1))
- (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
- (process-vcs-directory dir action options))))
+ (unless action
+ (usage "Invalid action ~A" (first args))
+ (quit 1))
+ (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
+ (process-vcs-directory dir action options))))
(quit 0)))
;;(main)
projects / vcs-tree.git / blobdiff