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