;; sy-git.el --- A couple of nice git tools -*- Emacs-Lisp -*-
-;; Copyright (C) 2015 Steve Youngs
+;; Copyright (C) 2015 - 2017 Steve Youngs
;; Author: Steve Youngs <steve@sxemacs.org>
;; Maintainer: Steve Youngs <steve@sxemacs.org>
;; Created: <2015-07-05>
-;; Time-stamp: <Friday Jul 15, 2016 15:02:16 steve>
+;; Time-stamp: <Friday Oct 27, 2017 11:41:15 steve>
;; Homepage: http://git.sxemacs.org/slh
;; Keywords: git, tools, convenience
;; lets you write commit logs in a similar format to that of
;; `add-change-log-entry'. It is globally bound to `C-x G a'.
;; See: `sy-git-add-log-entry'.
+;;
+;; [2017-10-16 08:59]: Added rudimentary support for git-diff,
+;; git-blame, and git-log. For examining changes you can use
+;; either plain `diff-mode' with `sy-git-diff', or Ediff with
+;; `sy-git-ediff'.
;;; Todo:
;;
-;; o Implement a variation of `patch-to-change-log'
+;; o Implement a variation of `patch-to-change-log'.
+;; [2017-10-15 15:09]: Turns out that this isn't really needed
+;; as you can invoke `sy-git-add-log-entry' directly from a diff.
;;; Code:
+;; Need VC, ediff, and diff-mode
+(vc-load-vc-hooks)
+(add-to-list 'vc-handled-backends 'GIT)
+(require 'ediff)
+(require 'diff-mode)
+
+;;; Eyecandy
+(eval-and-compile
+ (condition-case nil
+ (require 'working)
+ (error
+ (progn
+ (defmacro working-status-forms (message donestr &rest forms)
+ "Contain a block of code during which a working status is shown."
+ (list 'let (list (list 'msg message) (list 'dstr donestr)
+ '(ref1 0))
+ (cons 'progn forms)))
+
+ (defun working-status (&optional percent &rest args)
+ "Called within the macro `working-status-forms', show the status."
+ (message "%s%s" (apply 'format msg args)
+ (if (eq percent t) (concat "... " dstr)
+ (format "... %3d%%"
+ (or percent
+ (floor (* 100.0 (/ (float (point))
+ (point-max)))))))))
+ (put 'working-status-forms 'lisp-indent-function 2)))))
+
+(defvar sy-git-log-font-lock-keywords
+ '(;;
+ ;; Headers
+ ("^commit .*$"
+ (0 font-lock-warning-face))
+ (#r"^\(Author\(Date\)?:\|Commit\(Date\)?:\|Date:\|Merge:\)"
+ (1 gnus-header-content))
+ ;; date
+ (#r"Date:\(.*$\)"
+ (1 change-log-date-face))
+ ;; name/email
+ (#r":\s-+\(.*\)\s-+<\(.*\)>"
+ (1 change-log-name-face)
+ (2 change-log-email-face))
+ ;; file name
+ (#r"^\s-+\* \([^ ,:(]+\)"
+ (1 change-log-file-face))
+ ;; Function or variable names.
+ ("(\\([^) ,:\n]+\\)"
+ (1 change-log-list-face)
+ ("\\=, *\\([^) ,:\n]+\\)" nil nil
+ (1 change-log-list-face)))
+ ;; Signed-off
+ (#r"\(Signed-off\|Reviewed\|Reported\|Acked\)-by:\|Cc:"
+ (0 gnus-header-content))))
+
+;;; Globals
+(defvar sy-gitbin (executable-find "git")
+ "The git binary.")
+
+(defvar sy-git-default-binopts
+ '("--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true")
+ "The default options passed to every git invocation.
+
+Screw with these at your own peril. If you don't know what you are
+doing DO NOT change them, or at the very least, DO NOT remove any of
+them.")
+
+(defun sy-git-run-buffer (buffer subcmd &rest args)
+ "Run git SUBCMD with ARGS, collect output in BUFFER."
+ (let ((git sy-gitbin)
+ (gitopts sy-git-default-binopts)
+ (coding-system-for-write (if (get-coding-system 'utf-8)
+ 'utf-8
+ 'binary))
+ (buffer (get-buffer-create buffer)))
+ ;; If called with ARGS as a list, it is now a nested list. That's
+ ;; bad
+ (while (listp (car args))
+ (setq args (car args)))
+ ;; nils are bad too
+ (setq args (delq nil args))
+ (setq args (and (push subcmd args)
+ (append gitopts args)))
+ (apply #'call-process git nil buffer nil args)))
+(put 'sy-git-run-buffer 'lisp-indent-function 1)
+
+(defun sy-git-run-string (subcmd &rest args)
+ "Return a string from output of git SUBCMD ARGS."
+ (let ((git sy-gitbin)
+ (gitopts sy-git-default-binopts)
+ cmdline)
+ ;; flatten and remove nils from ARGS
+ (while (listp (car args))
+ (setq args (car args)))
+ (setq args (delq nil args))
+ ;; build cmdline
+ (push subcmd args)
+ (setq cmdline (push git gitopts))
+ (setq cmdline (append cmdline args))
+ (setq cmdline (mapconcat #'identity cmdline " "))
+ ;; run it
+ (shell-command-to-string cmdline)))
+(put 'sy-git-run-string 'lisp-indent-function 1)
+
(defun sy-git-check-hook (hook)
"Return non-nil when HOOK script exists and is usable.
(re-search-forward (regexp-quote "rm -f ${LOG}") nil t))
(t nil))))))
+;;; diff
+;; FIXME: might be nice to be able to diff against other revisions
+;; aside from HEAD.
+(defun sy-git-diff ()
+ "Show a diff of the current file against HEAD."
+ (interactive)
+ (progn
+ (vc-diff nil)
+ (local-set-key [(control x) G a] #'sy-git-add-log-entry)))
+
+(defun sy-git-ediff ()
+ "Run ediff-buffers on the working file and the HEAD version."
+ (interactive)
+ (let* ((bufferA (file-basename (buffer-file-name)))
+ (bufferB (concat bufferA ".~HEAD~")))
+ (progn
+ (vc-version-other-window "HEAD")
+ (ediff-buffers bufferA bufferB))))
+
+;;; blame
+(defun sy-git-blame-log (&optional extent)
+ "*Display the log of the git commit who's sha is stored in EXTENT.
+
+This command should only ever be called from within a Git Blame
+buffer."
+ (interactive)
+ (unless (string-match "GIT Blame" (buffer-name))
+ (error 'invalid-operation this-command
+ "Can only be called from the Blame buffer"))
+ (let* ((extent (or extent
+ (extent-at (point) nil 'blame)))
+ (revstr (extent-property extent 'brev))
+ (showbuf (format "*GIT Show::%s*" revstr))
+ (gitcmd "show")
+ (args (split-string (format "--name-only %s" revstr)))
+ (cb (current-buffer)))
+ (window-configuration-to-register ?l)
+ (with-current-buffer (get-buffer-create showbuf)
+ (erase-buffer)
+ (set (make-local-variable 'font-lock-defaults)
+ '(sy-git-log-font-lock-keywords t t))
+ (sy-git-run-buffer showbuf gitcmd args)
+ (goto-char (point-min))
+ (view-mode cb #'(lambda (showbuf)
+ (kill-buffer showbuf)
+ (jump-to-register ?l)
+ (clear-register ?l))))
+ (pop-to-buffer showbuf)
+ (shrink-window-if-larger-than-buffer)))
+
+(defun sy-git-blame-log-mouse (e)
+ (interactive "e")
+ (let ((extent (extent-at-event e 'blame)))
+ (sy-git-blame-log extent)))
+
+(defun sy-git-blame-show (&optional extent)
+ "*Display git commit who's sha is stored in EXTENT.
+
+This command should only ever be called from within a Git Blame
+buffer."
+ (interactive)
+ (unless (string-match "GIT Blame" (buffer-name))
+ (error 'invalid-operation this-command
+ "Can only be called from the Blame buffer"))
+ (let* ((extent (or extent
+ (extent-at (point) nil 'blame)))
+ (revstr (extent-property extent 'brev))
+ (showbuf (format "*GIT Show::%s*" revstr))
+ (gitcmd "show")
+ (cb (current-buffer)))
+ (window-configuration-to-register ?s)
+ (with-current-buffer (get-buffer-create showbuf)
+ (erase-buffer)
+ (sy-git-run-buffer showbuf gitcmd revstr)
+ (goto-char (point-min))
+ (view-mode cb #'(lambda (showbuf)
+ (kill-buffer showbuf)
+ (jump-to-register ?s)
+ (clear-register ?s))))
+ (pop-to-buffer showbuf)
+ (shrink-window-if-larger-than-buffer)))
+
+(defun sy-git-blame-show-mouse (e)
+ (interactive "e")
+ (let ((extent (extent-at-event e 'blame)))
+ (sy-git-blame-show extent)))
+
+(defvar sy-git-blame-map
+ (let ((map (make-sparse-keymap 'sy-git-blame-map)))
+ (define-key map [s] #'sy-git-blame-show)
+ (define-key map [l] #'sy-git-blame-log)
+ (define-key map [button1] #'sy-git-blame-show-mouse)
+ (define-key map [button2] #'sy-git-blame-log-mouse)
+ map)
+ "Keymap for blame extents.")
+
+(defun sy-git-process-blame-buffer ()
+ "Processes the content of the blame BUFFER.
+Adds margin, extents, keymaps, etc."
+ (let ((regex #r"\(^[a-f0-9]+\)\s-+[0-9]+) ")
+ (hash (make-hash-table :size 1024 :test #'equal)))
+ (set-specifier left-margin-width 9 (current-buffer))
+ (goto-char (point-min))
+ (save-excursion
+ (working-status-forms "Blaming %s" "done"
+ (while (re-search-forward regex nil t)
+ (working-status nil (substring (buffer-name) 12 -1))
+ (let ((blamerev (match-string 1))
+ (buf (get-buffer-create "*sy-git-extents*"))
+ bhelp khelp ext)
+ (delete-region (match-beginning 0) (match-end 0))
+ ;; skip uncommitted and blank lines
+ (unless (or (string= blamerev "00000000")
+ (zerop (length
+ (buffer-substring
+ (point-at-bol) (point-at-eol)))))
+ (if (not (gethash blamerev hash))
+ ;; A new rev, set up extent
+ (progn
+ (puthash blamerev (point) hash)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert
+ (sy-git-run-string "show"
+ (split-string
+ (concat "--format=\"[Keys:s,l,b1,b2] [%h] %an "
+ "%ai%ncommit: %H%nAuthor: %an <%ae>%n"
+ "Date: %>(33)%ad%n%n %s\" --summary "
+ blamerev " |head -n8"))))
+ (goto-char (point-min))
+ (setq khelp (buffer-substring
+ (point-at-bol) (point-at-eol)))
+ (delete-region (point-at-bol) (point-at-eol))
+ (setq bhelp (buffer-string)))
+ (kill-buffer buf)
+ (setq ext (make-extent
+ (point-at-bol) (point-at-eol)))
+ (set-extent-properties
+ ext
+ `(mouse-face highlight keymap ,sy-git-blame-map
+ help-echo ,khelp balloon-help ,bhelp
+ blame t brev ,blamerev))
+ (set-extent-begin-glyph
+ ext
+ (make-glyph blamerev) 'outside-margin))
+ ;; A previous rev, just set extent parent
+ (setq ext (make-extent (point-at-bol) (point-at-eol)))
+ (set-extent-parent
+ ext (extent-at
+ (gethash blamerev hash) nil 'blame))))))
+ (working-status t (substring (buffer-name) 12 -1))))))
+
+(defun sy-git-blame ()
+ "*Display git blame for the current file.
+
+If the region is active the output will be for just the lines of the
+file within the region."
+ (interactive)
+ (let ((gitcmd "blame")
+ (cb (current-buffer))
+ (gb (format "*GIT Blame::%s*"
+ (file-basename (buffer-file-name))))
+ (args (list (file-basename (buffer-file-name))))
+ (cmm major-mode)
+ beg end)
+ (when (region-active-p)
+ (setq beg (line-number (region-beginning))
+ end (line-number (region-end))))
+ (and beg end
+ (push (format "-L%d,%d" beg end) args))
+ ;; We want -s for nicer, less verbose output and --root for
+ ;; boundary commits
+ (setq args (append '("-s" "--root") args))
+ (sy-git-run-buffer gb gitcmd args)
+ (window-configuration-to-register ?G)
+ (with-current-buffer gb
+ (setq truncate-lines t)
+ (funcall cmm)
+ (sy-git-process-blame-buffer)
+ (view-mode cb #'(lambda (gb)
+ (kill-buffer gb)
+ (jump-to-register ?G)
+ (clear-register ?G))))
+ (pop-to-buffer gb)
+ (shrink-window-if-larger-than-buffer)))
+
+;;; log
+(defun sy-git-log (opts)
+ "*Display git log of current file.
+
+With one prefix arg, OPTS, display the log for the entire repo.
+With two prefix args, prompt for options to pass to git-log.
+
+The default options used are: `--shortstat', except when two prefix
+args are used and then the only options used are those the user
+supplies."
+ (interactive "P")
+ (let ((cb (current-buffer))
+ (gb "*GIT Log::%s*")
+ (gitcmd "log")
+ args)
+ (case (car opts)
+ ;; 1 prefix arg, log for whole repo
+ (4 (setq args '("--shortstat")
+ gb (format gb "Whole Repo")))
+ ;; 2 prefix args, prompt for options
+ (16 (setq args (split-string (read-string "Git Log options: "))
+ gb (format gb "Custom")))
+ ;; default, show log of current file
+ (otherwise (setq args (list "--shortstat"
+ (file-basename (buffer-file-name)))
+ gb (format gb (file-basename
+ (buffer-file-name))))))
+ (sy-git-run-buffer gb gitcmd args)
+ (window-configuration-to-register ?L)
+ (with-current-buffer gb
+ (set (make-local-variable 'font-lock-defaults)
+ '(sy-git-log-font-lock-keywords t t))
+ (goto-char (point-min))
+ (view-mode cb #'(lambda (gb)
+ (kill-buffer gb)
+ (jump-to-register ?L)
+ (clear-register ?L))))
+ (pop-to-buffer gb)
+ (shrink-window-if-larger-than-buffer)))
+
+;;; add-log
(defun sy-git-add-log-entry (&optional newlog)
"*A wrapper for `add-change-log-entry'.
"
(interactive "p")
- (let* ((topd (substring (shell-command-to-string
- "git rev-parse --show-toplevel") 0 -1))
+ (let* ((topd (substring (sy-git-run-string "rev-parse"
+ "--show-toplevel") 0 -1))
(logfile (expand-file-name "++log" topd))
(hookd (paths-construct-path `(,topd ".git" "hooks")))
(msg-hook (expand-file-name "commit-msg" hookd))
(commit-hook (expand-file-name "post-commit" hookd))
- (add-log-full-name (substring (shell-command-to-string
- "git config user.name") 0 -1))
- (add-log-mailing-address (substring (shell-command-to-string
- "git config user.email") 0 -1))
+ (add-log-full-name (substring (sy-git-run-string "config"
+ "user.name") 0 -1))
+ (add-log-mailing-address (substring (sy-git-run-string "config"
+ "user.email") 0 -1))
(add-log-keep-changes-together t)
(header (concat
(format-time-string "%Y-%m-%d")
(unless (search-forward newhead nil t)
(insert newhead "\n\n\n")))))
+;;; keymap/mode/hook stuffs
+(defvar sy-git-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-name map 'sy-git-mode-map)
+ (define-key map [(control ?x) ?G ?a] #'sy-git-add-log-entry)
+ (define-key map [(control ?x) ?G ?=] #'sy-git-diff)
+ (define-key map [(control ?x) ?G ?d] #'sy-git-diff)
+ (define-key map [(control ?x) ?G ?e] #'sy-git-ediff)
+ (define-key map [(control ?x) ?G ?l] #'sy-git-log)
+ (define-key map [(control ?x) ?G ?b] #'sy-git-blame)
+ map)
+ "Keys for use in sy-git-mode.")
+
+(define-minor-mode sy-git-mode
+ "A minor mode to pretty much do nothing but hold keymap.
+\\{sy-git-mode-map}."
+ :lighter " SY/Git"
+ :keymap 'sy-git-mode-map)
+
+(defun sy-git-activate-maybe ()
+ "Maybe turn on `sy-git-mode'."
+ (and (eq (vc-file-getprop (buffer-file-name) 'vc-backend) 'GIT)
+ (sy-git-mode)))
-(global-set-key [(control x) G a] #'sy-git-add-log-entry)
+(add-hook 'find-file-hooks #'sy-git-activate-maybe 'append)
(provide 'sy-git)
;;; sy-git.el ends here
projects / slh / blobdiff