code.delx.au - gnu-emacs-elpa/blob - packages/ztree/ztree-diff-model.el

   1 ;;; ztree-diff-model.el --- diff model for directory trees -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013-2015  Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Alexey Veretennikov <alexey dot veretennikov at gmail dot com>
   6 ;;
   7 ;; Created: 2013-11-1l
   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-model-wait-message nil
  37   "Message showing while constructing the diff tree.")
  38 (make-variable-buffer-local 'ztree-diff-model-wait-message)
  39
  40 (defvar ztree-diff-model-ignore-fun nil
  41   "Function which determines if the node should be excluded from comparison.")
  42 (make-variable-buffer-local 'ztree-diff-model-ignore-fun)
  43
  44 (defun ztree-diff-model-update-wait-message ()
  45   "Update the wait mesage with one more '.' progress indication."
  46   (when ztree-diff-model-wait-message
  47     (setq ztree-diff-model-wait-message (concat ztree-diff-model-wait-message "."))
  48     (message ztree-diff-model-wait-message)))
  49
  50 ;; Create a record ztree-diff-node with defined fields and getters/setters
  51 ;; here:
  52 ;; parent - parent node
  53 ;; left-path is the full path on the left side of the diff window,
  54 ;; right-path is the full path of the right side,
  55 ;; short-name - is the file or directory name
  56 ;; children - list of nodes - files or directories if the node is a directory
  57 ;; different = {nil, 'new, 'diff} - means comparison status
  58 (cl-defstruct (ztree-diff-node
  59                (:constructor)
  60                (:constructor ztree-diff-node-create
  61                 (parent left-path right-path
  62                         different
  63                         &aux (short-name (ztree-file-short-name
  64                                           (or left-path right-path)))
  65                         (right-short-name (ztree-file-short-name
  66                                            (or right-path left-path))))))
  67   parent left-path right-path short-name right-short-name children different)
  68
  69 (defun ztree-diff-model-ignore-p (node)
  70   "Determine if the NODE should be excluded from comparison results."
  71   (when ztree-diff-model-ignore-fun
  72     (funcall ztree-diff-model-ignore-fun node)))
  73
  74 (defun ztree-diff-node-to-string (node)
  75   "Construct the string with contents of the NODE given."
  76   (let* ((string-or-nil #'(lambda (x) (if x
  77                                           (cond ((stringp x) x)
  78                                                 ((eq x 'new) "new")
  79                                                 ((eq x 'diff) "different")
  80                                                 (t (ztree-diff-node-short-name x)))
  81                                         "(empty)")))
  82          (children (ztree-diff-node-children node))
  83          (ch-str ""))
  84     (dolist (x children)
  85       (setq ch-str (concat ch-str "\n   * " (ztree-diff-node-short-name x))))
  86     (concat "Node: " (ztree-diff-node-short-name node)
  87             "\n"
  88             ;; " * Parent: " (let ((parent (ztree-diff-node-parent node)))
  89             ;;                 (if parent (ztree-diff-node-short-name parent) "nil"))
  90             " * Parent: " (funcall string-or-nil (ztree-diff-node-parent node))
  91             "\n"
  92             " * Left path: " (funcall string-or-nil (ztree-diff-node-left-path node))
  93             "\n"
  94             " * Right path: " (funcall string-or-nil (ztree-diff-node-right-path node))
  95             "\n"
  96             " * Children: " ch-str
  97             "\n")))
  98
  99
 100 (defun ztree-diff-node-short-name-wrapper (node &optional right-side)
 101   "Return the short name of the NODE given.
 102 If the RIGHT-SIDE is true, take the right leaf"
 103   (if (not right-side)
 104       (ztree-diff-node-short-name node)
 105     (ztree-diff-node-right-short-name node)))
 106
 107
 108 (defun ztree-diff-node-is-directory (node)
 109   "Determines if the NODE is a directory."
 110   (let ((left (ztree-diff-node-left-path node))
 111         (right (ztree-diff-node-right-path node)))
 112     (if left
 113         (file-directory-p left)
 114       (file-directory-p right))))
 115
 116 (defun ztree-diff-node-side (node)
 117   "Determine the side there the file is present for NODE.
 118 Return BOTH if the file present on both sides;
 119 LEFT if only on the left side and
 120 RIGHT if only on the right side."
 121   (let ((left (ztree-diff-node-left-path node))
 122         (right (ztree-diff-node-right-path node)))
 123     (if (and left right) 'both
 124       (if left 'left 'right))))
 125
 126 (defun ztree-diff-node-equal (node1 node2)
 127   "Determines if NODE1 and NODE2 are equal."
 128   (and (string-equal (ztree-diff-node-short-name node1)
 129                      (ztree-diff-node-short-name node2))
 130        (string-equal (ztree-diff-node-left-path node1)
 131                      (ztree-diff-node-left-path node2))
 132        (string-equal (ztree-diff-node-right-path node1)
 133                      (ztree-diff-node-right-path node1))))
 134
 135 (defun ztree-diff-untrampify-filename (file)
 136   "Return FILE as the local file name."
 137   ;; FIXME: We shouldn't use internal Tramp functions.
 138   (require 'tramp)
 139   (declare-function tramp-tramp-file-p "tramp" (name))
 140   (declare-function tramp-file-name-localname "tramp" (vec))
 141   (declare-function tramp-dissect-file-name "tramp" (name &optional nodefault))
 142   (if (not (tramp-tramp-file-p file))
 143       file
 144     (tramp-file-name-localname (tramp-dissect-file-name file))))
 145
 146 (defun ztree-diff-modef-quotify-string (x)
 147   "Surround string X with quotes."
 148   (concat "\"" x "\""))
 149
 150 (defun ztree-diff-model-files-equal (file1 file2)
 151   "Compare files FILE1 and FILE2 using external diff.
 152 Returns t if equal."
 153   ;; FIXME: This "untrampification" only works if both file1 and file2 are on
 154   ;; the same host.
 155   ;; FIXME: We assume that default-directory is also on the same host as
 156   ;; file(1|2).
 157   (let* ((file1-untrampified (ztree-diff-untrampify-filename (ztree-diff-modef-quotify-string file1)))
 158          (file2-untrampified (ztree-diff-untrampify-filename (ztree-diff-modef-quotify-string file2)))
 159          (diff-command (concat "diff -q" " " file1-untrampified " " file2-untrampified))
 160          (diff-output (shell-command-to-string diff-command)))
 161     (not (> (length diff-output) 2))))
 162
 163 (defun ztree-directory-files (dir)
 164   "Return the list of full paths of files in a directory DIR.
 165 Filters out . and .."
 166   (ztree-filter #'(lambda (file) (let ((simple-name (ztree-file-short-name file)))
 167                                    (not (or (string-equal simple-name ".")
 168                                             (string-equal simple-name "..")))))
 169                 (directory-files dir 'full)))
 170
 171 (defun ztree-diff-model-partial-rescan (node)
 172   "Rescan the NODE."
 173   ;; assuming what parent is always exists
 174   ;; otherwise the UI shall force the full rescan
 175   (let ((isdir (ztree-diff-node-is-directory node))
 176         (left (ztree-diff-node-left-path node))
 177         (right (ztree-diff-node-right-path node)))
 178     ;; if node is a directory - traverse
 179     (when (and left right
 180                (file-exists-p left)
 181                (file-exists-p right))
 182       (if isdir
 183         (let ((traverse (ztree-diff-node-traverse
 184                          node
 185                          left
 186                          right)))
 187           (setf (ztree-diff-node-different node) (car traverse))
 188           (setf (ztree-diff-node-children node) (cdr traverse)))
 189         ;; node is a file
 190         (setf (ztree-diff-node-different node)
 191               (if (ztree-diff-model-files-equal left right)
 192                   nil
 193                 'diff))))))
 194
 195 (defun ztree-diff-model-subtree (parent path side)
 196   "Create a subtree with given PARENT for the given PATH.
 197 Argument SIDE either 'left or 'right side."
 198   (let ((files (ztree-directory-files path))
 199         (result nil))
 200     (dolist (file files)
 201       (if (file-directory-p file)
 202           (let* ((node (ztree-diff-node-create
 203                         parent
 204                         (when (eq side 'left) file)
 205                         (when (eq side 'right) file)
 206                         'new))
 207                  (children (ztree-diff-model-subtree node file side)))
 208             (setf (ztree-diff-node-children node) children)
 209             (push node result))
 210         (push (ztree-diff-node-create
 211                parent
 212                (when (eq side 'left) file)
 213                (when (eq side 'right) file)
 214                'new)
 215               result)))
 216     result))
 217
 218 (defun ztree-diff-node-update-diff-from-children (node)
 219   "Set the diff status for the NODE based on its children."
 220   (let ((children (ztree-diff-node-children node))
 221         (diff nil))
 222     (dolist (child children)
 223       (unless (ztree-diff-model-ignore-p child)
 224         (setq diff
 225               (ztree-diff-model-update-diff
 226                diff
 227                (ztree-diff-node-different child)))))
 228     (setf (ztree-diff-node-different node) diff)))
 229
 230 (defun ztree-diff-node-update-all-parents-diff (node)
 231   "Recursively update all parents diff status for the NODE."
 232   (let ((parent node))
 233     (while (setq parent (ztree-diff-node-parent parent))
 234       (ztree-diff-node-update-diff-from-children parent))))
 235
 236
 237 (defun ztree-diff-model-update-diff (old new)
 238   "Get the diff status depending if OLD or NEW is not nil."
 239   (if new
 240       (if (or (not old)
 241               (eq old 'new))
 242           new
 243         old)
 244     old))
 245
 246 (defun ztree-diff-node-traverse (parent path1 path2)
 247   "Traverse 2 paths creating the list nodes with PARENT defined and diff status.
 248 Function traversing 2 paths PATH1 and PATH2 returning the list where the
 249 first element is the difference status (nil, 'diff, 'new') and
 250 the rest is the combined list of nodes."
 251   (let ((list1 (ztree-directory-files path1))
 252         (list2 (ztree-directory-files path2))
 253         (different-dir nil)
 254         (result nil))
 255     (ztree-diff-model-update-wait-message)
 256     ;; first - adding all entries from left directory
 257     (dolist (file1 list1)
 258       ;; for every entry in the first directory
 259       ;; we are creating the node
 260       (let* ((simple-name (ztree-file-short-name file1))
 261              (isdir (file-directory-p file1))
 262              (children nil)
 263              (different nil)
 264              ;; create the current node to be set as parent to
 265              ;; subdirectories
 266              (node (ztree-diff-node-create parent file1 nil nil))
 267              ;; 1. find if the file is in the second directory and the type
 268              ;;    is the same - i.e. both are directories or both are files
 269              (file2 (ztree-find list2
 270                                 #'(lambda (x) (and (string-equal (ztree-file-short-name x)
 271                                                                  simple-name)
 272                                                    (eq isdir (file-directory-p x)))))))
 273         ;; 2. if it is not in the second directory, add it as a node
 274         (if (not file2)
 275             (progn
 276               ;; 2.1 if it is a directory, add the whole subtree
 277               (when (file-directory-p file1)
 278                 (setq children (ztree-diff-model-subtree node file1 'left)))
 279               ;; 2.2 update the difference status for this entry
 280               (setq different 'new))
 281           ;; 3. if it is found in second directory and of the same type
 282           ;; 3.1 if it is a file
 283           (if (not (file-directory-p file1))
 284               ;; 3.1.1 set difference status to this entry
 285               (setq different (if (ztree-diff-model-files-equal file1 file2) nil 'diff))
 286             ;; 3.2 if it is the directory
 287             ;; 3.2.1 get the result of the directories comparison together with status
 288             (let ((traverse (ztree-diff-node-traverse node file1 file2)))
 289               ;; 3.2.2 update the difference status for whole comparison from
 290               ;;       difference result from the 2 subdirectories comparison
 291               (setq different (car traverse))
 292               ;; 3.2.3 set the children list from the 2 subdirectories comparison
 293               (setq children (cdr traverse)))))
 294         ;; update calculated parameters of the node
 295         (setf (ztree-diff-node-right-path node) file2)
 296         (setf (ztree-diff-node-children node) children)
 297         (setf (ztree-diff-node-different node) different)
 298         ;; 2.3 update difference status for the whole comparison
 299         ;; depending if the node should participate in overall result
 300         (unless (ztree-diff-model-ignore-p node)
 301           (setq different-dir (ztree-diff-model-update-diff different-dir different)))
 302         ;; push the created node to the result list
 303         (push node result)))
 304     ;; second - adding entries from the right directory which are not present
 305     ;; in the left directory
 306     (dolist (file2 list2)
 307       ;; for every entry in the second directory
 308       ;; we are creating the node
 309       (let* ((simple-name (ztree-file-short-name file2))
 310              (isdir (file-directory-p file2))
 311              (children nil)
 312              ;; create the node to be added to the results list
 313              (node (ztree-diff-node-create parent nil file2 'new))
 314              ;; 1. find if the file is in the first directory and the type
 315              ;;    is the same - i.e. both are directories or both are files
 316              (file1 (ztree-find list1
 317                                 #'(lambda (x) (and (string-equal (ztree-file-short-name x)
 318                                                                  simple-name)
 319                                                    (eq isdir (file-directory-p x)))))))
 320         ;; if it is not in the first directory, add it as a node
 321         (unless file1
 322           ;; if it is a directory, set the whole subtree to children
 323           (when (file-directory-p file2)
 324             (setq children (ztree-diff-model-subtree node file2 'right)))
 325           ;; set calculated children to the node
 326           (setf (ztree-diff-node-children node) children)
 327           ;; update the different status for the whole comparison
 328           ;; depending if the node should participate in overall result
 329           (unless (ztree-diff-model-ignore-p node)
 330             (setq different-dir (ztree-diff-model-update-diff different-dir 'new)))
 331           ;; push the created node to the result list
 332           (push node result))))
 333     ;; result is a pair: difference status and nodes list
 334     (cons different-dir result)))
 335
 336 (defun ztree-diff-model-create (dir1 dir2 &optional ignore-p)
 337   "Create a node based on DIR1 and DIR2.
 338 IGNORE-P is the optional filtering function, taking node as
 339 an argument, which determines if the node should be excluded
 340 from comparison."
 341   (unless (file-directory-p dir1)
 342     (error "Path %s is not a directory" dir1))
 343   (unless (file-directory-p dir2)
 344     (error "Path %s is not a directory" dir2))
 345   (setf ztree-diff-model-ignore-fun ignore-p)
 346   (setq ztree-diff-model-wait-message (concat "Comparing " dir1 " and " dir2 " ..."))
 347   (let* ((model
 348           (ztree-diff-node-create nil dir1 dir2 nil))
 349          (traverse (ztree-diff-node-traverse model dir1 dir2)))
 350     (setf (ztree-diff-node-children model) (cdr traverse))
 351     (setf (ztree-diff-node-different model) (car traverse))
 352     (message "Done.")
 353     model))
 354
 355 (defun ztree-diff-model-update-node (node)
 356   "Refresh the NODE."
 357   (setq ztree-diff-model-wait-message
 358         (concat "Updating " (ztree-diff-node-short-name node) " ..."))
 359   (let ((traverse (ztree-diff-node-traverse node
 360                                             (ztree-diff-node-left-path node)
 361                                             (ztree-diff-node-right-path node))))
 362     (setf (ztree-diff-node-children node) (cdr traverse))
 363     (setf (ztree-diff-node-different node) (car traverse))
 364     (message "Done.")))
 365
 366
 367
 368 (provide 'ztree-diff-model)
 369
 370 ;;; ztree-diff-model.el ends here