;; short-name - is the file or directory name
;; children - list of nodes - files or directories if the node is a directory
;; different = {nil, 'same, 'new, 'diff, 'ignore} - means comparison status
-(ztree-defrecord ztree-diff-node (parent left-path right-path short-name right-short-name children different))
+(cl-defstruct (ztree-diff-node
+ (:constructor)
+ (:constructor ztree-diff-node-create
+ (parent left-path right-path
+ different
+ &aux
+ (short-name (ztree-file-short-name
+ (or left-path right-path)))
+ (right-short-name
+ (if (and left-path right-path)
+ (ztree-file-short-name right-path)
+ short-name)))))
+ parent left-path right-path short-name right-short-name children different)
(defun ztree-diff-model-ignore-p (node)
"Determine if the NODE should be excluded from comparison results."
(defun ztree-diff-untrampify-filename (file)
"Return FILE as the local file name."
+ ;; FIXME: We shouldn't use internal Tramp functions.
(require 'tramp)
+ (declare-function tramp-tramp-file-p "tramp" (name))
+ (declare-function tramp-file-name-localname "tramp" (vec))
+ (declare-function tramp-dissect-file-name "tramp" (name &optional nodefault))
(if (not (tramp-tramp-file-p file))
file
(tramp-file-name-localname (tramp-dissect-file-name file))))
(defun ztree-diff-model-files-equal (file1 file2)
"Compare files FILE1 and FILE2 using external diff.
Returns t if equal."
+ ;; FIXME: This "untrampification" only works if both file1 and file2 are on
+ ;; the same host.
+ ;; FIXME: We assume that default-directory is also on the same host as
+ ;; file(1|2).
(let* ((file1-untrampified (ztree-diff-untrampify-filename (ztree-diff-modef-quotify-string file1)))
(file2-untrampified (ztree-diff-untrampify-filename (ztree-diff-modef-quotify-string file2)))
(diff-command (concat diff-command " -q" " " file1-untrampified " " file2-untrampified))
(if (ztree-diff-node-is-directory node)
(ztree-diff-node-recreate node)
;; if a file, change a status
- (ztree-diff-node-set-different
- node
- (if (or (ztree-diff-model-ignore-p node) ; if should be ignored
- (eql (ztree-diff-node-different node) 'ignore) ; was ignored
- (eql (ztree-diff-node-different ; or parent was ignored
- (ztree-diff-node-parent node)) 'ignore))
- 'ignore
- (ztree-diff-model-files-equal (ztree-diff-node-left-path node)
- (ztree-diff-node-right-path node)))))
+ (setf (ztree-diff-node-different node)
+ (if (or (ztree-diff-model-ignore-p node) ; if should be ignored
+ (eql (ztree-diff-node-different node) 'ignore) ; was ignored
+ (eql (ztree-diff-node-different ; or parent was ignored
+ (ztree-diff-node-parent node))
+ 'ignore))
+ 'ignore
+ (ztree-diff-model-files-equal (ztree-diff-node-left-path node)
+ (ztree-diff-node-right-path node)))))
;; update all parents statuses
(ztree-diff-node-update-all-parents-diff node))
parent
(when (eq side 'left) file)
(when (eq side 'right) file)
- (ztree-file-short-name file)
- (ztree-file-short-name file)
- nil
diff))
(children (ztree-diff-model-subtree node file side diff)))
- (ztree-diff-node-set-children node children)
+ (setf (ztree-diff-node-children node) children)
(push node result))
(push (ztree-diff-node-create
parent
(when (eq side 'left) file)
(when (eq side 'right) file)
- (ztree-file-short-name file)
- (ztree-file-short-name file)
- nil
diff)
result)))
result))
(defun ztree-diff-node-update-diff-from-children (node)
"Set the diff status for the NODE based on its children."
(unless (eql (ztree-diff-node-different node) 'ignore)
- (let ((diff (cl-reduce 'ztree-diff-model-update-diff
+ (let ((diff (cl-reduce #'ztree-diff-model-update-diff
(ztree-diff-node-children node)
:initial-value 'same
:key 'ztree-diff-node-different)))
- (ztree-diff-node-set-different node diff))))
+ (setf (ztree-diff-node-different node) diff))))
(defun ztree-diff-node-update-all-parents-diff (node)
"Recursively update all parents diff status for the NODE."
(not
(or (eql status 'ignore)
(eql (ztree-diff-node-different child) 'ignore))))
- (ztree-diff-node-set-different child status)
+ (setf (ztree-diff-node-different child) status)
(ztree-diff-node-update-diff-from-parent child)))
children)))
(and parent
(or (eql (ztree-diff-node-different parent) 'ignore)
(ztree-diff-model-ignore-p node)))))
-
(defun ztree-diff-node-recreate (node)
;; update node status ignore status either inhereted from the
;; parent or the own
(when should-ignore
- (ztree-diff-node-set-different node 'ignore))
+ (setf (ztree-diff-node-different node) 'ignore))
;; first - adding all entries from left directory
(dolist (file1 list1)
;; for every entry in the first directory
;; create a child. The current node is a parent
;; new by default - will be overriden below if necessary
(child
- (ztree-diff-node-create node file1 file2 simple-name simple-name nil children-status)))
+ (ztree-diff-node-create node file1 file2 children-status)))
;; update child own ignore status
(when (ztree-diff-model-should-ignore child)
- (ztree-diff-node-set-different child 'ignore))
+ (setf (ztree-diff-node-different child) 'ignore))
;; if exists on a right side with the same type,
;; remove from the list of files on the right side
(when file2
- (setf list2 (cl-delete file2 list2 :test 'string-equal)))
+ (setf list2 (cl-delete file2 list2 :test #'string-equal)))
(cond
;; when exist just on a left side and is a directory, add all
((and isdir (not file2))
- (ztree-diff-node-set-children child
- (ztree-diff-model-subtree child
- file1
- 'left
- (ztree-diff-node-different child))))
+ (setf (ztree-diff-node-children child)
+ (ztree-diff-model-subtree child
+ file1
+ 'left
+ (ztree-diff-node-different child))))
;; if 1) exists on both sides and 2) it is a file
;; and 3) not ignored file
((and file2 (not isdir) (not (eql (ztree-diff-node-different child) 'ignore)))
- (ztree-diff-node-set-different child
- (ztree-diff-model-files-equal file1 file2)))
+ (setf (ztree-diff-node-different child)
+ (ztree-diff-model-files-equal file1 file2)))
;; if exists on both sides and it is a directory, traverse further
((and file2 isdir)
(ztree-diff-node-recreate child)))
(dolist (file2 list2)
;; for every entry in the second directory
;; we are creating the node
- (let* ((simple-name (ztree-file-short-name file2))
- (isdir (file-directory-p file2))
+ (let* ((isdir (file-directory-p file2))
;; create the child to be added to the results list
(child
- (ztree-diff-node-create node nil file2 simple-name simple-name nil children-status)))
+ (ztree-diff-node-create node nil file2 children-status)))
;; update ignore status of the child
(when (ztree-diff-model-should-ignore child)
- (ztree-diff-node-set-different child 'ignore))
+ (setf (ztree-diff-node-different child) 'ignore))
;; if it is a directory, set the whole subtree to children
(when isdir
- (ztree-diff-node-set-children child
- (ztree-diff-model-subtree child
- file2
- 'right
- (ztree-diff-node-different child))))
+ (setf (ztree-diff-node-children child)
+ (ztree-diff-model-subtree child
+ file2
+ 'right
+ (ztree-diff-node-different child))))
;; push the created node to the result list
(push child children)))
;; finally set different status based on all children
;; depending if the node should participate in overall result
(unless should-ignore
- (ztree-diff-node-set-different node
- (cl-reduce 'ztree-diff-model-update-diff
- children
- :initial-value 'same
- :key 'ztree-diff-node-different)))
+ (setf (ztree-diff-node-different node)
+ (cl-reduce #'ztree-diff-model-update-diff
+ children
+ :initial-value 'same
+ :key 'ztree-diff-node-different)))
;; and set children
- (ztree-diff-node-set-children node children)))
+ (setf (ztree-diff-node-children node) children)))
(defun ztree-diff-model-update-node (node)
2 if left or right present - view left or rigth"
(let ((left (ztree-diff-node-left-path node))
(right (ztree-diff-node-right-path node))
+ ;; FIXME: The GNU convention is to only use "path" for lists of
+ ;; directories as in load-path.
(open-f #'(lambda (path) (if hard (find-file path)
(let ((split-width-threshold nil))
(view-file-other-window path))))))
;; assuming all went ok when left and right nodes are the same
;; set both as not different if they were not ignored
(unless (eq (ztree-diff-node-different node) 'ignore)
- (ztree-diff-node-set-different node 'same))
+ (setf (ztree-diff-node-different node) 'same))
;; update left/right paths
(if copy-to-right
- (ztree-diff-node-set-right-path node target-path)
- (ztree-diff-node-set-left-path node target-path))
+ (setf (ztree-diff-node-right-path node) target-path)
+ (setf (ztree-diff-node-left-path node) target-path))
(ztree-diff-node-update-all-parents-diff node)
(ztree-refresh-buffer (line-number-at-pos))))))
;; if everything is ok, update statuses
(message target-full-path)
(if copy-to-right
- (ztree-diff-node-set-right-path node
- target-full-path)
- (ztree-diff-node-set-left-path node
- target-full-path))
+ (setf (ztree-diff-node-right-path node) target-full-path)
+ (setf (ztree-diff-node-left-path node) target-full-path))
(ztree-diff-update-wait-message
(concat "Updating " (ztree-diff-node-short-name node) " ..."))
;; TODO: do not rescan the node. Use some logic like in delete
delete-from-left)
(and (eql node-side 'right)
(not delete-from-left)))
- (ztree-diff-node-set-children parent
- (ztree-filter
- (lambda (x) (not (ztree-diff-node-equal x node)))
- children))
+ (setf (ztree-diff-node-children parent)
+ (ztree-filter
+ (lambda (x) (not (ztree-diff-node-equal x node)))
+ children))
;; otherwise update only one side
- (let ((update-fun
- (if delete-from-left
- #'ztree-diff-node-set-left-path
- #'ztree-diff-node-set-right-path)))
- (mapc (lambda (x) (funcall update-fun x nil))
- (cons node (ztree-diff-node-children node))))
+ (mapc (if delete-from-left
+ (lambda (x) (setf (ztree-diff-node-left-path x) nil))
+ (lambda (x) (setf (ztree-diff-node-right-path x) nil)))
+ (cons node (ztree-diff-node-children node)))
;; and update diff status
;; if was ignored keep the old status
(unless (eql (ztree-diff-node-different node) 'ignore)
- (ztree-diff-node-set-different node 'new))
+ (setf (ztree-diff-node-different node) 'new))
;; finally update all children statuses
(ztree-diff-node-update-diff-from-parent node)))
(ztree-diff-node-update-all-parents-diff node)
(unless (file-exists-p dir2)
(error "Path %s does not exist" dir2))
(let* ((model
- (ztree-diff-node-create nil dir1 dir2
- (ztree-file-short-name dir1)
- (ztree-file-short-name dir2)
- nil
- nil))
+ (ztree-diff-node-create nil dir1 dir2 nil))
(buf-name (concat "*"
(ztree-diff-node-short-name model)
" <--> "
-;;; ztree-util.el --- Auxulary utilities for the ztree package -*- lexical-binding: t; -*-
+;;; ztree-util.el --- Auxiliary utilities for the ztree package -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
;;
(insert text)
(put-text-property start (point) 'face face)))
-
-(defmacro ztree-defrecord (record-name record-fields)
- "Create a record (structure) and getters/setters.
-
-Record is the following set of functions:
- - Record constructor with name \"RECORD-NAME\"-create and list of
-arguments which will be assigned to RECORD-FIELDS
- - Record getters with names \"record-name\"-\"field\" accepting one
-argument - the record; \"field\" is from \"record-fields\" symbols
- - Record setters with names \"record-name\"-set-\"field\" accepting two
-arguments - the record and the field value
-
-Example:
-\(ztree-defrecord person (name age))
-
-will be expanded to the following functions:
-
-\(defun person-create (name age) (...)
-\(defun person-name (record) (...)
-\(defun person-age (record) (...)
-\(defun person-set-name (record value) (...)
-\(defun person-set-age (record value) (...)
-
-To test expansion one can use GNU Emacs's pp library:
-\(require 'pp)
-\(pp-macroexpand-expression
- '(ztree-defrecord person (name age)))"
- (let ((ctor-name (intern (concat (symbol-name record-name) "-create")))
- (rec-var (make-symbol "record")))
- `(progn
- ;; constructor with the name "record-name-create"
- ;; with arguments list "record-fields" expanded
- (defun ,ctor-name (,@record-fields)
- (let ((,rec-var))
- ,@(mapcar #'(lambda (x)
- (list 'setq rec-var (list 'plist-put rec-var (list 'quote x) x)))
- record-fields)))
- ;; getters with names "record-name-field" where the "field"
- ;; is from record-fields
- ,@(mapcar #'(lambda (x)
- (let ((getter-name (intern (concat (symbol-name record-name)
- "-"
- (symbol-name x)))))
- `(progn
- (defun ,getter-name (,rec-var)
- (plist-get ,rec-var ',x)
- ))))
- record-fields)
- ;; setters wit names "record-name-set-field where the "field"
- ;; is from record-fields
- ;; arguments for setters: (record value)
- ,@(mapcar #'(lambda (x)
- (let ((setter-name (intern (concat (symbol-name record-name)
- "-set-"
- (symbol-name x)))))
- `(progn
- (defun ,setter-name (,rec-var value)
- (setq ,rec-var (plist-put ,rec-var ',x value))
- ))))
- record-fields))))
-
-
(provide 'ztree-util)
;;; ztree-util.el ends here