1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
;; Copyright (C) 2012-2017, 2023 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; To enable in all Dired buffers, add this to your init file:
;;
;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode)
;;
;; or
;;
;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode-unless-remote)
;;
;; to do it only in local Dired buffers.
;;; Code:
(require 'diff-hl)
(require 'dired)
(require 'vc-hooks)
(defvar diff-hl-dired-process-buffer nil)
(defgroup diff-hl-dired nil
"VC diff highlighting on the side of a Dired window."
:group 'diff-hl)
(defface diff-hl-dired-insert
'((default :inherit diff-hl-insert))
"Face used to highlight added files.")
(defface diff-hl-dired-delete
'((default :inherit diff-hl-delete))
"Face used to highlight directories with deleted files.")
(defface diff-hl-dired-change
'((default :inherit diff-hl-change))
"Face used to highlight changed files.")
(defface diff-hl-dired-unknown
'((default :inherit dired-ignored))
"Face used to highlight unregistered files.")
(defface diff-hl-dired-ignored
'((default :inherit dired-ignored))
"Face used to highlight unregistered files.")
(defcustom diff-hl-dired-extra-indicators t
"Non-nil to indicate ignored files."
:type 'boolean)
(defcustom diff-hl-dired-ignored-backends '(RCS)
"VC backends to ignore.
The directories registered to one of these backends won't have
status indicators."
:type `(repeat (choice ,@(mapcar
(lambda (name)
`(const :tag ,(symbol-name name) ,name))
vc-handled-backends))))
;;;###autoload
(define-minor-mode diff-hl-dired-mode
"Toggle VC diff highlighting on the side of a Dired window."
:lighter ""
(if diff-hl-dired-mode
(progn
(diff-hl-maybe-define-bitmaps)
(set (make-local-variable 'diff-hl-dired-process-buffer) nil)
(add-hook 'dired-after-readin-hook 'diff-hl-dired-update nil t))
(remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
(diff-hl-dired-clear)))
(defun diff-hl-dired-update ()
"Highlight the Dired buffer."
(let ((backend (ignore-errors (vc-responsible-backend default-directory)))
(def-dir default-directory)
(buffer (current-buffer))
dirs-alist files-alist)
(when (and backend (not (memq backend diff-hl-dired-ignored-backends)))
(diff-hl-dired-clear)
(if (buffer-live-p diff-hl-dired-process-buffer)
(let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
(when proc (kill-process proc)))
(setq diff-hl-dired-process-buffer
(generate-new-buffer " *diff-hl-dired* tmp status")))
(with-current-buffer diff-hl-dired-process-buffer
(setq default-directory (expand-file-name def-dir))
(erase-buffer)
(diff-hl-dired-status-files
backend def-dir
(when diff-hl-dired-extra-indicators
(cl-loop for file in (directory-files def-dir)
unless (member file '("." ".." ".hg"))
collect file))
(lambda (entries &optional more-to-come)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(dolist (entry entries)
(cl-destructuring-bind (file state &rest r) entry
;; Work around http://debbugs.gnu.org/18605
(setq file (replace-regexp-in-string "\\` " "" file))
(let ((type (plist-get
'( edited change added insert removed delete
unregistered unknown ignored ignored)
state)))
(if (string-match "\\`\\([^/]+\\)/" file)
(let* ((dir (match-string 1 file))
(value (cdr (assoc dir dirs-alist))))
(unless (eq value type)
(cond
((eq state 'up-to-date))
((null value)
(push (cons dir type) dirs-alist))
((not (eq type 'ignored))
(setcdr (assoc dir dirs-alist) 'change)))))
(push (cons file type) files-alist)))))
(unless more-to-come
(diff-hl-dired-highlight-items
(append dirs-alist files-alist))))
(unless more-to-come
(kill-buffer diff-hl-dired-process-buffer))))
)))))
(defun diff-hl-dired-status-files (backend dir files update-function)
"Using version control BACKEND, return list of (FILE STATE EXTRA) entries
for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
(vc-call-backend backend 'dir-status-files dir files update-function))
(defun diff-hl-dired-highlight-items (alist)
"Highlight ALIST containing (FILE . TYPE) elements."
(dolist (pair alist)
(let ((file (car pair))
(type (cdr pair)))
(save-excursion
(goto-char (point-min))
(when (and type (dired-goto-file-1
file (expand-file-name file) nil))
(let* ((diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-type)
(diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
(o (diff-hl-add-highlighting type 'single)))
(overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
(overlay-put o 'diff-hl-dired-type type)
))))))
(defun diff-hl-dired-face-from-type (type _pos)
(intern (format "diff-hl-dired-%s" type)))
(defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays)
;;;###autoload
(defun diff-hl-dired-mode-unless-remote ()
(unless (file-remote-p default-directory)
(diff-hl-dired-mode)))
(provide 'diff-hl-dired)
;;; diff-hl-dired.el ends here
|
