1 ;;; vc-got.el --- VC backend for Game of Trees VCS   -*- lexical-binding: t; -*-
2 
3 ;; Copyright (C) 2021  Free Software Foundation, Inc.
4 
5 ;; Author: Omar Polo <op@omarpolo.com>
6 ;;         Timo Myyrä <timo.myyra@bittivirhe.fi>
7 ;; URL: https://git.omarpolo.com/vc-got/
8 ;; Keywords: vc tools
9 ;; Version: 1.0
10 ;; Package-Requires: ((emacs "25.1"))
11 
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16 
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21 
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
24 
25 ;;; Commentary:
26 
27 ;; This file contains a VC backend for the Game of Trees (got) version
28 ;; control system.
29 
30 ;; Backend implementation status
31 ;;
32 ;; Function marked with `*' are required, those with `-' are optional.
33 ;;
34 ;; FUNCTION NAME                        STATUS
35 ;;
36 ;; BACKEND PROPERTIES:
37 ;; * revision-granularity               DONE
38 ;; - update-on-retrieve-tag             XXX: what should this do?
39 ;;
40 ;; STATE-QUERYING FUNCTIONS:
41 ;; * registered                         DONE
42 ;; * state                              DONE
43 ;; - dir-status-files                   DONE
44 ;; - dir-extra-headers                  DONE
45 ;; - dir-printer                        DONE
46 ;; - status-fileinfo-extra              NOT IMPLEMENTED
47 ;; * working-revision                   DONE
48 ;; * checkout-model                     DONE
49 ;; - mode-line-string                   DONE
50 ;;
51 ;; STATE-CHANGING FUNCTIONS:
52 ;; * create-repo                        NOT IMPLEMENTED
53 ;;      I don't think got init does what this function is supposed to
54 ;;      do.
55 ;; * register                           DONE
56 ;; - responsible-p                      DONE
57 ;; - receive-file                       NOT NEEDED, default `register' is fine
58 ;; - unregister                         DONE
59 ;; * checkin                            DONE
60 ;; * find-revision                      DONE
61 ;; * checkout                           NOT IMPLEMENTED
62 ;;      I'm not sure how to properly implement this.  Does filling
63 ;;      FILE with the find-revision do the trick?  Or use got update?
64 ;; * revert                             DONE
65 ;; - merge-file                         NOT IMPLEMENTED
66 ;; - merge-branch                       DONE
67 ;; - merge-news                         NOT IMPLEMENTED
68 ;; - pull                               DONE
69 ;; - push                               DONE
70 ;; - steal-lock                         NOT NEEDED, `got' is not using locks
71 ;; - modify-change-comment              NOT IMPLEMENTED
72 ;;      can be implemented via histedit, if I understood correctly
73 ;;      what it is supposed to do.
74 ;; - mark-resolved                      NOT NEEDED
75 ;;      got notice by itself when a file doesn't have any pending
76 ;;      conflicts to be resolved.
77 ;; - find-admin-dir                     NOT NEEDED
78 ;;
79 ;; HISTORY FUNCTIONS
80 ;; * print-log                          DONE
81 ;; * log-outgoing                       DONE
82 ;; * log-incoming                       DONE
83 ;; - log-search                         DONE
84 ;; - log-view-mode                      DONE
85 ;; - show-log-entry                     NOT IMPLEMENTED
86 ;; - comment-history                    NOT IMPLEMENTED
87 ;; - update-changelog                   NOT IMPLEMENTED
88 ;; * diff                               DONE
89 ;; - revision-completion-table          DONE
90 ;; - annotate-command                   DONE
91 ;; - annotate-time                      DONE
92 ;; - annotate-current-time              NOT NEEDED
93 ;;      the default time handling is enough.
94 ;; - annotate-extract-revision-at-line  DONE
95 ;; - region-history                     NOT IMPLEMENTED
96 ;; - region-history-mode                NOT IMPLEMENTED
97 ;; - mergebase                          NOT IMPLEMENTED
98 ;;
99 ;; TAG SYSTEM
100 ;; - create-tag                         DONE
101 ;; - retrieve-tag                       DONE
102 ;;
103 ;; MISCELLANEOUS                        NOT IMPLEMENTED
104 ;; - make-version-backups-p             NOT NEEDED, `got' works fine locally
105 ;; - root                               DONE
106 ;; - ignore                             NOT NEEDED, the default action is good
107 ;; - ignore-completion-table            NOT NEEDED, the default action is good
108 ;; - find-ignore-file                   DONE
109 ;; - previous-revision                  DONE
110 ;; - next-revision                      DONE
111 ;; - log-edit-mode                      NOT IMPLEMENTED
112 ;; - check-headers                      NOT NEEDED, `got' does not use headers
113 ;; - delete-file                        DONE
114 ;; - rename-file                        NOT IMPLEMENTED
115 ;; - find-file-hook                     DONE
116 ;; - extra-menu                         NOT IMPLEMENTED
117 ;; - extra-dir-menu                     NOT IMPLEMENTED, same as above
118 ;; - conflicted-files                   DONE
119 ;; - repository-url                     DONE
120 
121 ;; TODO: vc-git has most function that starts with:
122 ;;
123 ;;    (let* ((root (vc-git-root default-directory))
124 ;;           (buffer (format "*vc-git : %s*" (expand-file-name root)))
125 ;;           ...)
126 ;;      ...)
127 ;;
128 ;; we should 1) investigate if also other backends do something like
129 ;; this (or if there is a better way) and 2) try to do the same.
130 
131 ;;; Code:
132 
133 (eval-when-compile
134   (require 'subr-x))
135 
136 (require 'cl-lib)
137 (require 'seq)
138 (require 'vc)
139 (require 'vc-annotate)
140 
141 ;; FIXME: avoid loading this?  We only need it for
142 ;; log-edit-extract-headers in vc-got-checkin.
143 (require 'log-edit)
144 
145 ;; FIXME: avoid loading this?  We only need it for
146 ;; vc-dir-filename-mouse-map in our custom printer.
147 (require 'vc-dir)
148 
149 ;; FIXME: avoid loading this?  We only need it for
150 ;; compilation-{directory,arguments}.
151 (require 'compile)
152 
153 ;; FIXME: avoid loading this?  We only need it for
154 ;; log-view-{file-re,per-file-logs,message-re}.
155 (require 'log-view)
156 
157 (defgroup vc-got nil
158   "VC GoT backend."
159   :group 'vc)
160 
161 (defcustom vc-got-program "got"
162   "Name of the Got executable (excluding any arguments)."
163   :type 'string)
164 
165 (defcustom vc-got-diff-switches t
166   "String or list of strings specifying switches for Got diff under VC.
167 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
168   :type '(choice (const :tag "Unspecified" nil)
169                  (const :tag "None" t)
170                  (string :tag "Argument String")
171                  (repeat :tag "Argument List" :value ("") string)))
172 
173 ;; helpers
174 (defmacro vc-got--with-emacs-version<= (version &rest body)
175   "Eval BODY only when the Emacs version in greater or equal VERSION."
176   (declare (debug body)
177            (indent defun))
178   (when (version<= version emacs-version)
179     `(progn ,@body)))
180 
181 (defun vc-got--program-version ()
182   "Return string representing the got version."
183   (let (process-file-side-effects)
184     (with-temp-buffer
185       (vc-got--call "-V")
186       (substring (buffer-string) 4 -1))))
187 
188 (defun vc-got-root (file)
189   "Return the work tree root for FILE, or nil."
190   (vc-find-root file ".got"))
191 
192 (defmacro vc-got-with-worktree (file &rest body)
193   "Evaluate BODY in the work tree directory of FILE."
194   (declare (debug t) (indent defun))
195   `(when-let (default-directory (vc-got-root ,file))
196      ,@body))
197 
198 (defun vc-got--repo-root ()
199   "Return the path to the repository root.
200 Assume `default-directory' is inside a got worktree."
201   (vc-got-with-worktree default-directory
202     (with-temp-buffer
203       (insert-file-contents ".got/repository")
204       (string-trim (buffer-string) "" "\n"))))
205 
206 (defun vc-got--call (&rest args)
207   "Call `vc-got-program' with ARGS.
208 The output will be placed in the current buffer."
209   (apply #'process-file vc-got-program nil (current-buffer) nil
210          (apply #'nconc (mapcar (lambda (s) (if (listp s) s (list s))) args))))
211 
212 (defun vc-got--add (files)
213   "Add FILES to got, passing `vc-register-switches' to the command invocation."
214   (with-temp-buffer
215     (vc-got--call "add" vc-register-switches "--" files)))
216 
217 (defun vc-got--log (&optional path limit start-commit stop-commit
218                               search-pattern reverse include-diff)
219   "Execute the log command in the worktree of PATH in the current buffer.
220 LIMIT limits the maximum number of commit returned.
221 
222 START-COMMIT: start traversing history at the specified commit.
223 STOP-COMMIT: stop traversing history at the specified commit.
224 SEARCH-PATTERN: limit to log messages matched by the regexp given.
225 REVERSE: display the log messages in reverse order.
226 INCLUDE-DIFF: display the patch of modifications made in each commit.
227 
228 Return nil if the command failed or if PATH isn't included in any
229 worktree."
230   (let ((process-file-side-effects nil))
231     (vc-got-with-worktree (or path default-directory)
232       (when (zerop
233              (save-excursion
234                (vc-got--call "log"
235                              (and limit (list "-l" (format "%s" limit)))
236                              (and start-commit (list "-c" start-commit))
237                              (and stop-commit (list "-x" stop-commit))
238                              (and search-pattern (list "-s" search-pattern))
239                              (and reverse '("-R"))
240                              (and include-diff '("-p"))
241                              ;; "--"
242                              path)))
243         (save-excursion
244           (delete-matching-lines
245            "^-----------------------------------------------$")
246           t)))))
247 
248 (defun vc-got--status (status-codes dir-or-file &optional files)
249   "Return a list of lists '(FILE STATUS STAGE-STATUS).
250 DIR-OR-FILE can be either a directory or a file.  If FILES is
251 given, return the status of those files, otherwise the status of
252 DIR-OR-FILE.  STATUS-CODES is either nil, or a string that's
253 passed as the -s flag to got status to limit the types of status
254 to report (e.g. \"CD\" to report only conflicts and deleted
255 files)."
256   (with-temp-buffer
257     (let* ((default-directory (expand-file-name
258                                (if (file-directory-p dir-or-file)
259                                    dir-or-file
260                                  (file-name-directory dir-or-file))))
261            (root (vc-got-root default-directory))
262            (process-file-side-effects))
263       (when (zerop (vc-got--call "status"
264                                  (and status-codes (list "-s" status-codes))
265                                  "--"
266                                  (or files dir-or-file)))
267         (goto-char (point-min))
268         (cl-loop until (eobp)
269                  collect (vc-got--parse-status-line root)
270                  do (forward-line))))))
271 
272 (defun vc-got--parse-status-line (root)
273   "Parse a line of the the output of status.
274 ROOT is the root of the repo."
275   ;; the format of each line is
276   ;; <status-char> <stage-char> <spc> <filename> \n
277   (let* ((file-status (prog1 (vc-got--parse-status-char
278                               (char-after))
279                         (forward-char)))
280          (stage-status (let* ((c (char-after)))
281                          (prog1
282                              (when (member c '(?M ?A ?D))
283                                c)
284                            (forward-char))))
285          (filename (progn
286                      (forward-char)
287                      (buffer-substring (point)
288                                        (line-end-position)))))
289     (list (file-relative-name (expand-file-name filename root)
290                               default-directory)
291           (or file-status (and stage-status 'up-to-date))
292           stage-status)))
293 
294 (defun vc-got--parse-status-char (c)
295   "Parse status char C into a symbol accepted by `vc-state'."
296   (cl-case c
297     (?M 'edited)
298     (?A 'added)
299     (?D 'removed)
300     (?C 'conflict)
301     (?! 'missing)
302     (?~ 'edited) ; XXX: what does it means for a file to be ``obstructed''?
303     (?? 'unregistered)
304     (?m 'edited) ; modified file modes
305     (?N nil)))
306 
307 (defun vc-got--cat (commit obj-id)
308   "Execute got cat -c COMMIT OBJ-ID in the current buffer."
309   (let (process-file-side-effects)
310     (zerop (vc-got--call "cat" "-c" commit obj-id))))
311 
312 (defun vc-got--revert (&rest files)
313   "Execute got revert FILES."
314   (vc-got-with-worktree (car files)
315     (with-temp-buffer
316       (zerop (vc-got--call "revert" "--" files)))))
317 
318 (defun vc-got--list-branches ()
319   "Return an alist of (branch . commit)."
320   (let (process-file-side-effects)
321     (with-temp-buffer
322       (when (zerop (vc-got--call "branch" "-l"))
323         (let (alist)
324           (goto-char (point-min))
325           (while (re-search-forward "^\\*?[[:space:]]+\\(.+\\): \\([[:word:]]+\\)$"
326                                     nil t)
327             (push (cons (match-string 1) (match-string 2)) alist))
328           alist)))))
329 
330 (defun vc-got--current-branch ()
331   "Return the current branch."
332   (let (process-file-side-effects)
333     (with-temp-buffer
334       (when (zerop (vc-got--call "branch"))
335         (string-trim (buffer-string) "" "\n")))))
336 
337 (defun vc-got--integrate (branch)
338   "Integrate BRANCH into the current one."
339   (with-temp-buffer
340     (zerop (vc-got--call "integrate" branch))))
341 
342 (defun vc-got--update (branch &optional paths)
343   "Update to a different commit or BRANCH.
344 Optionally restrict the update operation to files at or within
345 the specified PATHS."
346   (with-temp-buffer
347     (unless (zerop (vc-got--call "update" "-b" branch "--" paths))
348       (error "[vc-got] can't update to branch %s: %s"
349              branch
350              (buffer-string)))))
351 
352 (defun vc-got--diff-files (&rest files)
353   "Compute the local modifications to FILES."
354   (let (process-file-side-effects)
355     (zerop (vc-got--call "diff" (vc-switches 'got 'diff) "-P" "--"
356                          files))))
357 
358 (defun vc-got--diff-objects (obj1 obj2)
359   "Diff the two objects OBJ1 and OBJ2.
360 OBJ1 and OBJ2 are interpreted as a reference, tag name, or an
361 object ID SHA1 hash."
362   (let (process-file-side-effects)
363     (zerop (vc-got--call "diff" (vc-switches 'got 'diff) "--" obj1 obj2))))
364 
365 (defun vc-got--unstage (file-or-directory)
366   "Unstage all the staged hunks at or within FILE-OR-DIRECTORY.
367 If it's nil, unstage every staged changes across the entire work
368 tree."
369   (zerop (vc-got--call "unstage" "--" file-or-directory)))
370 
371 (defun vc-got--remove (file &optional force keep-local)
372   "Use got to remove FILE.
373 If FORCE is non-nil perform the operation even if a file contains
374 local modification.  If KEEP-LOCAL is non-nil keep the affected
375 files on disk."
376   (vc-got-with-worktree (or file default-directory)
377     (with-temp-buffer
378       (zerop (vc-got--call "remove"
379                            (and force "-f")
380                            (and keep-local "-k")
381                            "--"
382                            file)))))
383 
384 (defun vc-got--ref ()
385   "Return a list of all references."
386   (let ((process-file-side-effects nil)
387         (re "^refs/\\(heads\\|remotes\\|tags\\)/\\(.*\\):")
388         ;; hardcoding HEAD because it's always present and the regexp
389         ;; won't match it.
390         (table (list "HEAD")))
391     (vc-got-with-worktree default-directory
392       (with-temp-buffer
393         (when (zerop (vc-got--call "ref" "-l"))
394           (goto-char (point-min))
395           (while (re-search-forward re nil t)
396             (push (match-string 2) table))
397           table)))))
398 
399 (defun vc-got--branch (name)
400   "Try to create and switch to the branch called NAME."
401   (let (process-file-side-effects)
402     (vc-got-with-worktree default-directory
403       (with-temp-buffer
404         (if (zerop (vc-got--call "branch" "--" name))
405             t
406           (error "[vc-got] can't create branch %s: %s" name
407                  (buffer-string)))))))
408 
409 
410 ;; Backend properties
411 
412 (defun vc-got-revision-granularity ()
413   "Got has REPOSITORY granularity."
414   'repository)
415 
416 (defun vc-got-update-on-retrieve-tag ()
417   "Like vc-git, vc-got don't need to buffers on `retrieve-tag'."
418   nil)
419 
420 
421 ;; State-querying functions
422 
423 ;;;###autoload (defun vc-got-registered (file)
424 ;;;###autoload   "Return non-nil if FILE is registered with got."
425 ;;;###autoload   (when (vc-find-root file ".got")
426 ;;;###autoload     (load "vc-got" nil t)
427 ;;;###autoload     (vc-got-registered file)))
428 
429 (defun vc-got-registered (file)
430   "Return non-nil if FILE is registered with got."
431   (if (file-directory-p file)
432       nil                               ; got doesn't track directories
433     (when (vc-find-root file ".got")
434       (let ((s (vc-got-state file)))
435         (not (or (eq s 'unregistered)
436                  (null s)))))))
437 
438 (defun vc-got-state (file)
439   "Return the current version control state of FILE.  See `vc-state'."
440   (unless (file-directory-p file)
441     (let (process-file-side-effects)
442       ;; Manually calling got status and checking the result inline to
443       ;; avoid building the data structure in vc-got--status.
444       (with-temp-buffer
445         (when (zerop (vc-got--call "status" "--" file))
446           (goto-char (point-min))
447           (if (eobp)
448               'up-to-date
449             (vc-got--parse-status-char (char-after))))))))
450 
451 (defun vc-got--dir-filter-files (files)
452   "Remove ., .. and .got from FILES."
453   (cl-loop for file in files
454            unless (or (string= file "..")
455                       (string= file ".")
456                       (string= file ".got"))
457            collect file))
458 
459 (defun vc-got-dir-status-files (dir files update-function)
460   "Build the status for FILES in DIR.
461 The builded result is given to the callback UPDATE-FUNCTION.  If
462 FILES is nil, consider all the files in DIR."
463   (let* ((fs (vc-got--dir-filter-files (or files (directory-files dir))))
464          ;; XXX: we call with files, wich will probably be nil on the
465          ;; first run, so we catch deleted, missing and edited files
466          ;; in subdirectories.
467          (res (vc-got--status nil dir files))
468          double-check)
469     (cl-loop for file in fs
470              do (when (and (not (cdr (assoc file res #'string=)))
471                            (not (file-directory-p file))
472                            ;; if file doesn't exists, it's a
473                            ;; untracked file that was removed.
474                            (file-exists-p file))
475                   ;; if we don't know the status of a file here, it's
476                   ;; either up-to-date or ignored.  Save it for a
477                   ;; double check
478                   (push file double-check)))
479     (cl-loop with statuses = (vc-got--status nil dir double-check)
480              for file in double-check
481              unless (eq 'unregistered (cadr (assoc file statuses #'string=)))
482              do (push (list file 'up-to-date nil) res))
483     (funcall update-function res nil)))
484 
485 (defun vc-got-dir-extra-headers (dir)
486   "Return a string for the `vc-dir' buffer heading for directory DIR."
487   (let ((remote (vc-got-repository-url dir)))
488     (concat (propertize "Repository : " 'face 'font-lock-type-face)
489             (vc-got--repo-root) "\n"
490             (when remote
491               (concat
492                (propertize "Remote URL : " 'face 'font-lock-type-face)
493                (vc-got-repository-url dir) "\n"))
494             (propertize "Branch     : " 'face 'font-lock-type-face)
495             (vc-got--current-branch))))
496 
497 (defun vc-got-dir-printer (info)
498   "Pretty-printer for the vc-dir-fileinfo structure INFO."
499   (let* ((isdir (vc-dir-fileinfo->directory info))
500          (state (if isdir "" (vc-dir-fileinfo->state info)))
501          (stage-state (vc-dir-fileinfo->extra info))
502          (filename (vc-dir-fileinfo->name info)))
503     (insert
504      "  "
505      (propertize
506       (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
507       'face 'font-lock-type-face)
508      "  "
509      (propertize
510       (format "%-12s" state)
511       'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
512                   ((memq state '(missing conflict)) 'font-lock-warning-face)
513                   ((eq state 'edited) 'font-lock-constant-face)
514                   (t 'font-lock-variable-name-face))
515       'mouse-face 'highlight
516       'keymap (vc-got--with-emacs-version<= "28.0.50"
517                 vc-dir-status-mouse-map))
518 
519      "   " (propertize
520             (if stage-state
521                 (format "%c" stage-state)
522               " ")
523             'face (cond ((memq stage-state '(?A ?E)) 'font-lock-constant-face)
524                         ((eq stage-state ?R) 'font-lock-warning-face)
525                         (t 'font-lock-variable-name-face)))
526      "    "
527      (propertize filename
528                  'face (if isdir 'font-lock-comment-delimiter-face
529                          'font-lock-function-name-face)
530                  'help-echo
531                  (if isdir
532                      (concat
533                       "Directory\n"
534                       "VC operations can be applied to it\n"
535                       "mouse-3: Pop-up menu")
536                    "File\nmouse-3: Pop-up menu")
537                  'mouse-face 'highlight
538                  'keymap vc-dir-filename-mouse-map))))
539 
540 (defun vc-got-working-revision (file)
541   "Return the last commit that touched FILE or \"0\" if it's newly added."
542   (or
543    (with-temp-buffer
544      (when (vc-got--log file 1)
545        (let (start)
546          (goto-char (point-min))
547          (forward-word)                 ; skip "commit"
548          (forward-char)                 ; skip the space
549          (setq start (point))           ; store start of the SHA
550          (forward-word)                 ; goto SHA end
551          (buffer-substring start (point)))))
552    ;; special case: if this file is added but has no previous commits
553    ;; touching it, got log will fail (as expected), but we have to
554    ;; return "0".
555    (when (eq (vc-got-state file) 'added)
556      "0")))
557 
558 (defun vc-got-checkout-model (_files)
559   "Return the checkout model.
560 Got uses an implicit checkout model for every file."
561   'implicit)
562 
563 (defun vc-got-mode-line-string (file)
564   "Return the VC mode line string for FILE."
565   (vc-got-with-worktree file
566     (let ((def (vc-default-mode-line-string 'Got file)))
567       (concat (substring def 0 4) (vc-got--current-branch)))))
568 
569 
570 ;; state-changing functions
571 
572 (defun vc-got-create-repo (_backend)
573   "Create an empty repository in the current directory."
574   (error "[vc-got] create-repo not implemented"))
575 
576 (defun vc-got-register (files &optional _comment)
577   "Register FILES, passing `vc-register-switches' to the backend command."
578   (vc-got--add files))
579 
580 (defalias 'vc-got-responsible-p #'vc-got-root)
581 
582 (defun vc-got-unregister (file)
583   "Unregister FILE."
584   (vc-got--remove file t t))
585 
586 (defun vc-got-checkin (files comment &optional _rev)
587   "Commit FILES with COMMENT as commit message."
588   (with-temp-buffer
589     (unless (zerop (vc-got--call "commit" "-m"
590                                  (log-edit-extract-headers nil comment)
591                                  "--"
592                                  files))
593       (error "[vc-got] can't commit: %s" (buffer-string)))))
594 
595 (defun vc-got-find-revision (file rev buffer)
596   "Fill BUFFER with the content of FILE in the given revision REV."
597   (with-current-buffer buffer
598     (vc-got-with-worktree file
599       (vc-got--cat rev (file-relative-name file)))))
600 
601 (defun vc-got-checkout (_file &optional _rev)
602   "Checkout revision REV of FILE.
603 If REV is t, checkout from the head."
604   (error "[vc-got] checkout not implemented"))
605 
606 (defun vc-got-revert (file &optional _content-done)
607   "Revert FILE back to working revision."
608   (vc-got--revert file))
609 
610 (defun vc-got-merge-branch ()
611   "Prompt for a branch and integrate it into the current one."
612   ;; XXX: be smart and try to "got rebase" if "got integrate" fails?
613   (let* ((branches (cl-loop for (branch . commit) in (vc-got--list-branches)
614                             collect branch))
615          (branch (completing-read "Merge from branch: " branches)))
616     (when branch
617       (vc-got--integrate branch))))
618 
619 (defun vc-got--proc-filter (proc s)
620   "Custom output filter for async process PROC.
621 It's like `vc-process-filter' but supports \r inside S."
622   (let ((buffer (process-buffer proc)))
623     (when (buffer-live-p buffer)
624       (with-current-buffer buffer
625         (save-excursion
626           (let ((buffer-undo-list t)
627                 (inhibit-read-only t))
628             (goto-char (process-mark proc))
629             (if (not (string-match ".*\r\\(.*\\)" s))
630                 (insert s)
631               ;; handle \r
632               (end-of-line)
633               (let ((end (point)))
634                 (beginning-of-line)
635                 (delete-region (point) end))
636               (insert (match-string 1 s)))
637             (set-marker (process-mark proc) (point))))))))
638 
639 (defun vc-got--push-pull (cmd op prompt)
640   "Execute CMD OP, or prompt the user if PROMPT is non-nil."
641   (let ((buffer (format "*vc-got : %s*" (expand-file-name default-directory))))
642     (when-let (cmd (if prompt
643                        (split-string
644                         (read-shell-command (format "%s %s command: " cmd op)
645                                             (format "%s %s " cmd op))
646                         " " t)
647                      (list cmd op)))
648       (apply #'vc-do-async-command buffer default-directory cmd)
649       ;; this comes from vc-git.el.  We're using git to push, so in
650       ;; part it makes sense, but we should revisit for full Got
651       ;; support.
652       (with-current-buffer buffer
653         (vc-compilation-mode 'got)
654         (let ((comp-cmd (mapconcat #'identity cmd " "))
655               (proc (get-buffer-process buffer)))
656           (setq-local compile-command comp-cmd)
657           (setq-local compilation-directory default-directory)
658           (setq-local compilation-arguments (list comp-cmd
659                                                   nil
660                                                   (lambda (_ign) buffer)
661                                                   nil))
662           ;; Setup a custom process filter that handles \r.
663           (set-process-filter proc #'vc-got--proc-filter)))
664       (vc-set-async-update buffer))))
665 
666 ;; TODO: this could be expanded.  After a pull the worktree needs to
667 ;; be updated, either with a ``got update -b branch-name'' and
668 ;; eventually a rebase.
669 (defun vc-got-pull (prompt)
670   "Execute a pull prompting for the full command if PROMPT is not nil."
671   (vc-got--push-pull vc-got-program "fetch" prompt))
672 
673 (defun vc-got-push (prompt)
674   "Run git push (not got!) in the repository dir.
675 If PROMPT is non-nil, prompt for the git command to run."
676   (vc-got--push-pull vc-got-program "send" prompt))
677 
678 
679 ;; History functions
680 
681 (defun vc-got-print-log (files buffer &optional _shortlog start-revision limit)
682   "Insert the revision log for FILES into BUFFER.
683 LIMIT limits the number of commits, optionally starting at
684 START-REVISION."
685   (with-current-buffer buffer
686     ;; the *vc-diff* may be read only
687     (let ((inhibit-read-only t))
688       (cl-loop for file in files
689                do (vc-got--log (file-relative-name file)
690                                limit
691                                start-revision)))))
692 
693 (defun vc-got-log-outgoing (buffer remote-location)
694   "Fill BUFFER with the diff between the local worktree branch and REMOTE-LOCATION."
695   (vc-setup-buffer buffer)
696   (let ((rl (vc-got-next-revision
697              nil
698              (if (or (not remote-location) (string-empty-p remote-location))
699                  (concat "origin/" (vc-got--current-branch))
700                remote-location)))
701         (inhibit-read-only t))
702     (with-current-buffer buffer
703       (vc-got--log nil nil nil rl))))
704 
705 (defun vc-got-incoming (buffer remote-location)
706   "Fill BUFFER with the diff between the REMOTE-LOCATION and the local worktree branch."
707   (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
708                 (concat "origin/" (vc-got--current-branch))
709               remote-location))
710         (inhibit-read-only t))
711     (with-current-buffer buffer
712       (vc-got--log nil nil (vc-got--current-branch) rl))))
713 
714 (defun vc-got-log-search (buffer pattern)
715   "Search commits for PATTERN and write the results found in BUFFER."
716   (with-current-buffer buffer
717     (let ((inhibit-read-only t))
718       (vc-got--log nil nil nil nil pattern))))
719 
720 (define-derived-mode vc-got-log-view-mode log-view-mode "Got-Log-View"
721   "Got-specific log-view mode.
722 Heavily inspired by `vc-git-log-view-mode'."
723   (require 'add-log)
724   (setq-local log-view-file-re regexp-unmatchable)
725   (setq-local log-view-per-file-logs nil)
726   (setq-local log-view-message-re "^commit +\\([0-9a-z]+\\)")
727   (setq-local log-view-font-lock-keywords
728               (append
729                `((,log-view-message-re (1 'change-log-acknowledgment)))
730                ;; Handle the case:
731                ;; user: foo@bar
732                '(("^from: \\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
733                   (1 'change-log-email))
734                  ;; Handle the case:
735                  ;; user: FirstName LastName <foo@bar>
736                  ("^from: \\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
737                   (1 'change-log-name)
738                   (2 'change-log-email))
739                  ("^date: \\(.+\\)" (1 'change-log-date))))))
740 
741 ;; TODO: async
742 ;; TODO: return 0 or 1
743 (defun vc-got-diff (files &optional rev1 rev2 buffer _async)
744   "Insert into BUFFER (or *vc-diff*) the diff for FILES from REV1 to REV2."
745   (let* ((buffer (get-buffer-create (or buffer "*vc-diff*")))
746          (inhibit-read-only t))
747     (with-current-buffer buffer
748       (vc-got-with-worktree (or (car files)
749                                 default-directory)
750         (cond ((and (null rev1)
751                     (null rev2))
752                (apply #'vc-got--diff-files files))
753               ((and (null rev1)
754                     rev2)
755                ;; TODO: this includes the whole diff while to respect
756                ;; the vc semantics we should filter only the diff for
757                ;; files in FILES.
758                ;;
759                ;; XXX: this includes also the commit message, I
760                ;; consider it a feature over the usual vc behaviour of
761                ;; showing only the diff.
762                (vc-got--log nil 1 rev2 nil nil nil t))
763               ;;
764               ;; TODO: if rev1 is nil, diff from the current version until
765               ;; rev2.
766               ;;
767               ;; TODO 2: if rev2 is nil as well, diff against an empty
768               ;; tree (i.e. get the patch from `got log -p rev1')
769               (t (vc-got--diff-objects rev1 rev2)))))))
770 
771 (defun vc-got-revision-completion-table (_files)
772   "Return a completion table for existing revisions.
773 Ignores FILES because GoT doesn't have the concept of ``file
774 revisions''; instead, like with git, you have tags and branches."
775   (letrec ((table (lazy-completion-table
776                    table (lambda () (vc-got--ref)))))
777     table))
778 
779 (defun vc-got-annotate-command (file buf &optional rev)
780   "Show annotated contents of FILE in buffer BUF.  If given, use revision REV."
781   (let (process-file-side-effects)
782     (with-current-buffer buf
783       ;; FIXME: vc-ensure-vc-buffer won't recognise this buffer as managed
784       ;; by got unless vc-parent-buffer points to a buffer managed by got.
785       ;; investigate why this is needed.
786       (setq-local vc-parent-buffer (find-file-noselect file))
787       (vc-got--call "blame"
788                     (when rev (list "-c" rev))
789                     "--"
790                     file))))
791 
792 (defconst vc-got--annotate-re
793   (concat "^[0-9]\\{1,\\}) " ; line number followed by )
794           "\\([a-z0-9]+\\) " ; SHA-1 of commit
795           "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\) " ; year-mm-dd
796           "\\([^ ]\\)+ ")    ; author
797   "Regexp to match annotation output lines.
798 
799 Provides capture groups for:
800 1. revision id
801 2. date of commit
802 3. author of commit")
803 
804 (defconst vc-got--commit-re "^commit \\([a-z0-9]+\\)"
805   "Regexp to match commit lines.
806 Provides capture group for the commit revision id.")
807 
808 (defun vc-got-annotate-time ()
809   "Return the time of the next line of annotation at or after point.
810 Value is returned as floating point fractional number of days."
811   ;; XXX: to behave like vc-git here we should call re-search-forward
812   ;; instead of looking-at, as it makes the fontification of the line
813   ;; start AFTER the info.  The problem is, due to the format of the
814   ;; blame, it produces an ugly result, with colors starting at
815   ;; different offsets depending on how long the commiter name is.
816   (when (looking-at vc-got--annotate-re)
817     (let ((str (match-string-no-properties 2)))
818       (vc-annotate-convert-time
819        (encode-time 0 0 0
820                     (string-to-number (substring str 8 10))
821                     (string-to-number (substring str 5 7))
822                     (string-to-number (substring str 0 4)))))))
823 
824 (defun vc-got-annotate-extract-revision-at-line ()
825   "Return revision corresponding to the current line or nil."
826   (save-excursion
827     (beginning-of-line)
828     (when (looking-at vc-got--annotate-re)
829       (match-string-no-properties 1))))
830 
831 
832 ;; Tag system
833 
834 (defun vc-got--tag-callback (tag)
835   "`log-edit' callback for `vc-got-create-tag'.
836 Creates the TAG using the content of the current buffer."
837   (interactive)
838   (let ((msg (buffer-substring-no-properties (point-min)
839                                              (point-max))))
840     (with-temp-buffer
841       (unless (zerop (vc-got--call "tag"
842                                    "-m"
843                                    (log-edit-extract-headers nil msg)
844                                    "--"
845                                    tag))
846         (error "[vc-got] can't create tag %s: %s" tag (buffer-string))))))
847 
848 (defun vc-got-create-tag (_dir name branchp)
849   "Attach the tag NAME to the state of the worktree.
850 DIR is ignored (tags are global, not per-file).  If BRANCHP is
851 true, NAME should create a new branch otherwise it will pop-up a
852 `log-edit' buffer to provide the tag message."
853   ;; TODO: vc reccomends to ensure that all the file are in a clean
854   ;; state, but is it useful?
855   (if branchp
856       (vc-got--branch name)
857     (let ((buf (get-buffer-create "*vc-got tag*")))
858       (with-current-buffer buf
859         (erase-buffer)
860         (save-excursion
861           (insert "Summary: tag " name "\n\n"))
862         (move-end-of-line 1)
863         (switch-to-buffer buf)
864         (log-edit (lambda ()
865                     (interactive)
866                     (unwind-protect
867                         (vc-got--tag-callback name)
868                       (kill-buffer buf))))))))
869 
870 (defun vc-got-retrieve-tag (dir name _update)
871   "Switch to the tag NAME for files at or below DIR."
872   (let ((default-directory dir))
873     (vc-got--update name dir)))
874 
875 
876 ;; Miscellaneous
877 
878 (defun vc-got-find-ignore-file (file)
879   "Return the gitignore file that controls FILE."
880   (expand-file-name ".gitignore"
881                     (vc-got-root file)))
882 
883 (defun vc-got-previous-revision (file rev)
884   "Return the revision number that precedes REV for FILE or nil."
885   (with-temp-buffer
886     (vc-got--log file 2 rev nil nil t)
887     (goto-char (point-min))
888     (keep-lines "^commit")
889     (when (looking-at vc-got--commit-re)
890       (match-string-no-properties 1))))
891 
892 (defun vc-got-next-revision (file rev)
893   "Return the revision number that follows REV for FILE or nil."
894   (with-temp-buffer
895     (vc-got--log file nil nil rev)
896     (keep-lines "^commit" (point-min) (point-max))
897     (goto-char (point-max))
898     (forward-line -1)    ; return from empty line to last actual commit
899     (unless (= (point) (point-min))
900       (forward-line -1)
901       (when (looking-at vc-got--commit-re)
902         (match-string-no-properties 1)))))
903 
904 (defun vc-got-delete-file (file)
905   "Delete FILE locally and mark it deleted in work tree."
906   (vc-got--remove file t))
907 
908 (defun vc-got-find-file-hook ()
909   "Activate `smerge-mode' if there is a conflict."
910   ;; just like vc-git-find-file-hook
911   (when (and buffer-file-name
912              (eq (vc-state buffer-file-name 'Got) 'conflict)
913              (save-excursion
914                (goto-char (point-min))
915                (re-search-forward "^<<<<<<< " nil 'noerror)))
916     (smerge-start-session)
917     (vc-message-unresolved-conflicts buffer-file-name)))
918 
919 (defun vc-got-conflicted-files (dir)
920   "Return the list of files with conflicts in directory DIR."
921   (let* ((root (vc-got-root dir))
922          (default-directory root)
923          (process-file-side-effects nil))
924     (cl-loop for (file status _) in (vc-got--status "C" ".")
925              when (and (eq status 'conflict)
926                        (file-in-directory-p file dir))
927              collect file)))
928 
929 (defun vc-got-repository-url (_file &optional remote-name)
930   "Return URL for REMOTE-NAME, or for \"origin\" if nil."
931   (let* ((default-directory (vc-got--repo-root))
932          (remote-name (or remote-name "origin"))
933          (heading (concat "[remote \"" remote-name "\"]"))
934          (conf (cond ((file-exists-p ".git/config") ".git/config")
935                      ((file-exists-p ".git")        nil)
936                      ((file-exists-p "config")      "config")))
937          found)
938     (when conf
939       (with-temp-buffer
940         (insert-file-contents conf)
941         (goto-char (point-min))
942         (when (search-forward heading nil t)
943           (forward-line)
944           (while (and (not found)
945                       (looking-at ".*=") ; too broad?
946                       (not (= (point) (point-max))))
947             (when (looking-at ".*url = \\(.*\\)")
948               (setq found (match-string-no-properties 1)))
949             (forward-line))
950           found)))))
951 
952 
953 
954 ;; Automatically register the backend and add ".got" to the exclusion
955 ;; list.
956 
957 ;;;###autoload
958 (add-to-list 'vc-handled-backends 'Got)
959 
960 ;;;###autoload
961 (add-to-list 'vc-directory-exclusion-list ".got")
962 
963 (provide 'vc-got)
964 ;;; vc-got.el ends here