X-Git-Url: http://git.kpe.io/?p=vcs-tree.git;a=blobdiff_plain;f=main.lisp;h=861fcd280b9044fa9fd7d9cdafb897bade2cae06;hp=342e7d0320ba7e12dd5272a20ce63519772a2f71;hb=HEAD;hpb=9163fc46c1cf8ac02a3bf7a0119d3afd69789e46

diff --git a/main.lisp b/main.lisp
index 342e7d0..861fcd2 100644
--- a/main.lisp
+++ b/main.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; Process all subdirectories that are managed by either CVS or SVN
 ;;;;
-;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $
+;;;; $Id$
 ;;;; *************************************************************************
 
 
@@ -18,114 +18,135 @@
 (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* "")
@@ -134,10 +155,10 @@ Returns a list of directories managed by CVS or SVN."
   (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~%"))
@@ -149,27 +170,27 @@ Returns a list of directories managed by CVS or SVN."
     (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)