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