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

   1 ;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2015  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 ;; or
  27 ;;
  28 ;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode-unless-remote)
  29 ;;
  30 ;; to do it only in local Dired buffers.
  31
  32 ;;; Code:
  33
  34 (require 'diff-hl)
  35 (require 'dired)
  36 (require 'vc-hooks)
  37
  38 (defvar diff-hl-dired-process-buffer nil)
  39
  40 (defgroup diff-hl-dired nil
  41   "VC diff highlighting on the side of a Dired window."
  42   :group 'diff-hl)
  43
  44 (defface diff-hl-dired-insert
  45   '((default :inherit diff-hl-insert))
  46   "Face used to highlight added files.")
  47
  48 (defface diff-hl-dired-delete
  49   '((default :inherit diff-hl-delete))
  50   "Face used to highlight directories with deleted files.")
  51
  52 (defface diff-hl-dired-change
  53   '((default :inherit diff-hl-change))
  54   "Face used to highlight changed files.")
  55
  56 (defface diff-hl-dired-unknown
  57   '((default :inherit dired-ignored))
  58   "Face used to highlight unregistered files.")
  59
  60 (defface diff-hl-dired-ignored
  61   '((default :inherit dired-ignored))
  62   "Face used to highlight unregistered files.")
  63
  64 (defcustom diff-hl-dired-extra-indicators t
  65   "Non-nil to indicate ignored files."
  66   :type 'boolean)
  67
  68 (defcustom diff-hl-dired-ignored-backends '(RCS)
  69   "VC backends to ignore.
  70 The directories registered to one of these backends won't have
  71 status indicators."
  72   :type `(repeat (choice ,@(mapcar
  73                             (lambda (name)
  74                               `(const :tag ,(symbol-name name) ,name))
  75                             vc-handled-backends))))
  76
  77 ;;;###autoload
  78 (define-minor-mode diff-hl-dired-mode
  79   "Toggle VC diff highlighting on the side of a Dired window."
  80   :lighter ""
  81   (if diff-hl-dired-mode
  82       (progn
  83         (diff-hl-maybe-define-bitmaps)
  84         (set (make-local-variable 'diff-hl-dired-process-buffer) nil)
  85         (add-hook 'dired-after-readin-hook 'diff-hl-dired-update nil t))
  86     (remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
  87     (diff-hl-dired-clear)))
  88
  89 (defun diff-hl-dired-update ()
  90   "Highlight the Dired buffer."
  91   (let ((backend (ignore-errors (vc-responsible-backend default-directory)))
  92         (def-dir default-directory)
  93         (buffer (current-buffer))
  94         dirs-alist files-alist)
  95     (when (and backend (not (memq backend diff-hl-dired-ignored-backends)))
  96       (diff-hl-dired-clear)
  97       (if (buffer-live-p diff-hl-dired-process-buffer)
  98           (let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
  99             (when proc (kill-process proc)))
 100         (setq diff-hl-dired-process-buffer
 101               (generate-new-buffer " *diff-hl-dired* tmp status")))
 102       (with-current-buffer diff-hl-dired-process-buffer
 103         (setq default-directory (expand-file-name def-dir))
 104         (erase-buffer)
 105         (diff-hl-dired-status-files
 106          backend def-dir
 107          (when diff-hl-dired-extra-indicators
 108            (cl-loop for file in (directory-files def-dir)
 109                     unless (member file '("." ".." ".hg"))
 110                     collect file))
 111          (lambda (entries &optional more-to-come)
 112            (when (buffer-live-p buffer)
 113              (with-current-buffer buffer
 114                (dolist (entry entries)
 115                  (cl-destructuring-bind (file state &rest r) entry
 116                    ;; Work around http://debbugs.gnu.org/18605
 117                    (setq file (replace-regexp-in-string "\\` " "" file))
 118                    (let ((type (plist-get
 119                                 '(edited change added insert removed delete
 120                                   unregistered unknown ignored ignored)
 121                                 state)))
 122                      (if (string-match "\\`\\([^/]+\\)/" file)
 123                          (let* ((dir (match-string 1 file))
 124                                 (value (cdr (assoc dir dirs-alist))))
 125                            (unless (eq value type)
 126                              (cond
 127                               ((eq type 'up-to-date))
 128                               ((null value)
 129                                (push (cons dir type) dirs-alist))
 130                               ((not (eq type 'ignored))
 131                                (setcdr (assoc dir dirs-alist) 'change)))))
 132                        (push (cons file type) files-alist)))))
 133                (unless more-to-come
 134                  (diff-hl-dired-highlight-items
 135                   (append dirs-alist files-alist))))))
 136          )))))
 137
 138 (defun diff-hl-dired-status-files (backend dir files update-function)
 139    "Using version control BACKEND, return list of (FILE STATE EXTRA) entries
 140 for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
 141   (if (version< "25" emacs-version)
 142       (vc-call-backend backend 'dir-status-files dir files update-function)
 143     (vc-call-backend backend 'dir-status-files dir files nil update-function)))
 144
 145 (when (version< emacs-version "24.4.51.5")
 146   ;; Work around http://debbugs.gnu.org/19386
 147   (defadvice vc-git-dir-status-goto-stage (around
 148                                             diff-hl-dired-skip-up-to-date
 149                                             (stage files update-function)
 150                                             activate)
 151     (when (eq stage 'ls-files-up-to-date)
 152       (setq stage 'diff-index))
 153     ad-do-it))
 154
 155 (defun diff-hl-dired-highlight-items (alist)
 156   "Highlight ALIST containing (FILE . TYPE) elements."
 157   (dolist (pair alist)
 158     (let ((file (car pair))
 159           (type (cdr pair)))
 160       (save-excursion
 161         (goto-char (point-min))
 162         (when (and type (dired-goto-file-1
 163                          file (expand-file-name file) nil))
 164           (let* ((diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-type)
 165                  (diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
 166                  (o (diff-hl-add-highlighting type 'single)))
 167             (overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
 168             ))))))
 169
 170 (defun diff-hl-dired-face-from-type (type _pos)
 171   (intern (format "diff-hl-dired-%s" type)))
 172
 173 (defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays)
 174
 175 ;;;###autoload
 176 (defun diff-hl-dired-mode-unless-remote ()
 177   (unless (file-remote-p default-directory)
 178     (diff-hl-dired-mode)))
 179
 180 (provide 'diff-hl-dired)
 181
 182 ;;; diff-hl-dired.el ends here