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

KindCoveredAll%
expression39203 19.2
branch416 25.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/vc/proto.lisp --- VC Protocol
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :vc/proto)
7
 
8
 ;;; Vars
9
 (defvar *default-vc-kind* :hg)
10
 (defvar *repo* nil)
11
 (defvar *repo-roots* nil)
12
 (defvar *repo-registry* (make-hash-table :test 'equal))
13
 (defvar *repo-auto-register* t
14
   "When non-nil, register all VC-REPO objects when they are created.")
15
 
16
 ;;; Conditions
17
 (define-condition vc-error (std-error) ())
18
 
19
 ;;; Utils
20
 (defun namestring-or (obj)
21
   (if (pathnamep obj)
22
       (namestring obj)
23
       obj))
24
 
25
 (defun rel-pathname (path)
26
   (pathname (string-left-trim '(#\/) path)))
27
 
28
 (defun glob-path-match (glob)
29
   (lambda (p start end)
30
     (member (subseq p start end) (directory (rel-pathname glob)) :test 'equal)))
31
 
32
 ;;; Generics
33
 (defgeneric vc-init (self)
34
   (:documentation "Initialize a vc-repo - calls either 'git init' or 'hg init'"))
35
 
36
 (defgeneric vc-run (self cmd &rest args)
37
   (:documentation "Run a vc CMD with ARGS."))
38
 
39
 (defgeneric vc-clone (self remote &key &allow-other-keys)
40
   (:documentation "Clone repo REMOTE into spec SELF."))
41
 
42
 (defgeneric vc-push (self &key remote)
43
   (:documentation "Push repo SELF to REMOTE."))
44
 
45
 (defgeneric vc-pull (self &optional remote)
46
   (:documentation "Pull repo REMOTE into spec SELF."))
47
 
48
 (defgeneric vc-update (self &optional branch)
49
   (:documentation "Update repo SELF with optional BRANCH."))
50
 
51
 (defgeneric vc-commit (self msg &key &allow-other-keys)
52
   (:documentation "Commit repo object SELF, supplied with message MSG."))
53
 
54
 (defgeneric vc-add (self &rest files)
55
   (:documentation "Add FILES to repo SELF."))
56
 
57
 (defgeneric vc-remove (self &rest files)
58
   (:documentation "Remove FILES from repo SELF."))
59
 
60
 (defgeneric vc-addremove (self &rest files)
61
   (:documentation "Add any untracked files in the current directory and delete tracked files that
62
 are missing."))
63
 
64
 (defgeneric vc-branch (self)
65
   (:documentation "Return the name of the current branch."))
66
 
67
 (defgeneric vc-status (self &key &allow-other-keys))
68
 
69
 (defgeneric vc-bundle (self output &key &allow-other-keys))
70
 (defgeneric vc-unbundle (self input &key &allow-other-keys))
71
 
72
 (defgeneric vc-export (self output &key &allow-other-keys))
73
 
74
 ;;; Accessors
75
 (defgeneric vc-head (self))
76
 (defgeneric vc-tags (self))
77
 (defgeneric vc-revs (self))
78
 (defgeneric vc-branches (self))
79
 (defgeneric vc-remotes (self))
80
 (defgeneric vc-remote (self cmd &key &allow-other-keys))
81
 (defgeneric vc-submodule (self cmd &key &allow-other-keys))
82
 (defgeneric vc-config (self))
83
 (defgeneric (setf vc-config) (new self))
84
 (defgeneric vc-type (self))
85
 ;;  IDEA 2023-12-29: :ediff t
86
 (defgeneric vc-diff (a b &key &allow-other-keys))
87
 
88
 ;;; Objects
89
 
90
 ;;;; Config
91
 
92
 ;; usually parsed from .gitconfig or .hgrc
93
 (defconfig vc-config () ())
94
 
95
 ;;;; Ignorefile
96
 
97
 ;; Basically we treat HG and GIT ignore files the same - just lines of string
98
 ;; patterns. HG uses regexp and GIT is globs - an IGNOREFILE has a line parser
99
 ;; slot for selecting the appropriate function.
100
 
101
 (defun map-lines (fn path)
102
   "Call FN on each line of file PATH and collect the result."
103
   (with-open-file (file path)
104
     (loop for line = (read-line file nil)
105
           while line
106
           unless (or (= (length line) 0) (char= (aref line 0) #\#))
107
           collect (funcall fn line))))
108
 
109
 (defstruct vc-ignore path patterns)
110
 
111
 (defgeneric vc-path-ignored-p (obj path)
112
   (:documentation "Check PATH against the patterns in OBJ. If there is a match, return non-nil.")
113
   (:method ((obj vc-ignore) (path t))
114
     (let ((len (length path)))
115
       (loop for pat in (vc-ignore-patterns obj)
116
             when (funcall pat path 0 len)
117
             return (values path pat)))))
118
 
119
 (defstruct vc-branch name rev)
120
 
121
 (defstruct vc-commit id message)
122
 
123
 (defstruct vc-tag name id)
124
 
125
 (deftype vc-designator () `(or (member :hg :git) null)) ;; maybe: :sp (sapling)
126
 
127
 (defstruct vc-remote 
128
   (type nil :type vc-designator) 
129
   name
130
   url)
131
 
132
 (defaccessor name ((self vc-remote)) (vc-remote-name self))
133
 
134
 (defmethod print-object ((self vc-remote) stream)
135
   (let ((name (vc-remote-name self))
136
         (url (vc-remote-url self)))
137
     (format stream "(~A . ~A)" (string-downcase name) url)))
138
 
139
 (defstruct vc-rev num id)
140
 
141
 (defclass vc-repo ()
142
   ((path :initform nil :type (or null string pathname) :accessor path
143
          :initarg :path
144
          :documentation "AKA working-directory or working-copy")
145
    (head :initform nil :initarg :head :type (or null vc-rev) :accessor vc-head)
146
    (branches :initform (make-array 0 :element-type 'vc-branch :fill-pointer 0)
147
              :type (vector vc-branch) :accessor vc-branches)
148
    (submodules :type (vector vc-repo) :accessor vc-submodules)
149
    (tags :initform (make-array 0 :element-type 'vc-tag :fill-pointer 0) :type (vector vc-tag) :accessor vc-tags)
150
    (revisions :initform (make-array 0 :element-type 'vc-rev :fill-pointer 0)
151
               :type (vector vc-rev) :accessor vc-revs)
152
    (remotes :initform (make-array 0 :element-type 'vc-remote :fill-pointer 0)
153
             :type (vector vc-remote) :accessor vc-remotes)
154
    (config :initform nil :type (or null vc-config) :accessor vc-config))
155
   (:documentation "generic Repository object backed by one of VC-DESIGNATOR."))
156
 
157
 (defun register-repo (repo)
158
   "Register a repo, collecting information from the filesystem and
159
 creating a repo object which is stored in *REPO-REGISTRY*."
160
   (setf (gethash (path repo) *repo-registry*) repo))
161
 
162
 (defun find-repo (name)
163
   "Find a repo in *REPO-REGISTRY*."
164
   (gethash name *repo-registry*))
165
 
166
 (defmethod initialize-instance :after ((self vc-repo) &key)
167
   (when *repo-auto-register* (register-repo self)))
168
 
169
 (defmethod name ((self vc-repo))
170
   (car (last (pathname-directory (path self)))))
171
 
172
 (defmethod vc-type ((self vc-repo)) t)
173
 
174
 (defmethod write-ast ((self vc-repo) stream &key (pretty t) (case :downcase))
175
   (if (= 0 (length (vc-remotes self)))
176
       (write (vc-type self) :stream stream :pretty pretty :case case :readably t :array t :escape t)
177
       (progn
178
         (format stream "(")
179
         (write (vc-type self) :stream stream :pretty pretty :case case :readably t :array t :escape t)
180
         (format stream " ")
181
         (loop for x in (vc-remotes self)
182
               do 
183
                  (write `(,(vc-type self) ,(coerce (vc-remotes self) 'list)) :stream stream :pretty pretty :case case :readably t :array t :escape t))
184
         (format stream ")"))))
185
 
186
 ;; (defmethod print-object ((self vc-repo) stream)
187
 ;;   (print-unreadable-object (self stream)
188
 ;;     (write "vc-repo" :stream stream)
189
 ;;     (std:when-let ((remotes (vc-remotes self)))
190
 ;;       (write " " :stream stream)
191
 ;;       (pprint-tabular stream remotes nil nil 2))))
192
 
193
 (defun find-repo-root (&optional (path *default-pathname-defaults*))
194
   "Check PATH for evidence of a VCS and continue walking up the filesystem until
195
 we find one, else return NIL."
196
   (labels ((%check (dir)
197
              (if (null dir)
198
                  (return-from find-repo-root)
199
                  (if (probe-file (merge-pathnames ".hg/" dir))
200
                      :hg
201
                      (when (probe-file (merge-pathnames ".git/" dir))
202
                        :git)))))
203
     (let ((%path (directory-path (or path *default-pathname-defaults*))))
204
       (loop for x = (%check %path)
205
             for parent = (when-let ((parent (butlast (pathname-directory %path))))
206
                            (make-pathname :directory parent))
207
             if x
208
             return (values %path x)
209
             else if (or (not parent) (sequence:emptyp (namestring parent)))
210
             return nil
211
             else
212
             do (setf %path parent)))))