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