code.delx.au - gnu-emacs-elpa/blob - diff-hl-dired.el

   1 ;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2013  Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; To enable in all Dired buffers, add this to your init file:
  23 ;;
  24 ;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode)
  25
  26 ;;; Code:
  27
  28 (require 'diff-hl)
  29
  30 (defvar diff-hl-dired-process-buffer nil)
  31
  32 ;;;###autoload
  33 (define-minor-mode diff-hl-dired-mode
  34   "Toggle VC diff highlighting on the side of a Dired window."
  35   :lighter ""
  36   (if diff-hl-dired-mode
  37       (progn
  38         (diff-hl-maybe-define-bitmaps)
  39         (set (make-local-variable 'diff-hl-dired-process-buffer) nil)
  40         (add-hook 'dired-after-readin-hook 'diff-hl-dired-update nil t))
  41     (remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
  42     (diff-hl-dired-clear)))
  43
  44 (defun diff-hl-dired-update ()
  45   "Highlight the Dired buffer."
  46   (let ((backend (ignore-errors (vc-responsible-backend default-directory)))
  47         (def-dir default-directory)
  48         (buffer (current-buffer))
  49         dirs-alist files-alist)
  50     (when backend
  51       (diff-hl-dired-clear)
  52       (if (buffer-live-p diff-hl-dired-process-buffer)
  53           (let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
  54             (when proc (kill-process proc)))
  55         (setq diff-hl-dired-process-buffer
  56               (generate-new-buffer " *diff-hl-dired* tmp status")))
  57       (with-current-buffer diff-hl-dired-process-buffer
  58         (setq default-directory (expand-file-name def-dir))
  59         (erase-buffer)
  60         (vc-call-backend
  61          backend 'dir-status def-dir
  62          (lambda (entries &optional _more-to-come)
  63            (with-current-buffer buffer
  64              (dolist (entry entries)
  65                (cl-destructuring-bind (file state &rest) entry
  66                  (let ((type (plist-get
  67                               '(edited change added insert removed delete
  68                                 unregistered unknown)
  69                               state)))
  70                    (if (string-match "\\`\\([^/]+\\)/" file)
  71                        (let* ((dir (match-string 1 file))
  72                               (value (cdr (assoc dir dirs-alist))))
  73                          (unless (eq value type)
  74                            (if (null value)
  75                                (push (cons dir type) dirs-alist)
  76                              (setcdr (assoc dir dirs-alist) 'change))))
  77                      (push (cons file type) files-alist)))))
  78              ;; Process's finished, time to use the results.
  79              (unless (get-buffer-process diff-hl-dired-process-buffer)
  80                (diff-hl-dired-highlight-items (append dirs-alist
  81                                                       files-alist)))))
  82          )))))
  83
  84 (defun diff-hl-dired-highlight-items (alist)
  85   "Highlight ALIST containing (FILE . TYPE) elements."
  86   (dolist (pair alist)
  87     (let ((file (car pair))
  88           (type (cdr pair)))
  89       (save-excursion
  90         (goto-char (point-min))
  91         (when (and type (dired-goto-file-1
  92                          file (expand-file-name file) nil))
  93           (let* ((diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-type)
  94                  (o (diff-hl-add-highlighting type 'single)))
  95             (overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
  96             ))))))
  97
  98 (defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays)
  99
 100 (provide 'diff-hl-dired)
 101
 102 ;;; diff-hl-dired.el ends here