Blob


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