.emacs.d.git - Gitblit

Chizi123

2018-11-19 a4b9172aefa91861b587831e06f55b1e19f3f3be

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