mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-17 c4001ccd1864293b64aa37d83a9d9457eb875e70
commit | author | age
5cb5f7 1 ;;; ztree-diff-model.el --- diff model for directory trees -*- lexical-binding: t; -*-
C 2
3 ;; Copyright (C) 2013-2016  Free Software Foundation, Inc.
4 ;;
5 ;; Author: Alexey Veretennikov <alexey.veretennikov@gmail.com>
6 ;;
7 ;; Created: 2013-11-11
8 ;;
9 ;; Keywords: files tools
10 ;; URL: https://github.com/fourier/ztree
11 ;; Compatibility: GNU Emacs 24.x
12 ;;
13 ;; This file is part of GNU Emacs.
14 ;;
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
19 ;;
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 ;; GNU General Public License for more details.
24 ;;
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
27 ;;
28 ;;; Commentary:
29
30 ;; Diff model
31
32 ;;; Code:
33 (require 'ztree-util)
34 (eval-when-compile (require 'cl-lib))
35
36 (defvar ztree-diff-consider-file-permissions nil
37   "Mark files as different if their permissions are different")
38
39 (defvar ztree-diff-additional-options nil
40   "Command-line options for the diff program used as a diff backend. These options are added to default '-q' option.
41 Should be a list of strings.
42 Example:
43 (setq ztree-diff-options '(\"-w\" \"-i\"))")
44
45
46 (defvar-local ztree-diff-model-ignore-fun nil
47   "Function which determines if the node should be excluded from comparison.")
48
49 (defvar-local ztree-diff-model-progress-fun nil
50   "Function which should be called whenever the progress indications is updated.")
51
52
53 (defun ztree-diff-model-update-progress ()
54   "Update the progress."
55   (when ztree-diff-model-progress-fun
56     (funcall ztree-diff-model-progress-fun)))
57
58 ;; Create a record ztree-diff-node with defined fields and getters/setters
59 ;; here:
60 ;; parent - parent node
61 ;; left-path is the full path on the left side of the diff window,
62 ;; right-path is the full path of the right side,
63 ;; short-name - is the file or directory name
64 ;; children - list of nodes - files or directories if the node is a directory
65 ;; different = {nil, 'same, 'new, 'diff, 'ignore} - means comparison status
66 (cl-defstruct (ztree-diff-node
67                (:constructor)
68                (:constructor ztree-diff-node-create
69                 (parent left-path right-path
70                         different
71                         &aux
72                         (short-name (ztree-file-short-name
73                                      (or left-path right-path)))
74                         (right-short-name
75                          (if (and left-path right-path)
76                              (ztree-file-short-name right-path)
77                            short-name)))))
78   parent left-path right-path short-name right-short-name children different)
79
80 (defun ztree-diff-model-ignore-p (node)
81   "Determine if the NODE should be excluded from comparison results."
82   (when ztree-diff-model-ignore-fun
83     (funcall ztree-diff-model-ignore-fun node)))
84
85 (defun ztree-diff-node-to-string (node)
86   "Construct the string with contents of the NODE given."
87   (let ((string-or-nil #'(lambda (x) (if x
88                                          (cond ((stringp x) x)
89                                                ((eq x 'new) "new")
90                                                ((eq x 'diff) "different")
91                                                ((eq x 'ignore) "ignored")
92                                                ((eq x 'same) "same")
93                                                (t (ztree-diff-node-short-name x)))
94                                        "(empty)")))
95         (children (ztree-diff-node-children node))
96         (ch-str ""))
97     (dolist (x children)
98       (setq ch-str (concat ch-str "\n   * " (ztree-diff-node-short-name x)
99                            ": "
100                            (funcall string-or-nil (ztree-diff-node-different x)))))
101     (concat "Node: " (ztree-diff-node-short-name node)
102             "\n"
103             " * Parent: " (funcall string-or-nil (ztree-diff-node-parent node))
104             "\n"
105             " * Status: " (funcall string-or-nil (ztree-diff-node-different node))
106             "\n"
107             " * Left path: " (funcall string-or-nil (ztree-diff-node-left-path node))
108             "\n"
109             " * Right path: " (funcall string-or-nil (ztree-diff-node-right-path node))
110             "\n"
111             " * Children: " ch-str
112             "\n")))
113
114
115 (defun ztree-diff-node-short-name-wrapper (node &optional right-side)
116   "Return the short name of the NODE given.
117 If the RIGHT-SIDE is true, take the right leaf"
118   (if (not right-side)
119       (ztree-diff-node-short-name node)
120     (ztree-diff-node-right-short-name node)))
121
122
123 (defun ztree-diff-node-is-directory (node)
124   "Determines if the NODE is a directory."
125   (let ((left (ztree-diff-node-left-path node))
126         (right (ztree-diff-node-right-path node)))
127     (if left
128         (file-directory-p left)
129       (file-directory-p right))))
130
131 (defun ztree-diff-node-side (node)
132   "Determine the side there the file is present for NODE.
133 Return BOTH if the file present on both sides;
134 LEFT if only on the left side and
135 RIGHT if only on the right side."
136   (let ((left (ztree-diff-node-left-path node))
137         (right (ztree-diff-node-right-path node)))
138     (if (and left right) 'both
139       (if left 'left 'right))))
140
141
142 (defun ztree-diff-node-equal (node1 node2)
143   "Determines if NODE1 and NODE2 are equal."
144   (and (string-equal (ztree-diff-node-short-name node1)
145                      (ztree-diff-node-short-name node2))
146        (string-equal (ztree-diff-node-left-path node1)
147                      (ztree-diff-node-left-path node2))
148        (string-equal (ztree-diff-node-right-path node1)
149                      (ztree-diff-node-right-path node1))))
150
151 (defun ztree-diff-model-files-equal (file1 file2)
152   "Compare files FILE1 and FILE2 using external diff.
153 Returns t if equal."
154   (unless (ztree-same-host-p file1 file2)
155     (error "Compared files are not on the same host"))
156   (let* ((file1-untrampified (ztree-untrampify-filename file1))
157          (file2-untrampified (ztree-untrampify-filename file2)))
158     (if (or
159          (/= (nth 7 (file-attributes file1))
160              (nth 7 (file-attributes file2)))
161          (and ztree-diff-consider-file-permissions
162               (not (string-equal (nth 8 (file-attributes file1))
163                                  (nth 8 (file-attributes file2)))))
164          (/= 0
165              (apply #'process-file
166                     diff-command nil nil nil
167                     `("-q" ,@ztree-diff-additional-options
168                       ,file1-untrampified
169                       ,file2-untrampified))))
170         'diff
171       'same)))
172
173 (defun ztree-directory-files (dir)
174   "Return the list of full paths of files in a directory DIR.
175 Filters out . and .."
176   (ztree-filter #'(lambda (file) (let ((simple-name (ztree-file-short-name file)))
177                                    (not (or (string-equal simple-name ".")
178                                             (string-equal simple-name "..")))))
179                 (directory-files dir 'full)))
180
181 (defun ztree-diff-model-partial-rescan (node)
182   "Rescan the NODE.
183 The node is a either a file or directory with both
184 left and right parts existing."
185   ;; if a directory - recreate
186   (if (ztree-diff-node-is-directory node)
187       (ztree-diff-node-recreate node)
188     ;; if a file, change a status
189     (setf (ztree-diff-node-different node)
190           (if (or (ztree-diff-model-ignore-p node) ; if should be ignored
191                   (eql (ztree-diff-node-different node) 'ignore) ; was ignored
192                   (eql (ztree-diff-node-different ; or parent was ignored
193                         (ztree-diff-node-parent node))
194                        'ignore))
195               'ignore
196             (ztree-diff-model-files-equal (ztree-diff-node-left-path node)
197                                           (ztree-diff-node-right-path node)))))
198   ;; update all parents statuses
199   (ztree-diff-node-update-all-parents-diff node))
200
201 (defun ztree-diff-model-subtree (parent path side diff)
202   "Create a subtree with given PARENT for the given PATH.
203 Argument SIDE either `left' or `right' side.
204 Argument DIFF different status to be assigned to all created nodes."
205   (let ((files (ztree-directory-files path))
206         (result nil))
207     (dolist (file files)
208       (if (file-directory-p file)
209           (let* ((node (ztree-diff-node-create
210                         parent
211                         (when (eq side 'left) file)
212                         (when (eq side 'right) file)
213                         diff))
214                  (children (ztree-diff-model-subtree node file side diff)))
215             (setf (ztree-diff-node-children node) children)
216             (push node result))
217         (push (ztree-diff-node-create
218                parent
219                (when (eq side 'left) file)
220                (when (eq side 'right) file)
221                diff)
222               result)))
223     result))
224
225 (defun ztree-diff-node-update-diff-from-children (node)
226   "Set the diff status for the NODE based on its children."
227   (unless (eql (ztree-diff-node-different node) 'ignore)
228     (let ((diff (cl-reduce #'ztree-diff-model-update-diff
229                            (ztree-diff-node-children node)
230                            :initial-value 'same
231                            :key 'ztree-diff-node-different)))
232       (setf (ztree-diff-node-different node) diff))))
233
234 (defun ztree-diff-node-update-all-parents-diff (node)
235   "Recursively update all parents diff status for the NODE."
236   (let ((parent node))
237     (while (setq parent (ztree-diff-node-parent parent))
238       (ztree-diff-node-update-diff-from-children parent))))
239
240
241 (defun ztree-diff-model-update-diff (old new)
242   "Get the diff status depending if OLD or NEW is not nil.
243 If the OLD is `ignore', do not change anything"
244   ;; if the old whole directory is ignored, ignore children's status
245   (cond ((eql old 'ignore) 'ignore)
246         ;; if the new status is ignored, use old
247         ((eql new 'ignore) old)
248         ;; if the old or new status is different, return different
249         ((or (eql old 'diff)
250              (eql new 'diff)) 'diff)
251         ;; if new is 'new, return new
252         ((eql new 'new) 'new)
253         ;; all other cases return old
254         (t old)))
255
256 (defun ztree-diff-node-update-diff-from-parent (node)
257   "Recursively update diff status of all children of NODE.
258 This function will traverse through all children recursively
259 setting status from the NODE, unless they have an ignore status"
260   (let ((status (ztree-diff-node-different node))
261         (children (ztree-diff-node-children node)))
262     ;; if the parent has ignore status, force all kids this status
263     ;; otherwise only update status when the child status is not ignore
264     (mapc (lambda (child)
265             (when (or (eql status 'ignore)
266                       (not
267                        (or (eql status 'ignore)
268                            (eql (ztree-diff-node-different child) 'ignore))))
269               (setf (ztree-diff-node-different child) status)
270               (ztree-diff-node-update-diff-from-parent child)))
271             children)))
272
273
274
275 (defun ztree-diff-model-find-in-files (list shortname is-dir)
276   "Find in LIST of files the file with name SHORTNAME.
277 If IS-DIR searching for directories; assume files otherwise"
278   (ztree-find list
279               (lambda (x) (and (string-equal (ztree-file-short-name x)
280                                              shortname)
281                                (eq is-dir (file-directory-p x))))))
282
283
284 (defun ztree-diff-model-should-ignore (node)
285   "Determine if the NODE and its children should be ignored.
286 If no parent - never ignore;
287 if in ignore list - ignore
288 if parent has ignored status - ignore"
289   (let ((parent (ztree-diff-node-parent node)))
290     (and parent
291          (or (eql (ztree-diff-node-different parent) 'ignore)
292              (ztree-diff-model-ignore-p node)))))
293
294
295 (defun ztree-diff-node-recreate (node)
296   "Traverse 2 paths defined in the NODE updating its children and status."
297   (let* ((list1 (ztree-directory-files (ztree-diff-node-left-path node))) ;; left list of liles
298          (list2 (ztree-directory-files (ztree-diff-node-right-path node))) ;; right list of files
299          (should-ignore (ztree-diff-model-should-ignore node))
300          ;; status automatically assigned to children of the node
301          (children-status (if should-ignore 'ignore 'new))
302          (children nil))    ;; list of children
303     ;; update waiting status
304     (ztree-diff-model-update-progress)
305     ;; update node status ignore status either inhereted from the
306     ;; parent or the own
307     (when should-ignore
308       (setf (ztree-diff-node-different node) 'ignore))
309     ;; first - adding all entries from left directory
310     (dolist (file1 list1)
311       ;; for every entry in the first directory
312       ;; we are creating the node
313       (let* ((simple-name (ztree-file-short-name file1))
314              (isdir (file-directory-p file1))
315              ;; find if the file is in the second directory and the type
316              ;; is the same - i.e. both are directories or both are files
317              (file2 (ztree-diff-model-find-in-files list2 simple-name isdir))
318              ;; create a child. The current node is a parent
319              ;; new by default - will be overriden below if necessary
320              (child
321               (ztree-diff-node-create node file1 file2 children-status)))
322         ;; update child own ignore status
323         (when (ztree-diff-model-should-ignore child)
324           (setf (ztree-diff-node-different child) 'ignore))
325         ;; if exists on a right side with the same type,
326         ;; remove from the list of files on the right side
327         (when file2
328           (setf list2 (cl-delete file2 list2 :test #'string-equal)))
329         (cond
330          ;; when exist just on a left side and is a directory, add all
331          ((and isdir (not file2))
332           (setf (ztree-diff-node-children child)
333                 (ztree-diff-model-subtree child
334                                           file1
335                                           'left
336                                           (ztree-diff-node-different child))))
337          ;; if 1) exists on both sides and 2) it is a file
338          ;; and 3) not ignored file
339          ((and file2 (not isdir) (not (eql (ztree-diff-node-different child) 'ignore)))
340           (setf (ztree-diff-node-different child)
341                 (ztree-diff-model-files-equal file1 file2)))
342          ;; if exists on both sides and it is a directory, traverse further
343          ((and file2 isdir)
344           (ztree-diff-node-recreate child)))
345         ;; push the created node to the children list
346         (push child children)))
347     ;; second - adding entries from the right directory which are not present
348     ;; in the left directory
349     (dolist (file2 list2)
350       ;; for every entry in the second directory
351       ;; we are creating the node
352       (let* ((isdir (file-directory-p file2))
353              ;; create the child to be added to the results list
354              (child
355               (ztree-diff-node-create node nil file2 children-status)))
356         ;; update ignore status of the child
357         (when (ztree-diff-model-should-ignore child)
358           (setf (ztree-diff-node-different child) 'ignore))
359           ;; if it is a directory, set the whole subtree to children
360         (when isdir
361           (setf (ztree-diff-node-children child)
362                 (ztree-diff-model-subtree child
363                                           file2
364                                           'right
365                                           (ztree-diff-node-different child))))
366         ;; push the created node to the result list
367         (push child children)))
368     ;; finally set different status based on all children
369     ;; depending if the node should participate in overall result
370     (unless should-ignore
371       (setf (ztree-diff-node-different node)
372             (cl-reduce #'ztree-diff-model-update-diff
373                        children
374                        :initial-value 'same
375                        :key 'ztree-diff-node-different)))
376     ;; and set children
377     (setf (ztree-diff-node-children node) children)))
378
379
380 (defun ztree-diff-model-update-node (node)
381   "Refresh the NODE."
382   (ztree-diff-node-recreate node))
383
384
385
386 (defun ztree-diff-model-set-ignore-fun (ignore-p)
387   "Set the buffer-local ignore function to IGNORE-P.
388 Ignore function is a function of one argument (ztree-diff-node)
389 which returns t if the node should be ignored (like files starting
390 with dot etc)."
391   (setf ztree-diff-model-ignore-fun ignore-p))
392
393
394 (defun ztree-diff-model-set-progress-fun (progress-fun)
395   "Setter for the buffer-local PROGRESS-FUN callback.
396 This callback is called to indicate the ongoing activity.
397 Callback is a function without arguments."
398   (setf ztree-diff-model-progress-fun progress-fun))
399
400 (provide 'ztree-diff-model)
401
402 ;;; ztree-diff-model.el ends here