Code

git-blame.el: separate git-blame-mode to ease maintenance
[git.git] / contrib / emacs / git-blame.el
1 ;;; git-blame.el --- Minor mode for incremental blame for Git  -*- coding: utf-8 -*-
2 ;;
3 ;; Copyright (C) 2007  David Kågedal
4 ;;
5 ;; Authors:    David Kågedal <davidk@lysator.liu.se>
6 ;; Created:    31 Jan 2007
7 ;; Message-ID: <87iren2vqx.fsf@morpheus.local>
8 ;; License:    GPL
9 ;; Keywords:   git, version control, release management
10 ;;
11 ;; Compatibility: Emacs21
14 ;; This file is *NOT* part of GNU Emacs.
15 ;; This file is distributed under the same terms as GNU Emacs.
17 ;; This program is free software; you can redistribute it and/or
18 ;; modify it under the terms of the GNU General Public License as
19 ;; published by the Free Software Foundation; either version 2 of
20 ;; the License, or (at your option) any later version.
22 ;; This program is distributed in the hope that it will be
23 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
24 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
25 ;; PURPOSE.  See the GNU General Public License for more details.
27 ;; You should have received a copy of the GNU General Public
28 ;; License along with this program; if not, write to the Free
29 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
30 ;; MA 02111-1307 USA
32 ;; http://www.fsf.org/copyleft/gpl.html
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;;
37 ;;; Commentary:
38 ;;
39 ;; Here is an Emacs implementation of incremental git-blame.  When you
40 ;; turn it on while viewing a file, the editor buffer will be updated by
41 ;; setting the background of individual lines to a color that reflects
42 ;; which commit it comes from.  And when you move around the buffer, a
43 ;; one-line summary will be shown in the echo area.
45 ;;; Installation:
46 ;;
47 ;; To use this package, put it somewhere in `load-path' (or add
48 ;; directory with git-blame.el to `load-path'), and add the following
49 ;; line to your .emacs:
50 ;;
51 ;;    (require 'git-blame)
52 ;;
53 ;; If you do not want to load this package before it is necessary, you
54 ;; can make use of the `autoload' feature, e.g. by adding to your .emacs
55 ;; the following lines
56 ;;
57 ;;    (autoload 'git-blame-mode "git-blame"
58 ;;              "Minor mode for incremental blame for Git." t)
59 ;;
60 ;; Then first use of `M-x git-blame-mode' would load the package.
62 ;;; Compatibility:
63 ;;
64 ;; It requires GNU Emacs 21.  If you'are using Emacs 20, try
65 ;; changing this:
66 ;;
67 ;;            (overlay-put ovl 'face (list :background
68 ;;                                         (cdr (assq 'color (cddddr info)))))
69 ;;
70 ;; to
71 ;;
72 ;;            (overlay-put ovl 'face (cons 'background-color
73 ;;                                         (cdr (assq 'color (cddddr info)))))
76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77 ;;
78 ;;; Code:
80 (require 'cl)                         ; to use `push', `pop'
82 (defun color-scale (l)
83   (let* ((colors ())
84          r g b)
85     (setq r l)
86     (while r
87       (setq g l)
88       (while g
89         (setq b l)
90         (while b
91           (push (concat "#" (car r) (car g) (car b)) colors)
92           (pop b))
93         (pop g))
94       (pop r))
95     colors))
97 (defvar git-blame-dark-colors
98   (color-scale '("0c" "04" "24" "1c" "2c" "34" "14" "3c")))
100 (defvar git-blame-light-colors
101   (color-scale '("c4" "d4" "cc" "dc" "f4" "e4" "fc" "ec")))
103 (defvar git-blame-ancient-color "dark green")
105 (defvar git-blame-autoupdate t
106   "*Automatically update the blame display while editing")
108 (defvar git-blame-proc nil
109   "The running git-blame process")
110 (make-variable-buffer-local 'git-blame-proc)
112 (defvar git-blame-overlays nil
113   "The git-blame overlays used in the current buffer.")
114 (make-variable-buffer-local 'git-blame-overlays)
116 (defvar git-blame-cache nil
117   "A cache of git-blame information for the current buffer")
118 (make-variable-buffer-local 'git-blame-cache)
120 (defvar git-blame-idle-timer nil
121   "An idle timer that updates the blame")
122 (make-variable-buffer-local 'git-blame-cache)
124 (defvar git-blame-update-queue nil
125   "A queue of update requests")
126 (make-variable-buffer-local 'git-blame-update-queue)
128 (defvar git-blame-mode nil)
129 (make-variable-buffer-local 'git-blame-mode)
131 (defvar git-blame-mode-line-string " blame"
132   "String to display on the mode line when git-blame is active.")
134 (or (assq 'git-blame-mode minor-mode-alist)
135     (setq minor-mode-alist
136           (cons '(git-blame-mode git-blame-mode-line-string) minor-mode-alist)))
138 ;;;###autoload
139 (defun git-blame-mode (&optional arg)
140   "Toggle minor mode for displaying Git blame
142 With prefix ARG, turn the mode on if ARG is positive."
143   (interactive "P")
144   (cond
145    ((null arg)
146     (if git-blame-mode (git-blame-mode-off) (git-blame-mode-on)))
147    ((> (prefix-numeric-value arg) 0) (git-blame-mode-on))
148    (t (git-blame-mode-off))))
150 (defun git-blame-mode-on ()
151   "Turn on git-blame mode.
153 See also function `git-blame-mode'."
154   (make-local-variable 'git-blame-colors)
155   (if git-blame-autoupdate
156       (add-hook 'after-change-functions 'git-blame-after-change nil t)
157     (remove-hook 'after-change-functions 'git-blame-after-change t))
158   (git-blame-cleanup)
159   (let ((bgmode (cdr (assoc 'background-mode (frame-parameters)))))
160     (if (eq bgmode 'dark)
161         (setq git-blame-colors git-blame-dark-colors)
162       (setq git-blame-colors git-blame-light-colors)))
163   (setq git-blame-cache (make-hash-table :test 'equal))
164   (setq git-blame-mode t)
165   (git-blame-run))
167 (defun git-blame-mode-off ()
168   "Turn off git-blame mode.
170 See also function `git-blame-mode'."
171   (git-blame-cleanup)
172   (if git-blame-idle-timer (cancel-timer git-blame-idle-timer))
173   (setq git-blame-mode nil))
175 ;;;###autoload
176 (defun git-reblame ()
177   "Recalculate all blame information in the current buffer"
178   (interactive)
179   (unless git-blame-mode
180     (error "git-blame is not active"))
182   (git-blame-cleanup)
183   (git-blame-run))
185 (defun git-blame-run (&optional startline endline)
186   (if git-blame-proc
187       ;; Should maybe queue up a new run here
188       (message "Already running git blame")
189     (let ((display-buf (current-buffer))
190           (blame-buf (get-buffer-create
191                       (concat " git blame for " (buffer-name))))
192           (args '("--incremental" "--contents" "-")))
193       (if startline
194           (setq args (append args
195                              (list "-L" (format "%d,%d" startline endline)))))
196       (setq args (append args
197                          (list (file-name-nondirectory buffer-file-name))))
198       (setq git-blame-proc
199             (apply 'start-process
200                    "git-blame" blame-buf
201                    "git" "blame"
202                    args))
203       (with-current-buffer blame-buf
204         (erase-buffer)
205         (make-local-variable 'git-blame-file)
206         (make-local-variable 'git-blame-current)
207         (setq git-blame-file display-buf)
208         (setq git-blame-current nil))
209       (set-process-filter git-blame-proc 'git-blame-filter)
210       (set-process-sentinel git-blame-proc 'git-blame-sentinel)
211       (process-send-region git-blame-proc (point-min) (point-max))
212       (process-send-eof git-blame-proc))))
214 (defun remove-git-blame-text-properties (start end)
215   (let ((modified (buffer-modified-p))
216         (inhibit-read-only t))
217     (remove-text-properties start end '(point-entered nil))
218     (set-buffer-modified-p modified)))
220 (defun git-blame-cleanup ()
221   "Remove all blame properties"
222     (mapcar 'delete-overlay git-blame-overlays)
223     (setq git-blame-overlays nil)
224     (remove-git-blame-text-properties (point-min) (point-max)))
226 (defun git-blame-update-region (start end)
227   "Rerun blame to get updates between START and END"
228   (let ((overlays (overlays-in start end)))
229     (while overlays
230       (let ((overlay (pop overlays)))
231         (if (< (overlay-start overlay) start)
232             (setq start (overlay-start overlay)))
233         (if (> (overlay-end overlay) end)
234             (setq end (overlay-end overlay)))
235         (setq git-blame-overlays (delete overlay git-blame-overlays))
236         (delete-overlay overlay))))
237   (remove-git-blame-text-properties start end)
238   ;; We can be sure that start and end are at line breaks
239   (git-blame-run (1+ (count-lines (point-min) start))
240                  (count-lines (point-min) end)))
242 (defun git-blame-sentinel (proc status)
243   (with-current-buffer (process-buffer proc)
244     (with-current-buffer git-blame-file
245       (setq git-blame-proc nil)
246       (if git-blame-update-queue
247           (git-blame-delayed-update))))
248   ;;(kill-buffer (process-buffer proc))
249   ;;(message "git blame finished")
250   )
252 (defvar in-blame-filter nil)
254 (defun git-blame-filter (proc str)
255   (save-excursion
256     (set-buffer (process-buffer proc))
257     (goto-char (process-mark proc))
258     (insert-before-markers str)
259     (goto-char 0)
260     (unless in-blame-filter
261       (let ((more t)
262             (in-blame-filter t))
263         (while more
264           (setq more (git-blame-parse)))))))
266 (defun git-blame-parse ()
267   (cond ((looking-at "\\([0-9a-f]\\{40\\}\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\)\n")
268          (let ((hash (match-string 1))
269                (src-line (string-to-number (match-string 2)))
270                (res-line (string-to-number (match-string 3)))
271                (num-lines (string-to-number (match-string 4))))
272            (setq git-blame-current
273                  (if (string= hash "0000000000000000000000000000000000000000")
274                      nil
275                    (git-blame-new-commit
276                     hash src-line res-line num-lines))))
277          (delete-region (point) (match-end 0))
278          t)
279         ((looking-at "filename \\(.+\\)\n")
280          (let ((filename (match-string 1)))
281            (git-blame-add-info "filename" filename))
282          (delete-region (point) (match-end 0))
283          t)
284         ((looking-at "\\([a-z-]+\\) \\(.+\\)\n")
285          (let ((key (match-string 1))
286                (value (match-string 2)))
287            (git-blame-add-info key value))
288          (delete-region (point) (match-end 0))
289          t)
290         ((looking-at "boundary\n")
291          (setq git-blame-current nil)
292          (delete-region (point) (match-end 0))
293          t)
294         (t
295          nil)))
298 (defun git-blame-new-commit (hash src-line res-line num-lines)
299   (save-excursion
300     (set-buffer git-blame-file)
301     (let ((info (gethash hash git-blame-cache))
302           (inhibit-point-motion-hooks t)
303           (inhibit-modification-hooks t))
304       (when (not info)
305         (let ((color (pop git-blame-colors)))
306           (unless color
307             (setq color git-blame-ancient-color))
308           (setq info (list hash src-line res-line num-lines
309                            (git-describe-commit hash)
310                            (cons 'color color))))
311         (puthash hash info git-blame-cache))
312       (goto-line res-line)
313       (while (> num-lines 0)
314         (if (get-text-property (point) 'git-blame)
315             (forward-line)
316           (let* ((start (point))
317                  (end (progn (forward-line 1) (point)))
318                  (ovl (make-overlay start end)))
319             (push ovl git-blame-overlays)
320             (overlay-put ovl 'git-blame info)
321             (overlay-put ovl 'help-echo hash)
322             (overlay-put ovl 'face (list :background
323                                          (cdr (assq 'color (nthcdr 5 info)))))
324             ;; the point-entered property doesn't seem to work in overlays
325             ;;(overlay-put ovl 'point-entered
326             ;;             `(lambda (x y) (git-blame-identify ,hash)))
327             (let ((modified (buffer-modified-p)))
328               (put-text-property (if (= start 1) start (1- start)) (1- end)
329                                  'point-entered
330                                  `(lambda (x y) (git-blame-identify ,hash)))
331               (set-buffer-modified-p modified))))
332         (setq num-lines (1- num-lines))))))
334 (defun git-blame-add-info (key value)
335   (if git-blame-current
336       (nconc git-blame-current (list (cons (intern key) value)))))
338 (defun git-blame-current-commit ()
339   (let ((info (get-char-property (point) 'git-blame)))
340     (if info
341         (car info)
342       (error "No commit info"))))
344 (defun git-describe-commit (hash)
345   (with-temp-buffer
346     (call-process "git" nil t nil
347                   "log" "-1" "--pretty=oneline"
348                   hash)
349     (buffer-substring (point-min) (1- (point-max)))))
351 (defvar git-blame-last-identification nil)
352 (make-variable-buffer-local 'git-blame-last-identification)
353 (defun git-blame-identify (&optional hash)
354   (interactive)
355   (let ((info (gethash (or hash (git-blame-current-commit)) git-blame-cache)))
356     (when (and info (not (eq info git-blame-last-identification)))
357       (message "%s" (nth 4 info))
358       (setq git-blame-last-identification info))))
360 ;; (defun git-blame-after-save ()
361 ;;   (when git-blame-mode
362 ;;     (git-blame-cleanup)
363 ;;     (git-blame-run)))
364 ;; (add-hook 'after-save-hook 'git-blame-after-save)
366 (defun git-blame-after-change (start end length)
367   (when git-blame-mode
368     (git-blame-enq-update start end)))
370 (defvar git-blame-last-update nil)
371 (make-variable-buffer-local 'git-blame-last-update)
372 (defun git-blame-enq-update (start end)
373   "Mark the region between START and END as needing blame update"
374   ;; Try to be smart and avoid multiple callouts for sequential
375   ;; editing
376   (cond ((and git-blame-last-update
377               (= start (cdr git-blame-last-update)))
378          (setcdr git-blame-last-update end))
379         ((and git-blame-last-update
380               (= end (car git-blame-last-update)))
381          (setcar git-blame-last-update start))
382         (t
383          (setq git-blame-last-update (cons start end))
384          (setq git-blame-update-queue (nconc git-blame-update-queue
385                                              (list git-blame-last-update)))))
386   (unless (or git-blame-proc git-blame-idle-timer)
387     (setq git-blame-idle-timer
388           (run-with-idle-timer 0.5 nil 'git-blame-delayed-update))))
390 (defun git-blame-delayed-update ()
391   (setq git-blame-idle-timer nil)
392   (if git-blame-update-queue
393       (let ((first (pop git-blame-update-queue))
394             (inhibit-point-motion-hooks t))
395         (git-blame-update-region (car first) (cdr first)))))
397 (provide 'git-blame)
399 ;;; git-blame.el ends here