1 ;; vc-got.el --- Game of Tree backend for VC -*- lexical-binding: t; -*-
2 
3 ;; Copyright © 2020 Omar Polo <op@omarpolo.com>
4 
5 ;; This file is not part of GNU Emacs.
6 
7 ;; This file is free software.
8 ;;
9 ;; Permission to use, copy, modify, and distribute this software for
10 ;; any purpose with or without fee is hereby granted, provided that
11 ;; the above copyright notice and this permission notice appear in all
12 ;; copies.
13 ;;
14 ;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
15 ;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
16 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
17 ;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
18 ;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
19 ;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
20 ;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
21 ;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
22 
23 ;; Author: Omar Polo <op@omarpolo.com>
24 ;; URL: https://git.omarpolo.com/vc-got
25 ;; Keywords: vc vc-backend
26 
27 ;;; Commentary
28 
29 ;; Backend implementation status
30 ;;
31 ;; Function marked with `*' are required, those with `-' are optional.
32 ;;
33 ;; FUNCTION NAME                        STATUS
34 ;;
35 ;; BACKEND PROPERTIES:
36 ;; * revision-granularity               DONE
37 ;; - update-on-retrieve-tag             XXX: what should this do?
38 ;;
39 ;; STATE-QUERYING FUNCTIONS:
40 ;; * registered                         DONE
41 ;; * state                              DONE
42 ;; - dir-status-files                   DONE
43 ;; - dir-extra-headers                  NOT IMPLEMENTED
44 ;; - dir-printer                        NOT IMPLEMENTED
45 ;; - status-fileinfo-extra              NOT IMPLEMENTED
46 ;; * working-revision                   DONE
47 ;; * checkout-model                     DONE
48 ;; - mode-line-string                   NOT IMPLEMENTED
49 ;;
50 ;; STATE-CHANGING FUNCTIONS:
51 ;; * create-repo                        NOT IMPLEMENTED
52 ;;                           I don't think got init does
53 ;;                           what this function is supposed
54 ;;                           to do.
55 ;; * register                           DONE
56 ;; - responsible-p                      DONE
57 ;; - receive-file                       NOT IMPLEMENTED
58 ;; - unregister                         NOT IMPLEMENTED
59 ;;                           use remove?
60 ;; * checkin                            DONE
61 ;; * find-revision                      DONE
62 
63 ;; TODO: use the idiom
64 ;;      (let (process-file-side-effects) ...)
65 ;; when the got command WON'T change the file.  This can enable some
66 ;; emacs optimizations
67 
68 ;;; Code:
69 
70 (eval-when-compile
71   (require 'subr-x))
72 
73 (require 'cl-lib)
74 (require 'seq)
75 (require 'vc)
76 
77 (defvar vc-got-cmd "got"
78   "The got command.")
79 
80 ;; helpers
81 
82 (defun vc-got-root (file)
83   "Return the work tree root for FILE, or nil."
84   (or (vc-file-getprop file 'got-root)
85       (vc-file-setprop file 'got-root (vc-find-root file ".got"))))
86 
87 (defmacro vc-got-with-worktree (file &rest body)
88   "Evaluate BODY in the work tree directory of FILE."
89   (declare (indent defun))
90   `(when-let (default-directory (vc-got-root ,file))
91      ,@body))
92 
93 (defun vc-got--call (&rest args)
94   "Call `vc-got-cmd' in the `default-directory' with ARGS and put the output in the current buffer."
95   (apply #'process-file vc-got-cmd nil (current-buffer) nil args))
96 
97 (defun vc-got--add (files)
98   "Add FILES to got, passing `vc-register-switches' to the command invocation."
99   (with-temp-buffer
100     (apply #'vc-got--call "add" (append vc-register-switches files))))
101 
102 (defun vc-got--log (limit path)
103   "Execute the log command in the worktree of PATH.
104 
105 The output of the command will be put in the current-buffer.
106 
107 LIMIT limits the maximum number of commit returned.
108 
109 Return nil if the command failed or if PATH isn't included in any
110 worktree."
111   (vc-got-with-worktree path
112     (zerop (vc-got--call "log" "-l" (format "%s" limit) path))))
113 
114 (defun vc-got--status (dir-or-file &rest files)
115   "Return the output of ``got status''.
116 
117 DIR-OR-FILE can be either a directory or a file.  If FILES is
118 given, return the status of those files, otherwise the status of
119 DIR-OR-FILE."
120   (vc-got-with-worktree dir-or-file
121     (with-temp-buffer
122       (if files
123           (apply #'vc-got--call "status" files)
124         (vc-got--call "status" dir-or-file))
125       (buffer-string))))
126 
127 (defun vc-got--parse-status-flag (flag)
128   "Parse FLAG, see `vc-state'."
129   ;; got outputs nothing if the file is up-to-date
130   (if (string-empty-p flag)
131       'up-to-date
132     ;; trying to follow the order of the manpage
133     (cl-case (aref flag 0)
134       (?M 'edited)
135       (?A 'added)
136       (?D 'removed)
137       (?C 'conflict)
138       (?! 'missing)
139       (?~ 'edited) ;XXX: what does it means for a file to be ``obstructed''?
140       (?? 'unregistered)
141       (?m 'edited) ;modified file modes
142       (?N nil))))
143 
144 (defun vc-got--parse-status (output)
145   "Parse the OUTPUT of got status and return an alist of (FILE . STATUS)."
146   ;; XXX: the output of got is line-oriented and will break if
147   ;; filenames contains spaces or newlines.
148   (cl-loop for line in (split-string output "\n" t)
149            collect (cl-destructuring-bind (status file) (split-string line " " t " ")
150                      `(,file . ,(vc-got--parse-status-flag status)))))
151 
152 (defun vc-got--tree-parse ()
153   "Parse into an alist the output of got tree -i in the current buffer."
154   (goto-char (point-min))
155   (cl-loop
156    until (= (point) (point-max))
157    collect (let* ((obj-start (point))
158                   (_ (forward-word))
159                   (obj (buffer-substring obj-start (point)))
160                   (_ (forward-char))         ;skip the space
161                   (filename-start (point))
162                   (_ (move-end-of-line nil))
163                   (filename (buffer-substring filename-start (point))))
164              ;; goto the start of the next line
165              (forward-line)
166              (move-beginning-of-line nil)
167              `(,filename . ,obj))))
168 
169 (defun vc-got--tree (commit path)
170   (vc-got-with-worktree path
171     (with-temp-buffer
172       (vc-got--call "tree" "-c" commit "-i" path)
173       (vc-got--tree-parse))))
174 
175 (defun vc-got--cat (commit obj-id)
176   "Execute got cat -c COMMIT OBJ-ID in the current buffer."
177   (vc-got--call "cat" "-c" commit obj-id))
178 
179 
180 ;; Backend properties
181 
182 (defun vc-got-revision-granularity ()
183   "Got has REPOSITORY granularity."
184   'repository)
185 
186 ;; XXX: what this should do?  The description is not entirely clear
187 (defun vc-got-update-on-retrieve-tag ()
188   nil)
189 
190 
191 ;; State-querying functions
192 
193 ;;;###autoload (defun vc-got-registered (file)
194 ;;;###autoload   "Return non-nil if FILE is registered with got."
195 ;;;###autoload   (when (vc-find-root file ".got")
196 ;;;###autoload     (load "vc-got" nil t)
197 ;;;###autoload     (vc-got-registered file)))
198 
199 (defun vc-got-registered (file)
200   "Return non-nil if FILE is registered with got."
201   (if (file-directory-p file)
202       nil                               ;got doesn't track directories
203     (let ((status (vc-got--status file)))
204       (not (or (string-prefix-p "?" status)
205                (string-prefix-p "N" status))))))
206 
207 ;; (vc-got-registered "/usr/ports/mystuff/net/td")
208 ;; (vc-got-registered "/usr/ports/mystuff/net/td/Makefile")
209 ;; (vc-got-registered "/usr/ports/mystuff/tmp")
210 ;; (vc-got-registered "/usr/ports/mystuff/no-existant")
211 
212 (defun vc-got-state (file)
213   "Return the current version control state of FILE.  See `vc-state'."
214   (unless (file-directory-p file)
215     (vc-got--parse-status-flag (vc-got--status file))))
216 
217 ;; (vc-got-state "/usr/ports/mystuff/net/td")
218 ;; (vc-got-state "/usr/ports/mystuff/net/td/Makefile")
219 ;; (vc-got-state "/usr/ports/mystuff/tmp")
220 ;; (vc-got-state "/usr/ports/mystuff/non-existant")
221 
222 (defun vc-got-dir-status-files (dir files update-function)
223   (let* ((files (seq-filter (lambda (file)
224                               (and (not (string= file ".."))
225                                    (not (string= file "."))
226                                    (not (string= file ".got"))))
227                             (or files
228                                 (directory-files dir))))
229          (statuses (vc-got--parse-status
230                     (apply #'vc-got--status dir files)))
231          (default-directory dir))
232     (cl-loop
233      with result = nil
234      for file in files
235      do (setq result
236               (cons
237                (if (file-directory-p file)
238                    (list file 'unregistered nil)
239                  (if-let (status (cdr (assoc file statuses #'string=)))
240                      (list file status nil)
241                    (list file 'up-to-date nil)))
242                result))
243      finally (funcall update-function result nil))))
244 
245 ;; (let ((dir "/usr/ports/mystuff"))
246 ;;   (vc-got-dir-status-files dir nil (lambda (res _t)
247 ;;                                      (message "got %s" res))))
248 
249 (defun vc-got-working-revision (file)
250   "Return the id of the last commit that touched the FILE.
251 
252 Return \"0\" for a file added but not yet committed."
253   (or
254    (with-temp-buffer
255      (when (vc-got--log 1 file)
256        (let (start)
257          (goto-char (point-min))
258          (forward-line 1)               ;skip the ----- line
259          (forward-word)                 ;skip "commit"
260          (forward-char)                 ;skip the space
261          (setq start (point))           ;store start of the SHA
262          (forward-word)                 ;goto SHA end
263          (buffer-substring start (point)))))
264    ;; special case: if this file is added but has no previous commits
265    ;; touching it, got log will fail (as expected), but we have to
266    ;; return "0".
267    (when (eq (vc-got-state file) 'added)
268      "0")))
269 
270 ;; (vc-got-working-revision "/usr/ports/mystuff/non-existant")
271 ;; (vc-got-working-revision "/usr/ports/mystuff/CVS")
272 ;; (vc-got-working-revision "/usr/ports/mystuff/tmp")
273 ;; (vc-got-working-revision "/usr/ports/mystuff/net/td/Makefile")
274 
275 (defun vc-got-checkout-model (_files)
276   'implicit)
277 
278 
279 ;; state-changing functions
280 
281 (defun vc-got-create-repo (_backend)
282   (error "vc got: create-repo not implemented"))
283 
284 (defun vc-got-register (files &optional _comment)
285   "Register FILES, passing `vc-register-switches' to the backend command."
286   (vc-got--add files))
287 
288 (defalias 'vc-got-responsible-p #'vc-got-root)
289 
290 (defun vc-got-checkin (files comment &optional _rev)
291   "Commit FILES with COMMENT as commit message."
292   (with-temp-buffer
293     (apply #'vc-got--call "commit" "-m" comment files)))
294 
295 (defun vc-got-find-revision (file rev buffer)
296   (when-let (obj-id (assoc file (vc-got--tree rev file) #'string=))
297     (with-current-buffer buffer
298       (vc-got-with-worktree file
299         (vc-got--cat rev obj-id)))))
300 
301 (provide 'vc-got)
302 ;;; vc-got.el ends here