source: cl-darcs/trunk/diff.lisp

Last change on this file was 150, checked in by Magnus Henoch, 14 years ago

Signal an error when adding a file or directory that already exists

File size: 7.7 KB
Line 
1;;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defun diff-file (original modified &key filename)
20  "Find changes between ORIGINAL and MODIFIED.
21Return a list of HUNK-PATCHes.  Use FILENAME as their filename."
22  (when original (setf original (make-upath original)))
23  (when modified (setf modified (make-upath modified)))
24  (let* ((original-lines
25          (if original
26              (with-open-stream (in (open-upath original :binary t))
27                (loop for line = (read-binary-line in nil)
28                   while line collect line))
29              :nonexistent))
30         (modified-lines
31          (if modified
32              (with-open-stream (in (open-upath modified :binary t))
33                (loop for line = (read-binary-line in nil)
34                   while line collect line))
35              :nonexistent))
36
37         ;; using equalp is safe (i.e. non-case-clobbering), as
38         ;; we use bytes instead of characters
39         (opcodes (when (and (listp original-lines)
40                             (listp modified-lines))
41                    (difflib:get-opcodes
42                     (make-instance 'difflib:sequence-matcher
43                                    :a original-lines
44                                    :b modified-lines
45                                    :test-function #'equalp))))
46
47         patches)
48    (cond
49      ((and (eql original-lines :nonexistent)
50            (eql modified-lines :nonexistent))
51       (error "Neither ~A nor ~A exist." original modified))
52      ((eql original-lines :nonexistent)
53       ;; Newly created file
54       (list
55        (make-instance 'hunk-patch
56                       :filename filename
57                       :line-number 1
58                       :old ()
59                       :new modified-lines)))
60      ((eql modified-lines :nonexistent)
61       ;; Removed file
62       (list
63        (make-instance 'hunk-patch
64                       :filename filename
65                       :line-number 1
66                       :old original-lines
67                       :new ())))
68      (t
69       ;; Possibly changed file
70       (dolist (opcode opcodes)
71         (unless (eql (difflib:opcode-tag opcode) :equal)
72           (push 
73            (make-instance 'hunk-patch
74                           :filename filename
75                           :line-number (1+ (difflib:opcode-j1 opcode))
76                           :old (subseq original-lines
77                                        (difflib:opcode-i1 opcode)
78                                        (difflib:opcode-i2 opcode))
79                           :new (subseq modified-lines
80                                        (difflib:opcode-j1 opcode)
81                                        (difflib:opcode-j2 opcode)))
82            patches)))
83
84       (nreverse patches)))))
85
86(defun diff-binary-file (original modified &key filename)
87  "Find changes between binary files ORIGINAL and MODIFIED.
88ORIGINAL and MODIFIED can be NIL, meaning an empty file.
89Use FILENAME as their filename.
90Return a list of one BINARY-PATCH, or an empty list if
91the files are equal."
92  (let ((o-contents
93         (when original
94           (with-open-file (o original
95                              :direction :input :if-does-not-exist :error
96                              :element-type '(unsigned-byte 8))
97             (let ((data
98                    (make-array (file-length o)
99                                :element-type '(unsigned-byte 8))))
100               (read-sequence data o)))))
101        (m-contents
102         (when modified
103           (with-open-file (m modified
104                              :direction :input :if-does-not-exist :error
105                              :element-type '(unsigned-byte 8))
106             (let ((data 
107                    (make-array (file-length m)
108                                :element-type '(unsigned-byte 8))))
109               (read-sequence data m)))))
110        (empty (make-array 0 :element-type '(unsigned-byte 8))))
111    (unless (equalp o-contents m-contents)
112      (list
113       (make-instance 'binary-patch
114                      :filename filename
115                      :oldhex (or o-contents empty)
116                      :newhex (or m-contents empty))))))
117
118(defun diff-repo (repo &optional original modified)
119  "Find changes in REPO from pristine tree.
120Return a list of patches.
121ORIGINAL and MODIFIED specify directories to start from."
122  (setf repo (truename (fad:pathname-as-directory repo)))
123  (unless (and original modified)
124    (setf modified repo)
125    (setf original (upath-subdir repo '("_darcs" "pristine"))))
126
127  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
128                              :name :wild
129                              :type :wild
130                              :version :wild))
131         (repo-wild (merge-pathnames wild repo))
132         (pristine (upath-subdir repo '("_darcs" "pristine")))
133         (pristine-wild (merge-pathnames wild pristine))
134         (original-wild (merge-pathnames wild original))
135         (modified-wild (merge-pathnames wild modified))
136         (pending (or 
137                   (read-pending repo)
138                   (make-instance 'composite-patch :patches ())))
139         patches)
140    ;; XXX: check if both directories exist
141
142    ;; With fad:list-directory, we get absolute pathnames.  We make
143    ;; them relative to the "root", so they can be compared.
144    (flet ((original-to-repo-relative (p)
145             (pathname (enough-namestring p pristine)))
146           (modified-to-repo-relative (p)
147             (pathname (enough-namestring p repo))))
148      ;; We list the files in the original tree.
149      (let* ((files-in-original 
150              (mapcar #'original-to-repo-relative
151                      (fad:list-directory original)))
152             pruned-pending)
153        ;; Create patch objects for newly added files and directories,
154        ;; and remember pending patches not creating new files or
155        ;; directories.
156        (dolist (p (patches pending))
157          (typecase p
158            (add-file-patch
159             (let ((pathname-string (pathname-to-string (patch-filename p)))
160                   (old-file (merge-pathnames (patch-filename p) pristine))
161                   (new-file (merge-pathnames (patch-filename p) repo)))
162               (when (fad:file-exists-p old-file)
163                 (error "Pending add of file ~A, but it already exists in the repository." pathname-string))
164               (setf patches 
165                     (nconc patches
166                            (list* p
167                                   (if (file-binary-p repo pathname-string)
168                                       (diff-binary-file nil new-file :filename pathname-string)
169                                       (diff-file nil new-file :filename pathname-string)))))))
170            (add-dir-patch
171             (let ((pathname-string (pathname-to-string (patch-directory p)))
172                   (old-dir (merge-pathnames (patch-directory p) pristine)))
173               (when (fad:directory-exists-p old-dir)
174                 (error "Pending add of directory ~A, but it already exists in the repository." pathname-string)))
175             (setf patches (nconc patches (list p))))
176            (t
177             (push p pruned-pending))))
178        (setf (patches pending) (nreverse pruned-pending))
179
180        ;; Then for each original file, find out its fate.
181        (dolist (file files-in-original)
182          ;; Was it touched by some "pending" patch?
183          (multiple-value-bind (touching new-name)
184              (find-touching pending file :forwards)
185            (if touching
186                ;; If yes, we want to record those patches, and remember the new name.
187                (setf patches (nconc patches (patches touching)))
188                ;; If not, it has the same name as before.
189                (setf new-name file))
190
191            (let ((original-pathname 
192                   (merge-pathnames file pristine))
193                  (modified-pathname
194                   (merge-pathnames new-name repo))
195                  (pathname-string
196                   (pathname-to-string new-name)))
197              (cond
198                ((fad:directory-pathname-p file)
199                 (setf patches (nconc patches
200                                      (diff-repo repo original-pathname modified-pathname))))
201
202                ((file-binary-p repo pathname-string)
203                 (setf patches (nconc patches
204                                      (diff-binary-file original-pathname
205                                                        modified-pathname
206                                                        :filename pathname-string))))
207
208                (t
209                 (setf patches (nconc patches 
210                                      (diff-file original-pathname
211                                                 modified-pathname
212                                                 :filename pathname-string))))))))
213
214        patches))))
215
216(defun diff-repo-display (repo)
217  "Find changes in REPO and print them to *STANDARD-OUTPUT*."
218  (dolist (patch (diff-repo repo))
219    (display-patch patch *standard-output*)))
220
Note: See TracBrowser for help on using the repository browser.