diff-hl-dired.el (7192B)
1 ;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2012-2017, 2023 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 <https://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 state '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 (unless more-to-come 137 (kill-buffer diff-hl-dired-process-buffer)))) 138 ))))) 139 140 (defun diff-hl-dired-status-files (backend dir files update-function) 141 "Using version control BACKEND, return list of (FILE STATE EXTRA) entries 142 for DIR containing FILES. Call UPDATE-FUNCTION as entries are added." 143 (if (version< "25" emacs-version) 144 (vc-call-backend backend 'dir-status-files dir files update-function) 145 (vc-call-backend backend 'dir-status-files dir files nil update-function))) 146 147 (when (version< emacs-version "24.4.51.5") 148 ;; Work around http://debbugs.gnu.org/19386 149 (defadvice vc-git-dir-status-goto-stage (around 150 diff-hl-dired-skip-up-to-date 151 (stage files update-function) 152 activate) 153 (when (eq stage 'ls-files-up-to-date) 154 (setq stage 'diff-index)) 155 ad-do-it)) 156 157 (defun diff-hl-dired-highlight-items (alist) 158 "Highlight ALIST containing (FILE . TYPE) elements." 159 (dolist (pair alist) 160 (let ((file (car pair)) 161 (type (cdr pair))) 162 (save-excursion 163 (goto-char (point-min)) 164 (when (and type (dired-goto-file-1 165 file (expand-file-name file) nil)) 166 (let* ((diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-type) 167 (diff-hl-fringe-face-function 'diff-hl-dired-face-from-type) 168 (o (diff-hl-add-highlighting type 'single))) 169 (overlay-put o 'modification-hooks '(diff-hl-overlay-modified)) 170 (overlay-put o 'diff-hl-dired-type type) 171 )))))) 172 173 (defun diff-hl-dired-face-from-type (type _pos) 174 (intern (format "diff-hl-dired-%s" type))) 175 176 (defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays) 177 178 ;;;###autoload 179 (defun diff-hl-dired-mode-unless-remote () 180 (unless (file-remote-p default-directory) 181 (diff-hl-dired-mode))) 182 183 (provide 'diff-hl-dired) 184 185 ;;; diff-hl-dired.el ends here