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 "27.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 (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          (cl-remove-if #'null (flatten-list 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)
231     (vc-got-with-worktree (or path default-directory)
232       (when (zerop
233              (save-excursion
234                (vc-got--call "log"
235                              (when limit (list "-l" (format "%s" limit)))
236                              (when start-commit (list "-c" start-commit))
237                              (when stop-commit (list "-x" stop-commit))
238                              (when search-pattern (list "-s" search-pattern))
239                              (when 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                                  (when 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--tree-parse ()
307   "Parse into an alist the output of got tree -i in the current buffer."
308   (goto-char (point-min))
309   (cl-loop
310    until (= (point) (point-max))
311    collect (let* ((obj-start (point))
312                   (_ (forward-word))
313                   (obj (buffer-substring obj-start (point)))
314                   (_ (forward-char))         ; skip the space
315                   (filename-start (point))
316                   (_ (move-end-of-line nil))
317                   (filename (buffer-substring filename-start (point))))
318              ;; goto the start of the next line
319              (forward-line)
320              (move-beginning-of-line nil)
321              `(,filename . ,obj))))
322 
323 (defun vc-got--tree (commit path)
324   "Return an alist representing the got tree command output.
325 The outputted tree will be localised in the given PATH at the
326 given COMMIT."
327   (vc-got-with-worktree path
328     (let (process-file-side-effects)
329       (with-temp-buffer
330         (when (zerop (vc-got--call "tree" "-c" commit "-i" "--" path))
331           (vc-got--tree-parse))))))
332 
333 (defun vc-got--cat (commit obj-id)
334   "Execute got cat -c COMMIT OBJ-ID in the current buffer."
335   (let (process-file-side-effects)
336     (zerop (vc-got--call "cat" "-c" commit obj-id))))
337 
338 (defun vc-got--revert (&rest files)
339   "Execute got revert FILES."
340   (vc-got-with-worktree (car files)
341     (with-temp-buffer
342       (zerop (vc-got--call "revert" "--" files)))))
343 
344 (defun vc-got--list-branches ()
345   "Return an alist of (branch . commit)."
346   (let (process-file-side-effects)
347     (with-temp-buffer
348       (when (zerop (vc-got--call "branch" "-l"))
349         (goto-char (point-min))
350         (cl-loop
351          until (= (point) (point-max))
352          ;; parse the `* $branchname: $commit', from the end
353          ;; XXX: use a regex?
354          collect (let* ((_ (move-end-of-line nil))
355                         (end-commit (point))
356                         (_ (backward-word))
357                         (start-commit (point))
358                         (_ (backward-char 2))
359                         (end-branchname (point))
360                         (_ (move-beginning-of-line nil))
361                         (_ (forward-char 2))
362                         (start-branchname (point))
363                         (branchname (buffer-substring start-branchname
364                                                       end-branchname))
365                         (commit (buffer-substring start-commit end-commit)))
366                    (forward-line)
367                    (move-beginning-of-line nil)
368                    `(,branchname . ,commit)))))))
369 
370 (defun vc-got--current-branch ()
371   "Return the current branch."
372   (let (process-file-side-effects)
373     (with-temp-buffer
374       (when (zerop (vc-got--call "branch"))
375         (string-trim (buffer-string) "" "\n")))))
376 
377 (defun vc-got--integrate (branch)
378   "Integrate BRANCH into the current one."
379   (with-temp-buffer
380     (zerop (vc-got--call "integrate" branch))))
381 
382 (defun vc-got--update (branch &optional paths)
383   "Update to a different commit or BRANCH.
384 Optionally restrict the update operation to files at or within
385 the specified PATHS."
386   (with-temp-buffer
387     (unless (zerop (vc-got--call "update" "-b" branch "--" paths))
388       (error "[vc-got] can't update to branch %s: %s"
389              branch
390              (buffer-string)))))
391 
392 (defun vc-got--diff (&rest files)
393   "Call got diff against FILES.
394 The result will be stored in the current buffer."
395   (let (process-file-side-effects)
396     (zerop (vc-got--call "diff"
397                          (vc-switches 'got 'diff)
398                          "--"
399                          (mapcar #'file-relative-name files)))))
400 
401 (defun vc-got--unstage (file-or-directory)
402   "Unstage all the staged hunks at or within FILE-OR-DIRECTORY.
403 If it's nil, unstage every staged changes across the entire work
404 tree."
405   (zerop (vc-got--call "unstage" "--" file-or-directory)))
406 
407 (defun vc-got--remove (file &optional force keep-local)
408   "Use got to remove FILE.
409 If FORCE is non-nil perform the operation even if a file contains
410 local modification.  If KEEP-LOCAL is non-nil keep the affected
411 files on disk."
412   (vc-got-with-worktree (or file default-directory)
413     (with-temp-buffer
414       (zerop (vc-got--call "remove"
415                            (when force "-f")
416                            (when keep-local "-k")
417                            "--"
418                            file)))))
419 
420 (defun vc-got--ref ()
421   "Return a list of all references."
422   (let (process-file-side-effects
423         (re "^refs/\\(heads\\|remotes\\|tags\\)/\\(.*\\):")
424         ;; hardcoding HEAD because it's always present and the regexp
425         ;; won't match it.
426         (table (list "HEAD")))
427     (vc-got-with-worktree default-directory
428       (with-temp-buffer
429         (when (zerop (vc-got--call "ref" "-l"))
430           (goto-char (point-min))
431           (while (re-search-forward re nil t)
432             (push (match-string 2) table))
433           table)))))
434 
435 (defun vc-got--branch (name)
436   "Try to create and switch to the branch called NAME."
437   (let (process-file-side-effects)
438     (vc-got-with-worktree default-directory
439       (with-temp-buffer
440         (if (zerop (vc-got--call "branch" "--" name))
441             t
442           (error "[vc-got] can't create branch %s: %s" name
443                  (buffer-string)))))))
444 
445 
446 ;; Backend properties
447 
448 (defun vc-got-revision-granularity ()
449   "Got has REPOSITORY granularity."
450   'repository)
451 
452 (defun vc-got-update-on-retrieve-tag ()
453   "Like vc-git, vc-got don't need to buffers on `retrieve-tag'."
454   nil)
455 
456 
457 ;; State-querying functions
458 
459 ;;;###autoload (defun vc-got-registered (file)
460 ;;;###autoload   "Return non-nil if FILE is registered with got."
461 ;;;###autoload   (when (vc-find-root file ".got")
462 ;;;###autoload     (load "vc-got" nil t)
463 ;;;###autoload     (vc-got-registered file)))
464 
465 (defun vc-got-registered (file)
466   "Return non-nil if FILE is registered with got."
467   (if (file-directory-p file)
468       nil                               ; got doesn't track directories
469     (when (vc-find-root file ".got")
470       (let ((s (vc-got-state file)))
471         (not (or (eq s 'unregistered)
472                  (null s)))))))
473 
474 (defun vc-got-state (file)
475   "Return the current version control state of FILE.  See `vc-state'."
476   (unless (file-directory-p file)
477     (let (process-file-side-effects)
478       ;; Manually calling got status and checking the result inline to
479       ;; avoid building the data structure in vc-got--status.
480       (with-temp-buffer
481         (when (zerop (vc-got--call "status" "--" file))
482           (goto-char (point-min))
483           (if (eobp)
484               'up-to-date
485             (vc-got--parse-status-char (char-after))))))))
486 
487 (defun vc-got--dir-filter-files (files)
488   "Remove ., .. and .got from FILES."
489   (cl-loop for file in files
490            unless (or (string= file "..")
491                       (string= file ".")
492                       (string= file ".got"))
493            collect file))
494 
495 (defun vc-got-dir-status-files (dir files update-function)
496   "Build the status for FILES in DIR.
497 The builded result is given to the callback UPDATE-FUNCTION.  If
498 FILES is nil, consider all the files in DIR."
499   (let* ((fs (vc-got--dir-filter-files (or files (directory-files dir))))
500          ;; XXX: we call with files, wich will probably be nil on the
501          ;; first run, so we catch deleted, missing and edited files
502          ;; in subdirectories.
503          (res (vc-got--status nil dir files))
504          double-check)
505     (cl-loop for file in fs
506              do (when (and (not (cdr (assoc file res #'string=)))
507                            (not (file-directory-p file))
508                            ;; if file doesn't exists, it's a
509                            ;; untracked file that was removed.
510                            (file-exists-p file))
511                   ;; if we don't know the status of a file here, it's
512                   ;; either up-to-date or ignored.  Save it for a
513                   ;; double check
514                   (push file double-check)))
515     (cl-loop with statuses = (vc-got--status nil dir double-check)
516              for file in double-check
517              unless (eq 'unregistered (cadr (assoc file statuses #'string=)))
518              do (push (list file 'up-to-date nil) res))
519     (funcall update-function res nil)))
520 
521 (defun vc-got-dir-extra-headers (dir)
522   "Return a string for the `vc-dir' buffer heading for directory DIR."
523   (let ((remote (vc-got-repository-url dir)))
524     (concat (propertize "Repository : " 'face 'font-lock-type-face)
525             (vc-got--repo-root) "\n"
526             (when remote
527               (concat
528                (propertize "Remote URL : " 'face 'font-lock-type-face)
529                (vc-got-repository-url dir) "\n"))
530             (propertize "Branch     : " 'face 'font-lock-type-face)
531             (vc-got--current-branch))))
532 
533 (defun vc-got-dir-printer (info)
534   "Pretty-printer for the vc-dir-fileinfo structure INFO."
535   (let* ((isdir (vc-dir-fileinfo->directory info))
536          (state (if isdir "" (vc-dir-fileinfo->state info)))
537          (stage-state (vc-dir-fileinfo->extra info))
538          (filename (vc-dir-fileinfo->name info)))
539     (insert
540      "  "
541      (propertize
542       (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
543       'face 'font-lock-type-face)
544      "  "
545      (propertize
546       (format "%-12s" state)
547       'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
548                   ((memq state '(missing conflict)) 'font-lock-warning-face)
549                   ((eq state 'edited) 'font-lock-constant-face)
550                   (t 'font-lock-variable-name-face))
551       'mouse-face 'highlight
552       'keymap (vc-got--with-emacs-version<= "28.0.50"
553                 vc-dir-status-mouse-map))
554 
555      "   " (propertize
556             (if stage-state
557                 (format "%c" stage-state)
558               " ")
559             'face (cond ((memq stage-state '(?A ?E)) 'font-lock-constant-face)
560                         ((eq stage-state ?R) 'font-lock-warning-face)
561                         (t 'font-lock-variable-name-face)))
562      "    "
563      (propertize filename
564                  'face (if isdir 'font-lock-comment-delimiter-face
565                          'font-lock-function-name-face)
566                  'help-echo
567                  (if isdir
568                      (concat
569                       "Directory\n"
570                       "VC operations can be applied to it\n"
571                       "mouse-3: Pop-up menu")
572                    "File\nmouse-3: Pop-up menu")
573                  'mouse-face 'highlight
574                  'keymap vc-dir-filename-mouse-map))))
575 
576 (defun vc-got-working-revision (file)
577   "Return the last commit that touched FILE or \"0\" if it's newly added."
578   (or
579    (with-temp-buffer
580      (when (vc-got--log file 1)
581        (let (start)
582          (goto-char (point-min))
583          (forward-word)                 ; skip "commit"
584          (forward-char)                 ; skip the space
585          (setq start (point))           ; store start of the SHA
586          (forward-word)                 ; goto SHA end
587          (buffer-substring start (point)))))
588    ;; special case: if this file is added but has no previous commits
589    ;; touching it, got log will fail (as expected), but we have to
590    ;; return "0".
591    (when (eq (vc-got-state file) 'added)
592      "0")))
593 
594 (defun vc-got-checkout-model (_files)
595   "Return the checkout model.
596 Got uses an implicit checkout model for every file."
597   'implicit)
598 
599 (defun vc-got-mode-line-string (file)
600   "Return the VC mode line string for FILE."
601   (vc-got-with-worktree file
602     (let ((def (vc-default-mode-line-string 'Got file)))
603       (concat (substring def 0 4) (vc-got--current-branch)))))
604 
605 
606 ;; state-changing functions
607 
608 (defun vc-got-create-repo (_backend)
609   "Create an empty repository in the current directory."
610   (error "[vc-got] create-repo not implemented"))
611 
612 (defun vc-got-register (files &optional _comment)
613   "Register FILES, passing `vc-register-switches' to the backend command."
614   (vc-got--add files))
615 
616 (defalias 'vc-got-responsible-p #'vc-got-root)
617 
618 (defun vc-got-unregister (file)
619   "Unregister FILE."
620   (vc-got--remove file t t))
621 
622 (defun vc-got-checkin (files comment &optional _rev)
623   "Commit FILES with COMMENT as commit message."
624   (with-temp-buffer
625     (unless (zerop (vc-got--call "commit" "-m"
626                                  (log-edit-extract-headers nil comment)
627                                  "--"
628                                  files))
629       (error "[vc-got] can't commit: %s" (buffer-string)))))
630 
631 (defun vc-got-find-revision (file rev buffer)
632   "Fill BUFFER with the content of FILE in the given revision REV."
633   (when-let (obj-id (assoc file (vc-got--tree rev file) #'string=))
634     (with-current-buffer buffer
635       (vc-got-with-worktree file
636         (vc-got--cat rev obj-id)))))
637 
638 (defun vc-got-checkout (_file &optional _rev)
639   "Checkout revision REV of FILE.
640 If REV is t, checkout from the head."
641   (error "[vc-got] checkout not implemented"))
642 
643 (defun vc-got-revert (file &optional _content-done)
644   "Revert FILE back to working revision."
645   (vc-got--revert file))
646 
647 (defun vc-got-merge-branch ()
648   "Prompt for a branch and integrate it into the current one."
649   ;; XXX: be smart and try to "got rebase" if "got integrate" fails?
650   (let* ((branches (cl-loop for (branch . commit) in (vc-got--list-branches)
651                             collect branch))
652          (branch (completing-read "Merge from branch: " branches)))
653     (when branch
654       (vc-got--integrate branch))))
655 
656 (defun vc-got--proc-filter (proc s)
657   "Custom output filter for async process PROC.
658 It's like `vc-process-filter' but supports \r inside S."
659   (let ((buffer (process-buffer proc)))
660     (when (buffer-live-p buffer)
661       (with-current-buffer buffer
662         (save-excursion
663           (let ((buffer-undo-list t)
664                 (inhibit-read-only t))
665             (goto-char (process-mark proc))
666             (if (not (string-match ".*\r\\(.*\\)" s))
667                 (insert s)
668               ;; handle \r
669               (end-of-line)
670               (let ((end (point)))
671                 (beginning-of-line)
672                 (delete-region (point) end))
673               (insert (match-string 1 s)))
674             (set-marker (process-mark proc) (point))))))))
675 
676 (defun vc-got--push-pull (cmd op prompt)
677   "Execute CMD OP, or prompt the user if PROMPT is non-nil."
678   (let ((buffer (format "*vc-got : %s*" (expand-file-name default-directory))))
679     (when-let (cmd (if prompt
680                        (split-string
681                         (read-shell-command (format "%s %s command: " cmd op)
682                                             (format "%s %s " cmd op))
683                         " " t)
684                      (list cmd op)))
685       (apply #'vc-do-async-command buffer default-directory cmd)
686       ;; this comes from vc-git.el.  We're using git to push, so in
687       ;; part it makes sense, but we should revisit for full Got
688       ;; support.
689       (with-current-buffer buffer
690         (vc-compilation-mode 'got)
691         (let ((comp-cmd (mapconcat #'identity cmd " "))
692               (proc (get-buffer-process buffer)))
693           (setq-local compile-command comp-cmd)
694           (setq-local compilation-directory default-directory)
695           (setq-local compilation-arguments (list comp-cmd
696                                                   nil
697                                                   (lambda (_ign) buffer)
698                                                   nil))
699           ;; Setup a custom process filter that handles \r.
700           (set-process-filter proc #'vc-got--proc-filter)))
701       (vc-set-async-update buffer))))
702 
703 ;; TODO: this could be expanded.  After a pull the worktree needs to
704 ;; be updated, either with a ``got update -b branch-name'' and
705 ;; eventually a rebase.
706 (defun vc-got-pull (prompt)
707   "Execute a pull prompting for the full command if PROMPT is not nil."
708   (let ((default-directory (vc-got-root default-directory)))
709     (vc-got--push-pull vc-got-program "fetch" prompt)))
710 
711 (defun vc-got-push (prompt)
712   "Run git push (not got!) in the repository dir.
713 If PROMPT is non-nil, prompt for the git command to run."
714   (let ((default-directory (vc-got--repo-root)))
715     (vc-got--push-pull vc-got-program "send" prompt)))
716 
717 
718 ;; History functions
719 
720 (defun vc-got-print-log (files buffer &optional _shortlog start-revision limit)
721   "Insert the revision log for FILES into BUFFER.
722 LIMIT limits the number of commits, optionally starting at
723 START-REVISION."
724   (with-current-buffer buffer
725     ;; the *vc-diff* may be read only
726     (let ((inhibit-read-only t))
727       (cl-loop for file in files
728                do (vc-got--log (file-relative-name file)
729                                limit
730                                start-revision)))))
731 
732 (defun vc-got-log-outgoing (buffer remote-location)
733   "Fill BUFFER with the diff between the local worktree branch and REMOTE-LOCATION."
734   (vc-setup-buffer buffer)
735   (let ((rl (vc-got-next-revision
736              nil
737              (if (or (not remote-location) (string-empty-p remote-location))
738                  (concat "origin/" (vc-got--current-branch))
739                remote-location)))
740         (inhibit-read-only t))
741     (with-current-buffer buffer
742       (vc-got--log nil nil nil rl))))
743 
744 (defun vc-got-incoming (buffer remote-location)
745   "Fill BUFFER with the diff between the REMOTE-LOCATION and the local worktree branch."
746   (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
747                 (concat "origin/" (vc-got--current-branch))
748               remote-location))
749         (inhibit-read-only t))
750     (with-current-buffer buffer
751       (vc-got--log nil nil (vc-got--current-branch) rl))))
752 
753 (defun vc-got-log-search (buffer pattern)
754   "Search commits for PATTERN and write the results found in BUFFER."
755   (with-current-buffer buffer
756     (let ((inhibit-read-only t))
757       (vc-got--log nil nil nil nil pattern))))
758 
759 (define-derived-mode vc-got-log-view-mode log-view-mode "Got-Log-View"
760   "Got-specific log-view mode.
761 Heavily inspired by `vc-git-log-view-mode'."
762   (require 'add-log)
763   (setq-local log-view-file-re regexp-unmatchable)
764   (setq-local log-view-per-file-logs nil)
765   (setq-local log-view-message-re "^commit +\\([0-9a-z]+\\)")
766   (setq-local log-view-font-lock-keywords
767               (append
768                `((,log-view-message-re (1 'change-log-acknowledgment)))
769                ;; Handle the case:
770                ;; user: foo@bar
771                '(("^from: \\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
772                   (1 'change-log-email))
773                  ;; Handle the case:
774                  ;; user: FirstName LastName <foo@bar>
775                  ("^from: \\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
776                   (1 'change-log-name)
777                   (2 'change-log-email))
778                  ("^date: \\(.+\\)" (1 'change-log-date))))))
779 
780 ;; TODO: async
781 ;; TODO: return 0 or 1
782 (defun vc-got-diff (files &optional rev1 rev2 buffer _async)
783   "Insert into BUFFER (or *vc-diff*) the diff for FILES from REV1 to REV2."
784   (let* ((buffer (get-buffer-create (or buffer "*vc-diff*")))
785          (inhibit-read-only t))
786     (with-current-buffer buffer
787       (vc-got-with-worktree (or (car files)
788                                 default-directory)
789         (if (and (null rev1)
790                  (null rev2))
791             (dolist (file files)
792               (vc-got--diff file))
793           ;; TODO: if rev1 is nil, diff from the current version until
794           ;; rev2.
795           ;;
796           ;; TODO: if rev2 is nil as well, diff against an empty tree
797           ;; (i.e. get the patch from `got log -p rev1')
798           ;;
799           ;; TODO: it would be nice to optionally include FILES here,
800           ;; it would make the `=' key on the *Annotate* buffer do the
801           ;; right thing, but AFAICS got doesn't provide something
802           ;; like this.  Probably only hacking something with ``log
803           ;; -p'' and filtering?
804           (vc-got--diff rev1 rev2))))))
805 
806 (defun vc-got-revision-completion-table (_files)
807   "Return a completion table for existing revisions.
808 Ignores FILES because GoT doesn't have the concept of ``file
809 revisions''; instead, like with git, you have tags and branches."
810   (letrec ((table (lazy-completion-table
811                    table (lambda () (vc-got--ref)))))
812     table))
813 
814 (defun vc-got-annotate-command (file buf &optional rev)
815   "Show annotated contents of FILE in buffer BUF.  If given, use revision REV."
816   (let (process-file-side-effects)
817     (with-current-buffer buf
818       ;; FIXME: vc-ensure-vc-buffer won't recognise this buffer as managed
819       ;; by got unless vc-parent-buffer points to a buffer managed by got.
820       ;; investigate why this is needed.
821       (set (make-local-variable 'vc-parent-buffer) (find-file-noselect file))
822       (vc-got--call "blame"
823                     (when rev (list "-c" rev))
824                     "--"
825                     file))))
826 
827 (defconst vc-got--annotate-re
828   (concat "^[0-9]\\{1,\\}) " ; line number followed by )
829           "\\([a-z0-9]+\\) " ; SHA-1 of commit
830           "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\) " ; year-mm-dd
831           "\\([^ ]\\)+ ")    ; author
832   "Regexp to match annotation output lines.
833 
834 Provides capture groups for:
835 1. revision id
836 2. date of commit
837 3. author of commit")
838 
839 (defconst vc-got--commit-re "^commit \\([a-z0-9]+\\)"
840   "Regexp to match commit lines.
841 
842 Provides capture group for the commit revision id.")
843 
844 (defun vc-got-annotate-time ()
845   "Return the time of the next line of annotation at or after point.
846 Value is returned as floating point fractional number of days."
847   (save-excursion
848     (beginning-of-line)
849     (when (looking-at vc-got--annotate-re)
850       (let ((str (match-string-no-properties 2)))
851         (vc-annotate-convert-time
852          (encode-time 0 0 0
853                       (string-to-number (substring str 8 10))
854                       (string-to-number (substring str 5 7))
855                       (string-to-number (substring str 0 4))))))))
856 
857 (defun vc-got-annotate-extract-revision-at-line ()
858   "Return revision corresponding to the current line or nil."
859   (save-excursion
860     (beginning-of-line)
861     (when (looking-at vc-got--annotate-re)
862       (match-string-no-properties 1))))
863 
864 
865 ;; Tag system
866 
867 (defun vc-got--tag-callback (tag)
868   "`log-edit' callback for `vc-got-create-tag'.
869 Creates the TAG using the content of the current buffer."
870   (interactive)
871   (let ((msg (buffer-substring-no-properties (point-min)
872                                              (point-max))))
873     (with-temp-buffer
874       (unless (zerop (vc-got--call "tag"
875                                    "-m"
876                                    (log-edit-extract-headers nil msg)
877                                    "--"
878                                    tag))
879         (error "[vc-got] can't create tag %s: %s" tag (buffer-string))))))
880 
881 (defun vc-got-create-tag (_dir name branchp)
882   "Attach the tag NAME to the state of the worktree.
883 DIR is ignored (tags are global, not per-file).  If BRANCHP is
884 true, NAME should create a new branch otherwise it will pop-up a
885 `log-edit' buffer to provide the tag message."
886   ;; TODO: vc reccomends to ensure that all the file are in a clean
887   ;; state, but is it useful?
888   (if branchp
889       (vc-got--branch name)
890     (let ((buf (get-buffer-create "*vc-got tag*")))
891       (with-current-buffer buf
892         (erase-buffer)
893         (save-excursion
894           (insert "Summary: tag " name "\n\n"))
895         (move-end-of-line 1)
896         (switch-to-buffer buf)
897         (log-edit (lambda ()
898                     (interactive)
899                     (unwind-protect
900                         (vc-got--tag-callback name)
901                       (kill-buffer buf))))))))
902 
903 (defun vc-got-retrieve-tag (dir name _update)
904   "Switch to the tag NAME for files at or below DIR."
905   (let ((default-directory dir))
906     (vc-got--update name dir)))
907 
908 
909 ;; Miscellaneous
910 
911 (defun vc-got-find-ignore-file (file)
912   "Return the gitignore file that controls FILE."
913   (expand-file-name ".gitignore"
914                     (vc-got-root file)))
915 
916 (defun vc-got-previous-revision (file rev)
917   "Return the revision number that precedes REV for FILE or nil."
918   (with-temp-buffer
919     (vc-got--log file 2 rev nil nil t)
920     (goto-char (point-min))
921     (keep-lines "^commit")
922     (when (looking-at vc-got--commit-re)
923       (match-string-no-properties 1))))
924 
925 (defun vc-got-next-revision (file rev)
926   "Return the revision number that follows REV for FILE or nil."
927   (with-temp-buffer
928     (vc-got--log file nil nil rev)
929     (keep-lines "^commit" (point-min) (point-max))
930     (goto-char (point-max))
931     (forward-line -1)    ; return from empty line to last actual commit
932     (unless (= (point) (point-min))
933       (forward-line -1)
934       (when (looking-at vc-got--commit-re)
935         (match-string-no-properties 1)))))
936 
937 (defun vc-got-delete-file (file)
938   "Delete FILE locally and mark it deleted in work tree."
939   (vc-got--remove file t))
940 
941 (defun vc-got-find-file-hook ()
942   "Activate `smerge-mode' if there is a conflict."
943   ;; just like vc-git-find-file-hook
944   (when (and buffer-file-name
945              (eq (vc-state buffer-file-name 'Got) 'conflict)
946              (save-excursion
947                (goto-char (point-min))
948                (re-search-forward "^<<<<<<< " nil 'noerror)))
949     (smerge-start-session)
950     (vc-message-unresolved-conflicts buffer-file-name)))
951 
952 (defun vc-got-conflicted-files (dir)
953   "Return the list of files with conflicts in directory DIR."
954   (let* ((root (vc-got-root dir))
955          (default-directory root)
956          (process-file-side-effects))
957     (cl-loop with conflicts = nil
958              for (file status _) in (vc-got--status "C" ".")
959              do (when (and (eq status 'conflict)
960                            (file-in-directory-p file dir))
961                   (push file conflicts))
962              finally return conflicts)))
963 
964 (defun vc-got-repository-url (_file &optional remote-name)
965   "Return URL for REMOTE-NAME, or for \"origin\" if nil."
966   (let* ((default-directory (vc-got--repo-root))
967          (remote-name (or remote-name "origin"))
968          (heading (concat "[remote \"" remote-name "\"]"))
969          (conf (cond ((file-exists-p ".git/config") ".git/config")
970                      ((file-exists-p ".git")        nil)
971                      ((file-exists-p "config")      "config")))
972          found)
973     (when conf
974       (with-temp-buffer
975         (insert-file-contents conf)
976         (goto-char (point-min))
977         (when (search-forward heading nil t)
978           (forward-line)
979           (while (and (not found)
980                       (looking-at ".*=") ; too broad?
981                       (not (= (point) (point-max))))
982             (when (looking-at ".*url = \\(.*\\)")
983               (setq found (match-string-no-properties 1)))
984             (forward-line))
985           found)))))
986 
987 (provide 'vc-got)
988 ;;; vc-got.el ends here