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
  12
  13
  14 ;; This file is *NOT* part of GNU Emacs.
  15 ;; This file is distributed under the same terms as GNU Emacs.
  16
  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.
  21
  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.
  26
  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
  31
  32 ;; http://www.fsf.org/copyleft/gpl.html
  33
  34
  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.
  44
  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.
  61
  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)))))
  74
  75
  76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77 ;;
  78 ;;; Code:
  79
  80 (require 'cl)                         ; to use `push', `pop'
  81
  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))
  96
  97 (defvar git-blame-dark-colors
  98   (color-scale '("0c" "04" "24" "1c" "2c" "34" "14" "3c")))
  99
 100 (defvar git-blame-light-colors
 101   (color-scale '("c4" "d4" "cc" "dc" "f4" "e4" "fc" "ec")))
 102
 103 (defvar git-blame-ancient-color "dark green")
 104
 105 (defvar git-blame-autoupdate t
 106   "*Automatically update the blame display while editing")
 107
 108 (defvar git-blame-proc nil
 109   "The running git-blame process")
 110 (make-variable-buffer-local 'git-blame-proc)
 111
 112 (defvar git-blame-overlays nil
 113   "The git-blame overlays used in the current buffer.")
 114 (make-variable-buffer-local 'git-blame-overlays)
 115
 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)
 119
 120 (defvar git-blame-idle-timer nil
 121   "An idle timer that updates the blame")
 122 (make-variable-buffer-local 'git-blame-cache)
 123
 124 (defvar git-blame-update-queue nil
 125   "A queue of update requests")
 126 (make-variable-buffer-local 'git-blame-update-queue)
 127
 128 (defvar git-blame-mode nil)
 129 (make-variable-buffer-local 'git-blame-mode)
 130
 131 (defvar git-blame-mode-line-string " blame"
 132   "String to display on the mode line when git-blame is active.")
 133
 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)))
 137
 138 ;;;###autoload
 139 (defun git-blame-mode (&optional arg)
 140   "Toggle minor mode for displaying Git blame
 141
 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))))
 149
 150 (defun git-blame-mode-on ()
 151   "Turn on git-blame mode.
 152
 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))
 166
 167 (defun git-blame-mode-off ()
 168   "Turn off git-blame mode.
 169
 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))
 174
 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"))
 181
 182   (git-blame-cleanup)
 183   (git-blame-run))
 184
 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))))
 213
 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)))
 219
 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)))
 225
 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)))
 241
 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   )
 251
 252 (defvar in-blame-filter nil)
 253
 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)))))))
 265
 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)))
 296
 297
 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))))))
 333
 334 (defun git-blame-add-info (key value)
 335   (if git-blame-current
 336       (nconc git-blame-current (list (cons (intern key) value)))))
 337
 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"))))
 343
 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)))))
 350
 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))))
 359
 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)
 365
 366 (defun git-blame-after-change (start end length)
 367   (when git-blame-mode
 368     (git-blame-enq-update start end)))
 369
 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))))
 389
 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)))))
 396
 397 (provide 'git-blame)
 398
 399 ;;; git-blame.el ends here