Commit 6205bd933e077b02838dd7429920693559198429

Thomas de Grivel 2017-04-25T02:10:23

Add support for Subversion VCS.

diff --git a/repo.lisp b/repo.lisp
index 88ab563..63b465a 100644
--- a/repo.lisp
+++ b/repo.lisp
@@ -19,6 +19,7 @@
 	   #:repo
 	   #:*repo-dir*
 	   #:*repos*
+	   #:svn
 	   #:update))
 
 (defpackage :repo-user
@@ -67,6 +68,12 @@
 	  ((= 0 slash) "/")
 	  (t (subseq x 0 slash)))))
 
+(defun basename (x)
+  (let* ((end (or (string-ends-with "/" x) (length x)))
+	 (slash (position #\/ x :from-end t :end end)))
+    (cond ((null slash) (subseq x 0 end))
+	  (t (subseq x (1+ slash) end)))))
+
 (defun probe-dir (x)
   (probe-file (format nil "~A/" x)))
 
@@ -349,6 +356,59 @@
           (push repo *repos*)
           repo))))
 
+;;  subversion command
+
+(defvar *svn*
+  #+unix (or (probe-file "/usr/bin/svn")
+	     (probe-file "/usr/local/bin/svn")
+	     (first-line (sh "which svn"))))
+
+(defun $svn (&rest args)
+  (apply 'run-program *svn* args))
+
+;;  subversion repository class
+
+(defclass svn-repo (repo) ())
+
+(defgeneric $svn-checkout (repo))
+(defgeneric $svn-update (repo))
+
+(defmethod $svn-checkout ((repo svn-repo))
+  (let ((local (repo-local-dir repo))
+	(url (repo-url repo)))
+    (when (probe-dir local)
+      (error "svn checkout: not overwriting existing local directory~&~S" local))
+    (let ((parent (dirname local)))
+      (ensure-directories-exist (str parent "/") :verbose t)
+      ($svn "co" url (translate-home local))
+      nil)))
+
+(defmethod $svn-update ((repo svn-repo))
+  (let ((local (repo-local-dir repo)))
+    ($svn "up" (translate-home local))
+    nil))
+
+(defmethod install ((repo svn-repo))
+  (let ((local (repo-local-dir repo)))
+    (unless (probe-dir local)
+      ($svn-checkout repo))
+    (asdf::load-asd (repo-asd repo))))
+
+(defmethod update ((repo svn-repo))
+  (when (probe-dir (repo-local-dir repo))
+    ($svn-update repo)))
+
+(defun svn (url dir/name &rest initargs)
+  (or (repo-by-url url)
+      (let ((repo (apply #'make-instance 'svn-repo
+			 :dir (dirname dir/name)
+			 :name (basename dir/name)
+			 :url url :uri url
+			 :head (basename url)
+			 initargs)))
+        (push repo *repos*)
+        repo)))
+
 ;;  repo uri handler
 
 (defparameter *repo-uri-handlers*