Coverage report: /home/ellis/comp/core/lib/vc/util.lisp

KindCoveredAll%
expression15127 11.8
branch110 10.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; util.lisp --- VC High-level Utils
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :vc/util)
7
 
8
 (defun make-repo (path &key type init)
9
   (ecase type
10
     (:hg (make-hg-repo path :init init))
11
     (:git (make-git-repo path :init init))
12
     ('nil (multiple-value-bind (p ty) (find-repo-root path)
13
             (when (and p ty)
14
               (make-repo p :type ty))))))
15
 
16
 (defmacro with-current-vc-root ((sym &optional dir) &body body)
17
   `(let ((,sym
18
            (multiple-value-bind (root kind) (find-repo-root ,dir)
19
              (if root 
20
                  (make-repo root :type kind)
21
                  (error 'vc-error :message "Directory not under version control")))))
22
      ,@body))
23
 
24
 (defun directory-repos (&optional (path *default-pathname-defaults*) type)
25
   (let ((path (probe-directory path)))
26
     (loop for p in (directory (merge-pathnames "*/" (namestring path)))
27
           collect (make-repo p :type type))))
28
 
29
 (defun bundle-repo (path output)
30
   (vc-bundle (make-repo path) output))
31
 
32
 (defun bundle-repos (path output)
33
   (loop for repo in (directory-repos path)
34
         do (let ((out (merge-pathnames output (name repo))))
35
              (vc-bundle repo out))))
36
 
37
 (defun update-repo (repo &optional push (pull t))
38
   (when pull
39
     (vc-pull repo (when (stringp pull) pull)))
40
   (when push
41
     (vc-push repo :remote (when (stringp push) push))))
42
 
43
 (defun update-repos (path &key push (pull t) type)
44
   (loop for repo in (directory-repos path type)
45
         do (update-repo repo push pull)))
46
 
47
 (defmacro with-repo ((sym &rest args &key path init type &allow-other-keys) &body body)
48
   `(with-directory (probe-directory ,path)
49
      (let ((,sym ,@(or (unless (keywordp (car args))
50
                          `(pop ,args))
51
                        `((make-repo 
52
                           *default-pathname-defaults* 
53
                           ,@(when init `(:init ,init)) ,@(when type `(:type ,type)))))))
54
        (setf *repo* ,sym)
55
        ,@body)))
56
 
57
 ;;; Clone
58
 (defmethod vc-clone ((self pathname) (remote string) &key type)
59
   (let ((repo (if (or (search "git" remote)
60
                       (search "codeberg" remote)
61
                       (eql type :git))
62
                   (make-git-repo self)
63
                   (make-hg-repo self))))
64
     (vc-clone repo remote)))
65
 
66
 (defmethod vc-clone ((self pathname) (remote uri) &key type)
67
   (vc-clone (pathname self) (uri-to-string remote) :type type))
68
 
69
 (defmethod vc-clone ((self string) (remote t) &key type)
70
   (vc-clone (pathname self) remote :type type))
71