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 ;;;###autoload
  87 (define-minor-mode ztreediff-mode
  88   "A minor mode for displaying the difference of the directory trees in text mode."
  89   ;; initial value
  90   nil
  91   ;; modeline name
  92   " Diff"
  93   ;; The minor mode keymap
  94   `(
  95     (,(kbd "C") . ztree-diff-copy)
  96     (,(kbd "h") . ztree-diff-toggle-show-equal-files)
  97     (,(kbd "D") . ztree-diff-delete-file)
  98     (,(kbd "v") . ztree-diff-view-file)
  99     (,(kbd "d") . ztree-diff-simple-diff-files)
 100     (,(kbd "r") . ztree-diff-partial-rescan)
 101     ([f5] . ztree-diff-full-rescan)))
 102
 103
 104 (defun ztree-diff-node-face (node)
 105   "Return the face for the NODE depending on diff status."
 106   (let ((diff (ztree-diff-node-different node)))
 107     (cond ((eq diff 'diff) ztreep-diff-model-diff-face)
 108           ((eq diff 'new)  ztreep-diff-model-add-face)
 109           (t ztreep-diff-model-normal-face))))
 110
 111 (defun ztree-diff-insert-buffer-header ()
 112   "Insert the header to the ztree buffer."
 113   (ztree-insert-with-face "Differences tree" ztreep-diff-header-face)
 114   (insert "\n")
 115   (when ztree-diff-dirs-pair
 116     (ztree-insert-with-face (concat "Left:  " (car ztree-diff-dirs-pair))
 117                             ztreep-diff-header-small-face)
 118     (insert "\n")
 119     (ztree-insert-with-face (concat "Right: " (cdr ztree-diff-dirs-pair))
 120                             ztreep-diff-header-small-face)
 121     (insert "\n"))
 122   (ztree-insert-with-face "Legend:" ztreep-diff-header-small-face)
 123   (insert "\n")
 124   (ztree-insert-with-face " Normal file " ztreep-diff-model-normal-face)
 125   (ztree-insert-with-face "- same on both sides" ztreep-diff-header-small-face)
 126   (insert "\n")
 127   (ztree-insert-with-face " Orphan file " ztreep-diff-model-add-face)
 128   (ztree-insert-with-face "- does not exist on other side" ztreep-diff-header-small-face)
 129   (insert "\n")
 130   (ztree-insert-with-face " Mismatch file " ztreep-diff-model-diff-face)
 131   (ztree-insert-with-face "- different from other side" ztreep-diff-header-small-face)
 132   (insert "\n")
 133   (ztree-insert-with-face "==============" ztreep-diff-header-face)
 134   (insert "\n"))
 135
 136 (defun ztree-diff-full-rescan ()
 137   "Force full rescan of the directory trees."
 138   (interactive)
 139   (when (and ztree-diff-dirs-pair
 140              (yes-or-no-p (format "Force full rescan?")))
 141     (ztree-diff (car ztree-diff-dirs-pair) (cdr ztree-diff-dirs-pair))))
 142
 143
 144
 145 (defun ztree-diff-existing-common (node)
 146   "Return the NODE if both left and right sides exist."
 147   (let ((left (ztree-diff-node-left-path node))
 148         (right (ztree-diff-node-right-path node)))
 149     (if (and left right
 150              (file-exists-p left)
 151              (file-exists-p right))
 152         node
 153       nil)))
 154
 155 (defun ztree-diff-existing-common-parent (node)
 156   "Return the first node in up in hierarchy of the NODE which has both sides."
 157   (let ((common (ztree-diff-existing-common node)))
 158     (if common
 159         common
 160       (ztree-diff-existing-common-parent (ztree-diff-node-parent node)))))
 161
 162 (defun ztree-diff-do-partial-rescan (node)
 163   "Partly rescan the NODE."
 164   (let* ((common (ztree-diff-existing-common-parent node))
 165          (parent (ztree-diff-node-parent common)))
 166     (if (not parent)
 167         (when ztree-diff-dirs-pair
 168           (ztree-diff (car ztree-diff-dirs-pair) (cdr ztree-diff-dirs-pair)))
 169       (progn
 170         (ztree-diff-model-partial-rescan common)
 171         (ztree-diff-node-update-all-parents-diff node)
 172         (ztree-refresh-buffer (line-number-at-pos))))))
 173
 174
 175 (defun ztree-diff-partial-rescan ()
 176   "Perform partial rescan on the current node."
 177   (interactive)
 178   (let ((found (ztree-find-node-at-point)))
 179     (when found
 180       (ztree-diff-do-partial-rescan (car found)))))
 181
 182
 183 (defun ztree-diff-simple-diff (node)
 184   "Create a simple diff buffer for files from left and right panels.
 185 Argument NODE node containing paths to files to call a diff on."
 186   (let* ((node-left (ztree-diff-node-left-path node))
 187          (node-right (ztree-diff-node-right-path node)))
 188     (when (and
 189            node-left
 190            node-right
 191            (not (file-directory-p node-left)))
 192       ;; show the diff window on the bottom
 193       ;; to not to crush tree appearance
 194       (let ((split-width-threshold nil))
 195         (diff node-left node-right)))))
 196
 197
 198 (defun ztree-diff-simple-diff-files ()
 199   "Create a simple diff buffer for files from left and right panels."
 200   (interactive)
 201   (let ((found (ztree-find-node-at-point)))
 202     (when found
 203       (let ((node (car found)))
 204         (ztree-diff-simple-diff node)))))
 205
 206 (defun ztree-diff-node-action (node hard)
 207   "Perform action on NODE:
 208 1 if both left and right sides present:
 209    1.1 if they are differend
 210       1.1.1 if HARD ediff
 211       1.1.2 simple diff otherwiste
 212    1.2 if they are the same - view left
 213 2 if left or right present - view left or rigth"
 214   (let ((left (ztree-diff-node-left-path node))
 215         (right (ztree-diff-node-right-path node))
 216         (open-f #'(lambda (path) (if hard (find-file path)
 217                                   (let ((split-width-threshold nil))
 218                                     (view-file-other-window path))))))
 219     (cond ((and left right)
 220            (if (not (ztree-diff-node-different node))
 221                (funcall open-f left)
 222              (if hard
 223                  (ediff left right)
 224                (ztree-diff-simple-diff node))))
 225           (left (funcall open-f left))
 226           (right (funcall open-f right))
 227           (t nil))))
 228
 229
 230
 231 (defun ztree-diff-copy-file (node source-path destination-path copy-to-right)
 232   "Update the NODE status and copy the file.
 233 File copied from SOURCE-PATH to DESTINATION-PATH.
 234 COPY-TO-RIGHT specifies which side of the NODE to update."
 235   (let ((target-path (concat
 236                       (file-name-as-directory destination-path)
 237                       (file-name-nondirectory
 238                        (directory-file-name source-path)))))
 239     (let ((err (condition-case error-trap
 240                    (progn
 241                      ;; don't ask for overwrite
 242                      ;; keep time stamp
 243                      (copy-file source-path target-path t t)
 244                      nil)
 245                  (error error-trap))))
 246       ;; error message if failed
 247       (if err (message (concat "Error: " (nth 2 err)))
 248         (progn              ; otherwise:
 249           ;; assuming all went ok when left and right nodes are the same
 250           ;; set both as not different
 251           (ztree-diff-node-set-different node nil)
 252           ;; update left/right paths
 253           (if copy-to-right
 254               (ztree-diff-node-set-right-path node target-path)
 255             (ztree-diff-node-set-left-path node target-path))
 256           (ztree-diff-node-update-all-parents-diff node)
 257           (ztree-refresh-buffer (line-number-at-pos)))))))
 258
 259
 260 (defun ztree-diff-copy-dir (node source-path destination-path copy-to-right)
 261   "Update the NODE status and copy the directory.
 262 Directory copied from SOURCE-PATH to DESTINATION-PATH.
 263 COPY-TO-RIGHT specifies which side of the NODE to update."
 264   (let* ((src-path (file-name-as-directory source-path))
 265          (target-path (file-name-as-directory destination-path))
 266          (target-full-path (concat
 267                             target-path
 268                             (file-name-nondirectory
 269                              (directory-file-name source-path)))))
 270     (let ((err (condition-case error-trap
 271                    (progn
 272                      ;; keep time stamp
 273                      ;; ask for overwrite
 274                      (copy-directory src-path target-path t t)
 275                      nil)
 276                  (error error-trap))))
 277       ;; error message if failed
 278       (if err (message (concat "Error: " (nth 1 err)))
 279         (progn
 280           (message target-full-path)
 281           (if copy-to-right
 282               (ztree-diff-node-set-right-path node
 283                                               target-full-path)
 284             (ztree-diff-node-set-left-path node
 285                                            target-full-path))
 286           (ztree-diff-model-update-node node)
 287           (ztree-diff-node-update-all-parents-diff node)
 288           (ztree-refresh-buffer (line-number-at-pos)))))))
 289
 290
 291 (defun ztree-diff-copy ()
 292   "Copy the file under the cursor to other side."
 293   (interactive)
 294   (let ((found (ztree-find-node-at-point)))
 295     (when found
 296       (let* ((node (car found))
 297              (side (cdr found))
 298              (node-side (ztree-diff-node-side node))
 299              (copy-to-right t)           ; copy from left to right
 300              (node-left (ztree-diff-node-left-path node))
 301              (node-right (ztree-diff-node-right-path node))
 302              (source-path nil)
 303              (destination-path nil)
 304              (parent (ztree-diff-node-parent node)))
 305         (when parent                ; do not copy the root node
 306           ;; determine a side to copy from/to
 307           ;; algorithm:
 308           ;; 1) if both side are present, use the side
 309           ;;    variable
 310           (setq copy-to-right (if (eq node-side 'both)
 311                                   (eq side 'left)
 312                                 ;; 2) if one of sides is absent, copy from
 313                                 ;;    the side where the file is present
 314                                 (eq node-side 'left)))
 315           ;; 3) in both cases determine if the destination
 316           ;;    directory is in place
 317           (setq source-path (if copy-to-right node-left node-right)
 318                 destination-path (if copy-to-right
 319                                      (ztree-diff-node-right-path parent)
 320                                    (ztree-diff-node-left-path parent)))
 321           (when (and source-path destination-path
 322                      (yes-or-no-p (format "Copy [%s]%s to [%s]%s/ ?"
 323                                           (if copy-to-right "LEFT" "RIGHT")
 324                                           (ztree-diff-node-short-name node)
 325                                           (if copy-to-right "RIGHT" "LEFT")
 326                                           destination-path)))
 327             (if (file-directory-p source-path)
 328                 (ztree-diff-copy-dir node
 329                                      source-path
 330                                      destination-path
 331                                      copy-to-right)
 332               (ztree-diff-copy-file node
 333                                     source-path
 334                                     destination-path
 335                                     copy-to-right))))))))
 336
 337 (defun ztree-diff-view-file ()
 338   "View file at point, depending on side."
 339   (interactive)
 340   (let ((found (ztree-find-node-at-point)))
 341     (when found
 342       (let* ((node (car found))
 343              (side (cdr found))
 344              (node-side (ztree-diff-node-side node))
 345              (node-left (ztree-diff-node-left-path node))
 346              (node-right (ztree-diff-node-right-path node)))
 347         (when (or (eq node-side 'both)
 348                   (eq side node-side))
 349           (cond ((and (eq side 'left)
 350                       node-left)
 351                  (view-file node-left))
 352                 ((and (eq side 'right)
 353                       node-right)
 354                  (view-file node-right))))))))
 355
 356
 357 (defun ztree-diff-delete-file ()
 358   "Delete the file under the cursor."
 359   (interactive)
 360   (let ((found (ztree-find-node-at-point)))
 361     (when found
 362       (let* ((node (car found))
 363              (side (cdr found))
 364              (node-side (ztree-diff-node-side node))
 365              (delete-from-left t)
 366              (remove-path nil)
 367              (parent (ztree-diff-node-parent node)))
 368         (when parent                    ; do not delete the root node
 369           ;; algorithm for determining what to delete similar to copy:
 370           ;; 1. if the file is present on both sides, delete
 371           ;;    from the side currently selected
 372           (setq delete-from-left (if (eq node-side 'both)
 373                                      (eq side 'left)
 374                                    ;; 2) if one of sides is absent, delete
 375                                    ;; from the side where the file is present
 376                                    (eq node-side 'left)))
 377           (setq remove-path (if delete-from-left
 378                                 (ztree-diff-node-left-path node)
 379                               (ztree-diff-node-right-path node)))
 380           (when (yes-or-no-p (format "Delete the file [%s]%s ?"
 381                                      (if delete-from-left "LEFT" "RIGHT")
 382                                      remove-path))
 383             (let* ((delete-command
 384                     (if (file-directory-p remove-path)
 385                         '(delete-directory remove-path t)
 386                       '(delete-file remove-path t)))
 387                    (children (ztree-diff-node-children parent))
 388                    (err
 389                     (condition-case error-trap
 390                         (progn
 391                           (eval delete-command)
 392                           nil)
 393                       (error error-trap))))
 394               (if err (message (concat "Error: " (nth 2 err)))
 395                 (progn
 396                   (setq children (ztree-filter
 397                                   #'(lambda (x) (not (ztree-diff-node-equal x node)))
 398                                   children))
 399                   (ztree-diff-node-set-children parent children))
 400                 (ztree-diff-node-update-all-parents-diff node)
 401                 (ztree-refresh-buffer (line-number-at-pos))))))))))
 402
 403
 404
 405 (defun ztree-node-is-in-filter-list (node)
 406   "Determine if the NODE is in filter list.
 407 If the node is in the filter list it shall not be visible"
 408   (ztree-find ztree-diff-filter-list #'(lambda (rx) (string-match rx node))))
 409
 410
 411 (defun ztree-node-is-visible (node)
 412   "Determine if the NODE should be visible."
 413   (and (ztree-diff-node-parent node)    ; parent is always visible
 414        (not (ztree-node-is-in-filter-list (ztree-diff-node-short-name node)))
 415        (or ztree-diff-show-equal-files
 416            (ztree-diff-node-different node))))
 417
 418 (defun ztree-diff-toggle-show-equal-files ()
 419   "Toggle visibility of the equal files."
 420   (interactive)
 421   (setq ztree-diff-show-equal-files (not ztree-diff-show-equal-files))
 422   (ztree-refresh-buffer))
 423
 424 ;;;###autoload
 425 (defun ztree-diff (dir1 dir2)
 426   "Create an interactive buffer with the directory tree of the path given.
 427 Argument DIR1 left directory.
 428 Argument DIR2 right directory."
 429   (interactive "DLeft directory \nDRight directory ")
 430   (let* ((difference (ztree-diff-model-create dir1 dir2))
 431          (buf-name (concat "*"
 432                            (ztree-diff-node-short-name difference)
 433                            " <--> "
 434                            (ztree-diff-node-right-short-name difference)
 435                            "*")))
 436     (ztree-view buf-name
 437                 difference
 438                 'ztree-node-is-visible
 439                 'ztree-diff-insert-buffer-header
 440                 'ztree-diff-node-short-name-wrapper
 441                 'ztree-diff-node-is-directory
 442                 'ztree-diff-node-equal
 443                 'ztree-diff-node-children
 444                 'ztree-diff-node-face
 445                 'ztree-diff-node-action
 446                 'ztree-diff-node-side)
 447     (ztreediff-mode)
 448     (setq ztree-diff-dirs-pair (cons dir1 dir2))
 449     (ztree-refresh-buffer)))
 450
 451
 452
 453
 454 (provide 'ztree-diff)
 455 ;;; ztree-diff.el ends here