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

   1 ;;; ztree-diff.el --- Text mode diff 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 ;;; Code:
  31 (require 'ztree-view)
  32 (require 'ztree-diff-model)
  33
  34 (defconst ztree-diff-hidden-files-regexp "^\\."
  35   "Hidden files regexp.
  36 By default all filest starting with dot '.', including . and ..")
  37
  38 (defface ztreep-diff-header-face
  39   '((((type tty pc) (class color)) :foreground "lightblue" :weight bold)
  40     (((background dark)) (:height 1.2 :foreground "lightblue" :weight bold))
  41     (t :height 1.2 :foreground "darkblue" :weight bold))
  42   "*Face used for the header in Ztree Diff buffer."
  43   :group 'Ztree-diff :group 'font-lock-highlighting-faces)
  44 (defvar ztreep-diff-header-face 'ztreep-diff-header-face)
  45
  46 (defface ztreep-diff-header-small-face
  47   '((((type tty pc) (class color)) :foreground "lightblue" :weight bold)
  48     (((background dark)) (:foreground "lightblue" :weight bold))
  49     (t :weight bold :foreground "darkblue"))
  50   "*Face used for the header in Ztree Diff buffer."
  51   :group 'Ztree-diff :group 'font-lock-highlighting-faces)
  52 (defvar ztreep-diff-header-small-face 'ztreep-diff-header-small-face)
  53
  54 (defface ztreep-diff-model-diff-face
  55   '((t                   (:foreground "red")))
  56   "*Face used for different files in Ztree-diff."
  57   :group 'Ztree-diff :group 'font-lock-highlighting-faces)
  58 (defvar ztreep-diff-model-diff-face 'ztreep-diff-model-diff-face)
  59
  60 (defface ztreep-diff-model-add-face
  61   '((t                   (:foreground "blue")))
  62   "*Face used for added files in Ztree-diff."
  63   :group 'Ztree-diff :group 'font-lock-highlighting-faces)
  64 (defvar ztreep-diff-model-add-face 'ztreep-diff-model-add-face)
  65
  66 (defface ztreep-diff-model-normal-face
  67   '((t                   (:foreground "#7f7f7f")))
  68   "*Face used for non-modified files in Ztree-diff."
  69   :group 'Ztree-diff :group 'font-lock-highlighting-faces)
  70 (defvar ztreep-diff-model-normal-face 'ztreep-diff-model-normal-face)
  71
  72
  73 (defvar ztree-diff-filter-list (list ztree-diff-hidden-files-regexp)
  74   "List of regexp file names to filter out.
  75 By default paths starting with dot (like .git) are ignored")
  76 (make-variable-buffer-local 'ztree-diff-filter-list)
  77
  78 (defvar ztree-diff-dirs-pair nil
  79   "Pair of the directories stored.  Used to perform the full rescan.")
  80 (make-variable-buffer-local 'ztree-diff-dirs-pair)
  81
  82 (defvar ztree-diff-show-equal-files t
  83   "Show or not equal files/directories on both sides.")
  84 (make-variable-buffer-local 'ztree-diff-show-equal-files)
  85
  86 (defvar ztree-diff-show-filtered-files nil
  87   "Show or not files from the filtered list.")
  88
  89 ;;;###autoload
  90 (define-minor-mode ztreediff-mode
  91   "A minor mode for displaying the difference of the directory trees in text mode."
  92   ;; initial value
  93   nil
  94   ;; modeline name
  95   " Diff"
  96   ;; The minor mode keymap
  97   `(
  98     (,(kbd "C") . ztree-diff-copy)
  99     (,(kbd "h") . ztree-diff-toggle-show-equal-files)
 100     (,(kbd "H") . ztree-diff-toggle-show-filtered-files)
 101     (,(kbd "D") . ztree-diff-delete-file)
 102     (,(kbd "v") . ztree-diff-view-file)
 103     (,(kbd "d") . ztree-diff-simple-diff-files)
 104     (,(kbd "r") . ztree-diff-partial-rescan)
 105     ([f5] . ztree-diff-full-rescan)))
 106
 107
 108 (defun ztree-diff-node-face (node)
 109   "Return the face for the NODE depending on diff status."
 110   (let ((diff (ztree-diff-node-different node)))
 111     (cond ((eq diff 'diff) ztreep-diff-model-diff-face)
 112           ((eq diff 'new)  ztreep-diff-model-add-face)
 113           (t ztreep-diff-model-normal-face))))
 114
 115 (defun ztree-diff-insert-buffer-header ()
 116   "Insert the header to the ztree buffer."
 117   (ztree-insert-with-face "Differences tree" ztreep-diff-header-face)
 118   (insert "\n")
 119   (when ztree-diff-dirs-pair
 120     (ztree-insert-with-face (concat "Left:  " (car ztree-diff-dirs-pair))
 121                             ztreep-diff-header-small-face)
 122     (insert "\n")
 123     (ztree-insert-with-face (concat "Right: " (cdr ztree-diff-dirs-pair))
 124                             ztreep-diff-header-small-face)
 125     (insert "\n"))
 126   (ztree-insert-with-face "Legend:" ztreep-diff-header-small-face)
 127   (insert "\n")
 128   (ztree-insert-with-face " Normal file " ztreep-diff-model-normal-face)
 129   (ztree-insert-with-face "- same on both sides" ztreep-diff-header-small-face)
 130   (insert "\n")
 131   (ztree-insert-with-face " Orphan file " ztreep-diff-model-add-face)
 132   (ztree-insert-with-face "- does not exist on other side" ztreep-diff-header-small-face)
 133   (insert "\n")
 134   (ztree-insert-with-face " Mismatch file " ztreep-diff-model-diff-face)
 135   (ztree-insert-with-face "- different from other side" ztreep-diff-header-small-face)
 136   (insert "\n")
 137   (ztree-insert-with-face "==============" ztreep-diff-header-face)
 138   (insert "\n"))
 139
 140 (defun ztree-diff-full-rescan ()
 141   "Force full rescan of the directory trees."
 142   (interactive)
 143   (when (and ztree-diff-dirs-pair
 144              (yes-or-no-p (format "Force full rescan?")))
 145     (ztree-diff (car ztree-diff-dirs-pair) (cdr ztree-diff-dirs-pair))))
 146
 147
 148
 149 (defun ztree-diff-existing-common (node)
 150   "Return the NODE if both left and right sides exist."
 151   (let ((left (ztree-diff-node-left-path node))
 152         (right (ztree-diff-node-right-path node)))
 153     (if (and left right
 154              (file-exists-p left)
 155              (file-exists-p right))
 156         node
 157       nil)))
 158
 159 (defun ztree-diff-existing-common-parent (node)
 160   "Return the first node in up in hierarchy of the NODE which has both sides."
 161   (let ((common (ztree-diff-existing-common node)))
 162     (if common
 163         common
 164       (ztree-diff-existing-common-parent (ztree-diff-node-parent node)))))
 165
 166 (defun ztree-diff-do-partial-rescan (node)
 167   "Partly rescan the NODE."
 168   (let* ((common (ztree-diff-existing-common-parent node))
 169          (parent (ztree-diff-node-parent common)))
 170     (if (not parent)
 171         (when ztree-diff-dirs-pair
 172           (ztree-diff (car ztree-diff-dirs-pair) (cdr ztree-diff-dirs-pair)))
 173       (progn
 174         (ztree-diff-model-partial-rescan common)
 175         (ztree-diff-node-update-all-parents-diff node)
 176         (ztree-refresh-buffer (line-number-at-pos))))))
 177
 178
 179 (defun ztree-diff-partial-rescan ()
 180   "Perform partial rescan on the current node."
 181   (interactive)
 182   (let ((found (ztree-find-node-at-point)))
 183     (when found
 184       (ztree-diff-do-partial-rescan (car found)))))
 185
 186
 187 (defun ztree-diff-simple-diff (node)
 188   "Create a simple diff buffer for files from left and right panels.
 189 Argument NODE node containing paths to files to call a diff on."
 190   (let* ((node-left (ztree-diff-node-left-path node))
 191          (node-right (ztree-diff-node-right-path node)))
 192     (when (and
 193            node-left
 194            node-right
 195            (not (file-directory-p node-left)))
 196       ;; show the diff window on the bottom
 197       ;; to not to crush tree appearance
 198       (let ((split-width-threshold nil))
 199         (diff node-left node-right)))))
 200
 201
 202 (defun ztree-diff-simple-diff-files ()
 203   "Create a simple diff buffer for files from left and right panels."
 204   (interactive)
 205   (let ((found (ztree-find-node-at-point)))
 206     (when found
 207       (let ((node (car found)))
 208         (ztree-diff-simple-diff node)))))
 209
 210 (defun ztree-diff-node-action (node hard)
 211   "Perform action on NODE:
 212 1 if both left and right sides present:
 213    1.1 if they are differend
 214       1.1.1 if HARD ediff
 215       1.1.2 simple diff otherwiste
 216    1.2 if they are the same - view left
 217 2 if left or right present - view left or rigth"
 218   (let ((left (ztree-diff-node-left-path node))
 219         (right (ztree-diff-node-right-path node))
 220         ;; FIXME: The GNU convention is to only use "path" for lists of
 221         ;; directories as in load-path.
 222         (open-f #'(lambda (path) (if hard (find-file path)
 223                               (let ((split-width-threshold nil))
 224                                 (view-file-other-window path))))))
 225     (cond ((and left right)
 226            (if (not (ztree-diff-node-different node))
 227                (funcall open-f left)
 228              (if hard
 229                  (ediff left right)
 230                (ztree-diff-simple-diff node))))
 231           (left (funcall open-f left))
 232           (right (funcall open-f right))
 233           (t nil))))
 234
 235
 236
 237 (defun ztree-diff-copy-file (node source-path destination-path copy-to-right)
 238   "Update the NODE status and copy the file.
 239 File copied from SOURCE-PATH to DESTINATION-PATH.
 240 COPY-TO-RIGHT specifies which side of the NODE to update."
 241   (let ((target-path (concat
 242                       (file-name-as-directory destination-path)
 243                       (file-name-nondirectory
 244                        (directory-file-name source-path)))))
 245     (let ((err (condition-case error-trap
 246                    (progn
 247                      ;; don't ask for overwrite
 248                      ;; keep time stamp
 249                      (copy-file source-path target-path t t)
 250                      nil)
 251                  (error error-trap))))
 252       ;; error message if failed
 253       (if err (message (concat "Error: " (nth 2 err)))
 254         (progn              ; otherwise:
 255           ;; assuming all went ok when left and right nodes are the same
 256           ;; set both as not different
 257           (setf (ztree-diff-node-different node) nil)
 258           ;; update left/right paths
 259           (if copy-to-right
 260               (setf (ztree-diff-node-right-path node) target-path)
 261             (setf (ztree-diff-node-left-path node) target-path))
 262           (ztree-diff-node-update-all-parents-diff node)
 263           (ztree-refresh-buffer (line-number-at-pos)))))))
 264
 265
 266 (defun ztree-diff-copy-dir (node source-path destination-path copy-to-right)
 267   "Update the NODE status and copy the directory.
 268 Directory copied from SOURCE-PATH to DESTINATION-PATH.
 269 COPY-TO-RIGHT specifies which side of the NODE to update."
 270   (let* ((src-path (file-name-as-directory source-path))
 271          (target-path (file-name-as-directory destination-path))
 272          (target-full-path (concat
 273                             target-path
 274                             (file-name-nondirectory
 275                              (directory-file-name source-path)))))
 276     (let ((err (condition-case error-trap
 277                    (progn
 278                      ;; keep time stamp
 279                      ;; ask for overwrite
 280                      (copy-directory src-path target-path t t)
 281                      nil)
 282                  (error error-trap))))
 283       ;; error message if failed
 284       (if err (message (concat "Error: " (nth 1 err)))
 285         (progn
 286           (message target-full-path)
 287           (if copy-to-right
 288               (setf (ztree-diff-node-right-path node)
 289                     target-full-path)
 290             (setf (ztree-diff-node-left-path node)
 291                   target-full-path))
 292           (ztree-diff-model-update-node node)
 293           (ztree-diff-node-update-all-parents-diff node)
 294           (ztree-refresh-buffer (line-number-at-pos)))))))
 295
 296
 297 (defun ztree-diff-copy ()
 298   "Copy the file under the cursor to other side."
 299   (interactive)
 300   (let ((found (ztree-find-node-at-point)))
 301     (when found
 302       (let* ((node (car found))
 303              (side (cdr found))
 304              (node-side (ztree-diff-node-side node))
 305              (copy-to-right t)           ; copy from left to right
 306              (node-left (ztree-diff-node-left-path node))
 307              (node-right (ztree-diff-node-right-path node))
 308              (source-path nil)
 309              (destination-path nil)
 310              (parent (ztree-diff-node-parent node)))
 311         (when parent                ; do not copy the root node
 312           ;; determine a side to copy from/to
 313           ;; algorithm:
 314           ;; 1) if both side are present, use the side
 315           ;;    variable
 316           (setq copy-to-right (if (eq node-side 'both)
 317                                   (eq side 'left)
 318                                 ;; 2) if one of sides is absent, copy from
 319                                 ;;    the side where the file is present
 320                                 (eq node-side 'left)))
 321           ;; 3) in both cases determine if the destination
 322           ;;    directory is in place
 323           (setq source-path (if copy-to-right node-left node-right)
 324                 destination-path (if copy-to-right
 325                                      (ztree-diff-node-right-path parent)
 326                                    (ztree-diff-node-left-path parent)))
 327           (when (and source-path destination-path
 328                      (yes-or-no-p (format "Copy [%s]%s to [%s]%s/ ?"
 329                                           (if copy-to-right "LEFT" "RIGHT")
 330                                           (ztree-diff-node-short-name node)
 331                                           (if copy-to-right "RIGHT" "LEFT")
 332                                           destination-path)))
 333             (if (file-directory-p source-path)
 334                 (ztree-diff-copy-dir node
 335                                      source-path
 336                                      destination-path
 337                                      copy-to-right)
 338               (ztree-diff-copy-file node
 339                                     source-path
 340                                     destination-path
 341                                     copy-to-right))))))))
 342
 343 (defun ztree-diff-view-file ()
 344   "View file at point, depending on side."
 345   (interactive)
 346   (let ((found (ztree-find-node-at-point)))
 347     (when found
 348       (let* ((node (car found))
 349              (side (cdr found))
 350              (node-side (ztree-diff-node-side node))
 351              (node-left (ztree-diff-node-left-path node))
 352              (node-right (ztree-diff-node-right-path node)))
 353         (when (or (eq node-side 'both)
 354                   (eq side node-side))
 355           (cond ((and (eq side 'left)
 356                       node-left)
 357                  (view-file node-left))
 358                 ((and (eq side 'right)
 359                       node-right)
 360                  (view-file node-right))))))))
 361
 362
 363 (defun ztree-diff-delete-file ()
 364   "Delete the file under the cursor."
 365   (interactive)
 366   (let ((found (ztree-find-node-at-point)))
 367     (when found
 368       (let* ((node (car found))
 369              (side (cdr found))
 370              (node-side (ztree-diff-node-side node))
 371              (delete-from-left t)
 372              (remove-path nil)
 373              (parent (ztree-diff-node-parent node)))
 374         (when parent                    ; do not delete the root node
 375           ;; algorithm for determining what to delete similar to copy:
 376           ;; 1. if the file is present on both sides, delete
 377           ;;    from the side currently selected
 378           (setq delete-from-left (if (eq node-side 'both)
 379                                      (eq side 'left)
 380                                    ;; 2) if one of sides is absent, delete
 381                                    ;; from the side where the file is present
 382                                    (eq node-side 'left)))
 383           (setq remove-path (if delete-from-left
 384                                 (ztree-diff-node-left-path node)
 385                               (ztree-diff-node-right-path node)))
 386           (when (yes-or-no-p (format "Delete the file [%s]%s ?"
 387                                      (if delete-from-left "LEFT" "RIGHT")
 388                                      remove-path))
 389             (let* ((delete-command
 390                     (if (file-directory-p remove-path)
 391                         #'delete-directory
 392                       #'delete-file))
 393                    (children (ztree-diff-node-children parent))
 394                    (err
 395                     (condition-case error-trap
 396                         (progn
 397                           (funcall delete-command remove-path t)
 398                           nil)
 399                       (error error-trap))))
 400               (if err
 401                   (progn
 402                     (message (concat "Error: " (nth 2 err)))
 403                     ;; when error happened while deleting the
 404                     ;; directory, rescan the node
 405                     ;; and update the parents with a new status
 406                     ;; of this node
 407                     (when (file-directory-p remove-path)
 408                       (ztree-diff-model-partial-rescan node)
 409                       (ztree-diff-node-update-all-parents-diff node)))
 410                 ;; if everything ok
 411                 (progn
 412                   ;; remove the node from children
 413                   (setq children (ztree-filter
 414                                   #'(lambda (x) (not (ztree-diff-node-equal x node)))
 415                                   children))
 416                   (setf (ztree-diff-node-children parent) children))
 417                 (ztree-diff-node-update-all-parents-diff node)
 418                 ;;(ztree-diff-model-partial-rescan node)
 419                 (ztree-refresh-buffer (line-number-at-pos))))))))))
 420
 421
 422
 423 (defun ztree-diff-node-ignore-p (node)
 424   "Determine if the NODE is in filter list.
 425 If the node is in the filter list it shall not be visible,
 426 unless it is a parent node."
 427   (let ((name (ztree-diff-node-short-name node)))
 428     ;; ignore then
 429     ;; not a root and is in filter list
 430     (and (ztree-diff-node-parent node)
 431          (ztree-find ztree-diff-filter-list #'(lambda (rx) (string-match rx name))))))
 432
 433
 434 (defun ztree-node-is-visible (node)
 435   "Determine if the NODE should be visible."
 436   ;; visible then
 437   ;; 1) either it is a parent
 438   (or (not (ztree-diff-node-parent node))    ; parent is always visible
 439       (and
 440        ;; 2.1) or it is not in ignore list and
 441        (or ztree-diff-show-filtered-files ; show filtered files regardless
 442            (not (ztree-diff-node-ignore-p node)))
 443        ;; 2.2) it has different status
 444        (or ztree-diff-show-equal-files  ; show equal files regardless
 445            (ztree-diff-node-different node)))))
 446
 447 (defun ztree-diff-toggle-show-equal-files ()
 448   "Toggle visibility of the equal files."
 449   (interactive)
 450   (setq ztree-diff-show-equal-files (not ztree-diff-show-equal-files))
 451   (ztree-refresh-buffer))
 452
 453 (defun ztree-diff-toggle-show-filtered-files ()
 454   "Toggle visibility of the filtered files."
 455   (interactive)
 456   (setq ztree-diff-show-filtered-files (not ztree-diff-show-filtered-files))
 457   (ztree-refresh-buffer))
 458
 459
 460 ;;;###autoload
 461 (defun ztree-diff (dir1 dir2)
 462   "Create an interactive buffer with the directory tree of the path given.
 463 Argument DIR1 left directory.
 464 Argument DIR2 right directory."
 465   (interactive "DLeft directory \nDRight directory ")
 466   (let* ((difference (ztree-diff-model-create dir1 dir2 #'ztree-diff-node-ignore-p))
 467          (buf-name (concat "*"
 468                            (ztree-diff-node-short-name difference)
 469                            " <--> "
 470                            (ztree-diff-node-right-short-name difference)
 471                            "*")))
 472     (ztree-view buf-name
 473                 difference
 474                 'ztree-node-is-visible
 475                 'ztree-diff-insert-buffer-header
 476                 'ztree-diff-node-short-name-wrapper
 477                 'ztree-diff-node-is-directory
 478                 'ztree-diff-node-equal
 479                 'ztree-diff-node-children
 480                 'ztree-diff-node-face
 481                 'ztree-diff-node-action
 482                 'ztree-diff-node-side)
 483     (ztreediff-mode)
 484     (setq ztree-diff-dirs-pair (cons dir1 dir2))
 485     (ztree-refresh-buffer)))
 486
 487
 488
 489
 490 (provide 'ztree-diff)
 491 ;;; ztree-diff.el ends here