1 ;;; vc-got.el --- Game of Tree backend for VC -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2020 Omar Polo
5 ;; Author: Omar Polo <op@venera>
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
23 ;; Backend implementation status
25 ;; Function marked with `*' are required, those with `-' are optional.
27 ;; FUNCTION NAME STATUS
29 ;; BACKEND PROPERTIES:
30 ;; * revision-granularity DONE
31 ;; - update-on-retrieve-tag XXX: what should this do?
33 ;; STATE-QUERYING FUNCTIONS:
36 ;; - dir-status-files DONE
37 ;; - dir-extra-headers DONE
38 ;; - dir-printer NOT IMPLEMENTED
39 ;; - status-fileinfo-extra NOT IMPLEMENTED
40 ;; * working-revision DONE
41 ;; * checkout-model DONE
42 ;; - mode-line-string DONE
44 ;; STATE-CHANGING FUNCTIONS:
45 ;; * create-repo NOT IMPLEMENTED
46 ;; I don't think got init does what this function is supposed to
49 ;; - responsible-p DONE
50 ;; - receive-file NOT NEEDED, default `register' works fine
51 ;; - unregister NOT IMPLEMENTED, no use case
53 ;; * find-revision DONE
54 ;; * checkout NOT IMPLEMENTED
55 ;; I'm not sure how to properly implement this. Does filling
56 ;; FILE with the find-revision do the trick? Or use got update?
58 ;; - merge-file NOT IMPLEMENTED
59 ;; - merge-branch DONE
60 ;; - merge-news NOT IMPLEMENTED
64 ;; - steal-lock NOT NEEDED, `got' is not using locks
65 ;; - modify-change-comment NOT IMPLEMENTED
66 ;; can be implemented via histedit, if I understood correctly
67 ;; what it is supposed to do.
68 ;; - mark-resolved NOT IMPLEMENTED
69 ;; - find-admin-dir NOT IMPLEMENTED
73 ;; * log-outgoing DONE
74 ;; * log-incoming DONE
76 ;; - log-view-mode NOT IMPLEMENTED
77 ;; - show-log-entry NOT IMPLEMENTED
78 ;; - comment-history NOT IMPLEMENTED
79 ;; - update-changelog NOT IMPLEMENTED
81 ;; - revision-completion-table NOT IMPLEMENTED
82 ;; - annotate-command DONE
83 ;; - annotate-time DONE
84 ;; - annotate-current-time NOT IMPLEMENTED
85 ;; - annotate-extract-revision-at-line DONE
86 ;; - region-history NOT IMPLEMENTED
87 ;; - region-history-mode NOT IMPLEMENTED
88 ;; - mergebase NOT IMPLEMENTED
91 ;; - create-tag NOT IMPLEMENTED
92 ;; - retrieve-tag NOT IMPLEMENTED
94 ;; MISCELLANEOUS NOT IMPLEMENTED
95 ;; - make-version-backups-p NOT NEEDED, `got' works fine locally
97 ;; - ignore NOT IMPLEMENTED
98 ;; - ignore-completion-table NOT IMPLEMENTED
99 ;; - previous-revision DONE
100 ;; - next-revision DONE
101 ;; - log-edit-mode NOT IMPLEMENTED
102 ;; - check-headers NOT NEEDED, `got' does not use headers
103 ;; - delete-file DONE
104 ;; - rename-file NOT NEEDED, `delete' + `register' is enough
105 ;; - find-file-hook NOT NEEDED, no need for hooks yet
106 ;; - extra-menu NOT IMPLEMENTED, add `import', `integrate', `stage'?
107 ;; - extra-dir-menu NOT IMPLEMENTED, same as above
108 ;; - conflicted-files DONE
109 ;; - repository-url DONE
111 ;; TODO: use the idiom
112 ;; (let (process-file-side-effects) ...)
113 ;; when the got command WON'T change the file. This can enable some
114 ;; emacs optimizations
116 ;; TODO: vc-git has most function that starts with:
118 ;; (let* ((root (vc-git-root default-directory))
119 ;; (buffer (format "*vc-git : %s*" (expand-file-name root)))
123 ;; we should 1) investigate if also other backends do something like
124 ;; this (or if there is a better way) and 2) try to do the same.
135 (require 'vc-annotate)
137 (require 'vc-got-stage)
143 (defcustom vc-got-program "got"
144 "Name of the Got executable (excluding any arguments)."
148 (defcustom vc-got-diff-switches t
149 "String or list of strings specifying switches for Got diff under VC.
150 If nil, use the value of `vc-diff-switches'. If t, use no switches."
151 :type '(choice (const :tag "Unspecified" nil)
152 (const :tag "None" t)
153 (string :tag "Argument String")
154 (repeat :tag "Argument List" :value ("") string))
158 (defun vc-got--program-version ()
159 "Returns the version string of used `Got' command."
160 (let (process-file-side-effects)
163 (substring (buffer-string) 4 -1))))
165 (defun vc-got-root (file)
166 "Return the work tree root for FILE, or nil."
167 (or (vc-file-getprop file 'got-root)
168 (vc-file-setprop file 'got-root (vc-find-root file ".got"))))
170 (defmacro vc-got-with-worktree (file &rest body)
171 "Evaluate BODY in the work tree directory of FILE."
172 (declare (indent defun))
173 `(when-let (default-directory (vc-got-root ,file))
176 (defun vc-got--repo-root ()
177 "Return the path to the repository root.
178 Assume `default-directory' is inside a got worktree."
179 (vc-got-with-worktree default-directory
181 (insert-file-contents ".got/repository")
182 (string-trim (buffer-string) nil "\n"))))
184 (defun vc-got--call (&rest args)
185 "Call `vc-got-program' in the `default-directory' with ARGS and put the output in the current buffer."
186 (apply #'process-file vc-got-program nil (current-buffer) nil
187 (cl-remove-if #'null (flatten-list args))))
189 (defun vc-got--add (files)
190 "Add FILES to got, passing `vc-register-switches' to the command invocation."
192 (apply #'vc-got--call "add" (append vc-register-switches files))))
194 (defun vc-got--log (&optional path limit start-commit stop-commit
195 search-pattern reverse)
196 "Execute the log command in the worktree of PATH.
197 The output in the current buffer.
199 LIMIT limits the maximum number of commit returned.
201 START-COMMIT: start traversing history at the specified commit.
202 STOP-COMMIT: stop traversing history at the specified commit.
203 SEARCH-PATTERN: limit to log messages matched by the regexp given.
204 REVERSE: display the log messages in reverse order.
206 Return nil if the command failed or if PATH isn't included in any
208 (let (process-file-side-effects)
209 (vc-got-with-worktree (or path default-directory)
212 (when limit (list "-l" (format "%s" limit)))
213 (when start-commit (list "-c" start-commit))
214 (when stop-commit (list "-x" stop-commit))
215 (when search-pattern (list "-s" search-pattern))
216 (when reverse '("-R"))
219 (defun vc-got--status (dir-or-file &rest files)
220 "Return the output of ``got status''.
222 DIR-OR-FILE can be either a directory or a file. If FILES is
223 given, return the status of those files, otherwise the status of
225 (vc-got-with-worktree dir-or-file
228 (apply #'vc-got--call "status" files)
229 (vc-got--call "status" dir-or-file))
232 (defun vc-got--parse-status-flag (flag)
233 "Parse FLAG, see `vc-state'."
234 ;; got outputs nothing if the file is up-to-date
235 (if (string-empty-p flag)
237 ;; trying to follow the order of the manpage
238 (cl-case (aref flag 0)
244 (?~ 'edited) ;XXX: what does it means for a file to be ``obstructed''?
246 (?m 'edited) ;modified file modes
249 (defun vc-got--parse-status (output)
250 "Parse the OUTPUT of got status and return an alist of (FILE . STATUS)."
251 ;; XXX: the output of got is line-oriented and will break if
252 ;; filenames contains spaces or newlines.
253 (cl-loop for line in (split-string output "\n" t)
254 collect (cl-destructuring-bind (status file) (split-string line " " t " ")
255 `(,file . ,(vc-got--parse-status-flag status)))))
257 (defun vc-got--tree-parse ()
258 "Parse into an alist the output of got tree -i in the current buffer."
259 (goto-char (point-min))
261 until (= (point) (point-max))
262 collect (let* ((obj-start (point))
264 (obj (buffer-substring obj-start (point)))
265 (_ (forward-char)) ;skip the space
266 (filename-start (point))
267 (_ (move-end-of-line nil))
268 (filename (buffer-substring filename-start (point))))
269 ;; goto the start of the next line
271 (move-beginning-of-line nil)
272 `(,filename . ,obj))))
274 (defun vc-got--tree (commit path)
275 (vc-got-with-worktree path
277 (vc-got--call "tree" "-c" commit "-i" path)
278 (vc-got--tree-parse))))
280 (defun vc-got--cat (commit obj-id)
281 "Execute got cat -c COMMIT OBJ-ID in the current buffer."
282 (vc-got--call "cat" "-c" commit obj-id))
284 (defun vc-got--revert (&rest files)
285 "Execute got revert FILES..."
286 (vc-got-with-worktree (car files)
288 (apply #'vc-got--call "revert" files))))
290 (defun vc-got--list-branches ()
291 "Return an alist of (branch . commit)."
293 (when (zerop (vc-got--call "branch" "-l"))
294 (goto-char (point-min))
296 until (= (point) (point-max))
297 ;; parse the `* $branchname: $commit', from the end
298 collect (let* ((_ (move-end-of-line nil))
301 (start-commit (point))
302 (_ (backward-char 2))
303 (end-branchname (point))
304 (_ (move-beginning-of-line nil))
306 (start-branchname (point))
307 (branchname (buffer-substring start-branchname end-branchname))
308 (commit (buffer-substring start-commit end-commit)))
310 (move-beginning-of-line nil)
311 `(,branchname . ,commit))))))
313 (defun vc-got--current-branch ()
314 "Return the current branch."
316 (when (zerop (vc-got--call "branch"))
317 (string-trim (buffer-string) "" "\n"))))
319 (defun vc-got--integrate (branch)
320 "Integrate BRANCH into the current one."
322 (vc-got--call "integrate" branch)))
324 (defun vc-got--diff (&rest args)
325 "Call got diff with ARGS. The result will be stored in the current buffer."
326 (apply #'vc-got--call "diff"
327 (append (vc-switches 'got 'diff)
328 (mapcar #'file-relative-name args))))
330 (defun vc-got--unstage (file-or-directory)
331 "Unstage all the staged hunks at or within FILE-OR-DIRECTORY.
332 If it's nil, unstage every staged changes across the entire work
334 (vc-got--call "unstage" file-or-directory))
336 (defun vc-got--remove (file &optional force keep-local)
337 "Internal helper to removing FILE from got."
338 (vc-got-with-worktree (or file default-directory)
340 (vc-got--call "remove"
342 (when keep-local "-k")
346 ;; Backend properties
348 (defun vc-got-revision-granularity ()
349 "Got has REPOSITORY granularity."
352 ;; XXX: what this should do? The description is not entirely clear
353 (defun vc-got-update-on-retrieve-tag ()
357 ;; State-querying functions
359 ;;;###autoload (defun vc-got-registered (file)
360 ;;;###autoload "Return non-nil if FILE is registered with got."
361 ;;;###autoload (when (vc-find-root file ".got")
362 ;;;###autoload (load "vc-got" nil t)
363 ;;;###autoload (vc-got-registered file)))
365 (defun vc-got-registered (file)
366 "Return non-nil if FILE is registered with got."
367 (if (file-directory-p file)
368 nil ;got doesn't track directories
369 (when (vc-find-root file ".got")
370 (let ((status (vc-got--status file)))
371 (not (or (string-prefix-p "?" status)
372 (string-prefix-p "N" status)))))))
374 (defun vc-got-state (file)
375 "Return the current version control state of FILE. See `vc-state'."
376 (unless (file-directory-p file)
377 (vc-got--parse-status-flag (vc-got--status file))))
379 (defun vc-got-dir-status-files (dir files update-function)
380 (let* ((fs (seq-filter (lambda (file)
381 (and (not (string= file ".."))
382 (not (string= file "."))
383 (not (string= file ".got"))))
385 (directory-files dir))))
386 (stats (vc-got--parse-status (apply #'vc-got--status dir files)))
387 (res (mapcar (lambda (x)
388 (list (car x) (cdr x) nil))
390 (cl-loop for file in fs
391 do (let ((s (unless (or (cdr (assoc file stats #'string=))
392 (file-directory-p file))
393 (when (file-exists-p file)
394 ;; if file doesn't exists, it's a
395 ;; untracked file that was removed.
396 (list file 'up-to-date nil)))))
399 finally (funcall update-function res nil))))
401 (defun vc-got-dir-extra-headers (dir)
402 "Return a string for the `vc-dir' buffer heading for directory DIR."
403 (concat (propertize "Repository : " 'face 'font-lock-type-face)
404 (vc-got--repo-root) "\n"
405 (propertize "Remote URL : " 'face 'font-lock-type-face)
406 (vc-got-repository-url dir) "\n"
407 (propertize "Branch : " 'face 'font-lock-type-face)
408 (vc-got--current-branch)))
410 (defun vc-got-working-revision (file)
411 "Return the id of the last commit that touched the FILE or \"0\" for a new (but added) file."
414 (when (vc-got--log file 1)
416 (goto-char (point-min))
417 (forward-line 1) ;skip the ----- line
418 (forward-word) ;skip "commit"
419 (forward-char) ;skip the space
420 (setq start (point)) ;store start of the SHA
421 (forward-word) ;goto SHA end
422 (buffer-substring start (point)))))
423 ;; special case: if this file is added but has no previous commits
424 ;; touching it, got log will fail (as expected), but we have to
426 (when (eq (vc-got-state file) 'added)
429 (defun vc-got-checkout-model (_files)
432 (defun vc-got-mode-line-string (file)
433 "Return the VC mode line string for FILE."
434 (vc-got-with-worktree file
435 (let ((def (vc-default-mode-line-string 'Got file)))
436 (concat (substring def 0 4) (vc-got--current-branch)))))
439 ;; state-changing functions
441 (defun vc-got-create-repo (_backend)
442 (error "vc got: create-repo not implemented"))
444 (defun vc-got-register (files &optional _comment)
445 "Register FILES, passing `vc-register-switches' to the backend command."
448 (defalias 'vc-got-responsible-p #'vc-got-root)
450 (defun vc-got-checkin (files comment &optional _rev)
451 "Commit FILES with COMMENT as commit message."
453 (apply #'vc-got--call "commit" "-m"
454 ;; emacs add ``Summary:'' at the start of the commit
455 ;; message. vc-git doesn't seem to treat this specially.
456 ;; Since it's annoying, remove it.
457 (string-remove-prefix "Summary: " comment)
460 (defun vc-got-find-revision (file rev buffer)
461 "Fill BUFFER with the content of FILE in the given revision REV."
462 (when-let (obj-id (assoc file (vc-got--tree rev file) #'string=))
463 (with-current-buffer buffer
464 (vc-got-with-worktree file
465 (vc-got--cat rev obj-id)))))
467 (defun vc-got-find-ignore-file (file)
468 "Return the gitignore file that controls FILE."
469 (expand-file-name ".gitignore"
472 (defun vc-got-checkout (_file &optional _rev)
473 "Checkout revision REV of FILE. If REV is t, checkout from the head."
474 (error "vc got: checkout not implemented"))
476 (defun vc-got-revert (file &optional _content-done)
477 "Revert FILE back to working revision."
478 (vc-got--revert file))
480 (defun vc-got-merge-branch ()
481 "Prompt for a branch and integrate it into the current one."
482 ;; XXX: be smart and try to "got rebase" if "got integrate" fails?
483 (let* ((branches (cl-loop for (branch . commit) in (vc-got--list-branches)
485 (branch (completing-read "Merge from branch: " branches)))
487 (vc-got--integrate branch))))
489 (defun vc-got--push-pull (cmd op prompt root)
490 "Execute CMD OP, or prompt the user if PROMPT is non-nil.
491 ROOT is the worktree root."
492 (let ((buffer (format "*vc-got : %s*" (expand-file-name root))))
493 (when-let (cmd (if prompt
495 (read-shell-command (format "%s %s command: " cmd op)
496 (format "%s %s" cmd op))
499 (apply #'vc-do-command buffer 0 (car cmd) nil (cdr cmd)))))
501 (defun vc-got-pull (prompt)
502 "Execute got pull, prompting the user for the full command if PROMPT is not nil."
503 (vc-got--push-pull vc-got-program "fetch" prompt (vc-got-root default-directory)))
505 (defun vc-got-push (prompt)
506 "Run git push (not got!) in the repository dir.
507 If PROMPT is non-nil, prompt for the git command to run."
508 (let* ((root (vc-got-root default-directory))
509 (default-directory (vc-got--repo-root)))
510 (vc-got--push-pull "git" "push" prompt root)))
512 (defun vc-got-print-log (files buffer &optional _shortlog start-revision limit)
513 "Insert the revision log for FILES into BUFFER.
515 LIMIT limits the number of commits, optionally starting at START-REVISION."
516 (with-current-buffer buffer
517 ;; the *vc-diff* may be read only
518 (let ((inhibit-read-only t))
519 (cl-loop for file in files
520 do (vc-got--log (file-relative-name file) limit start-revision)))))
522 ;; XXX: this includes also the latest commit in REMOTE-LOCATION.
523 (defun vc-got-log-outgoing (buffer remote-location)
524 "Fill BUFFER with the diff between the local worktree branch and REMOTE-LOCATION."
525 (vc-setup-buffer buffer)
526 (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
527 (concat "origin/" (vc-got--current-branch))
529 (inhibit-read-only t))
530 (with-current-buffer buffer
531 (vc-got--log nil nil nil rl))))
533 (defun vc-got-incoming (buffer remote-location)
534 "Fill BUFFER with the diff between the REMOTE-LOCATION and the local worktree branch."
535 (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
536 (concat "origin/" (vc-got--current-branch))
538 (inhibit-read-only t))
539 (with-current-buffer buffer
540 (vc-got--log nil nil (vc-got--current-branch) rl))))
542 (defun vc-got-log-search (buffer pattern)
543 "Search commits for PATTERN and write the results found in BUFFER."
544 (with-current-buffer buffer
545 (let ((inhibit-read-only t))
546 (vc-got--log nil nil nil nil pattern))))
549 ;; TODO: return 0 or 1
550 (defun vc-got-diff (files &optional rev1 rev2 buffer _async)
551 "Insert into BUFFER (or *vc-diff*) the diff for FILES from REV1 to REV2."
552 (let* ((buffer (get-buffer-create (or buffer "*vc-diff*")))
553 (inhibit-read-only t))
554 (with-current-buffer buffer
555 (vc-got-with-worktree (car files)
556 (cond ((and (null rev1)
559 (vc-got--diff file)))
560 (t (error "Not implemented")))))))
562 (defun vc-got-annotate-command (file buf &optional rev)
563 "Show annotated contents of FILE in buffer BUF. If given, use revision REV."
564 (let (process-file-side-effects)
565 (with-current-buffer buf
566 ;; FIXME: vc-ensure-vc-buffer won't recognise this buffer as managed
567 ;; by got unless vc-parent-buffer points to a buffer managed by got.
568 ;; investigate why this is needed.
569 (set (make-local-variable 'vc-parent-buffer) (find-file-noselect file))
570 (apply #'vc-got--call "blame" (if rev
574 (defconst vc-got--annotate-re
575 (concat "^[0-9]\\{1,\\}) " ; line number followed by )
576 "\\([a-z0-9]+\\) " ; SHA-1 of commit
577 "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\) " ; year-mm-dd
578 "\\([^ ]\\)+ ") ; author
579 "Regexp to match annotation output lines.
581 Provides capture groups for:
584 3. author of commit")
586 (defconst vc-got--commit-re "^commit \\([a-z0-9]+\\)"
587 "Regexp to match commit lines.
589 Provides capture group for the commit revision id.")
591 (defun vc-got-annotate-time ()
592 "Return the time of the next line of annotation at or after point.
593 Value is returned as floating point fractional number of days."
596 (when (looking-at vc-got--annotate-re)
597 (let ((str (match-string-no-properties 2)))
598 (vc-annotate-convert-time
600 (string-to-number (substring str 8 10))
601 (string-to-number (substring str 5 7))
602 (string-to-number (substring str 0 4))))))))
604 (defun vc-got-annotate-extract-revision-at-line ()
605 "Returns revision corresponding to the current line or nil."
608 (when (looking-at vc-got--annotate-re)
609 (match-string-no-properties 1))))
611 (defun vc-got-previous-revision (file rev)
612 "Return the revision number that precedes REV for FILE, or nil if no such revision exists."
614 (vc-got--log file 2 rev nil nil t)
615 (goto-char (point-min))
616 (keep-lines "^commit")
617 (when (looking-at vc-got--commit-re)
618 (match-string-no-properties 1))))
620 (defun vc-got-next-revision (file rev)
621 "Return the revision number that follows REV for FILE, or nil
622 if no such revision exists."
624 (vc-got--log file nil nil rev)
625 (keep-lines "^commit" (point-min) (point-max))
626 (goto-char (point-max))
627 (forward-line -1) ;; return from empty line to last actual commit
628 (unless (= (point) (point-min))
630 (when (looking-at vc-got--commit-re)
631 (match-string-no-properties 1)))))
633 (defun vc-got-delete-file (file)
634 "Delete FILE locally and mark it deleted in work tree."
635 (vc-got--remove file t))
637 (defun vc-got-conflicted-files (dir)
638 "Return the list of files with conflicts in directory DIR."
639 (let* ((root (vc-got-root dir))
640 (default-directory root)
641 (process-file-side-effects))
642 ;; for got it doesn't matter where we call "got status", it will
643 ;; always report file paths from the root of the repo.
644 (cl-loop with conflicts = nil
645 for (file . status) in (vc-got--parse-status
646 (vc-got--status "."))
647 do (when (and (eq status 'conflict)
648 (file-in-directory-p file dir))
649 (push file conflicts))
650 finally return conflicts)))
652 (defun vc-got-repository-url (_file &optional remote-name)
653 "Return URL for REMOTE-NAME, or for \"origin\" if nil."
654 (let* ((default-directory (vc-got--repo-root))
655 (remote-name (or remote-name "origin"))
656 (heading (concat "[remote \"" remote-name "\"]"))
657 (conf (cond ((file-exists-p ".git/config")
659 ((file-exists-p ".git")
661 ((file-exists-p "config")
666 (insert-file-contents conf)
667 (goto-char (point-min))
668 (when (search-forward heading nil t)
670 (while (and (not found)
671 (looking-at ".*=") ;too broad?
672 (not (= (point) (point-max))))
673 (when (looking-at ".*url = \\(.*\\)")
674 (setq found (match-string-no-properties 1)))
679 ;;; vc-got.el ends here
