source: cl-darcs/trunk/read-patch.lisp

Last change on this file was 20, checked in by Magnus Henoch, 16 years ago

Fix inverted confusion for read-merger

File size: 9.4 KB
Line 
1;;; Copyright (C) 2006 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 read-patch-from-file (filename &key (compressed t))
20  "Read a Darcs-style patch from FILENAME (a upath).
21The file is expected to be compressed unless COMPRESSED is NIL."
22  (restart-case
23      (if compressed
24          ;; It's hard to switch between binary and text mode
25          ;; (element-type (unsigned-byte 8) and character, respectively).
26          ;; So decompress the file to a temporary file, and read it from
27          ;; there.
28          (with-temp-file-name tmp-file
29            (uncompress-file filename tmp-file)
30            (with-open-stream (uncompressed 
31                               (make-instance 'unreadable-stream
32                                              :base-stream (open-upath (pathname tmp-file) :binary t)))
33              (read-patch uncompressed)))
34          ;; Reading an uncompressed file is easier, but they don't appear
35          ;; in the wild.
36          (with-open-stream (uncompressed (make-instance 'unreadable-stream
37                                                         :base-stream (open-upath filename :binary t)))
38            (read-patch uncompressed)))
39    (reread-patch ()
40        :report (lambda (stream)
41                  (format stream "Reread patch from ~A." filename))
42        (read-patch-from-file filename :compressed compressed))))
43         
44;; from PatchRead.lhs
45(defun read-patch (stream)
46  "Read a Darcs-style patch from STREAM."
47  ;; Read a whitespace-separated token...
48  (multiple-value-bind (token original) (read-token stream)
49    (dformat "~&Read ~S" token)
50    (cond
51      ((string= token "{")
52       ;; composite patch
53       (dformat "~&Reading composite patch")
54       (make-instance 
55        'composite-patch
56        :patches (loop for patch = (read-patch stream)
57                    while patch collect patch)))
58      ((string= token "}")
59       ;; end of composite patch
60       nil)
61
62      ((string= token "(")
63       ;; split patch
64       (make-instance 
65        'split-patch
66        :patches (loop for patch = (read-patch stream)
67                    while patch collect patch)))
68      ((string= token ")")
69       ;; end of split patch
70       nil)
71
72      ((string= token "hunk")
73       (read-hunk stream))
74
75      ((string= token "replace")
76       (read-token-replace stream))
77
78      ((string= token "binary")
79       (read-binary stream))
80
81      ((string= token "addfile")
82       (read-add-file stream))
83
84      ((string= token "adddir")
85       (read-add-dir stream))
86
87      ((string= token "rmfile")
88       (read-rm-file stream))
89
90      ((string= token "rmdir")
91       (read-rm-dir stream))
92
93      ((string= token "move")
94       (read-move stream))
95
96      ((string= token "changepref")
97       (read-change-pref stream))
98
99      ((string= token "merger")
100       (read-merger stream nil))
101
102      ((string= token "regrem")
103       (read-merger stream t))
104
105      ((string= token "conflict")
106       (read-conflict stream))
107
108      ((string= token "tcilfnoc")
109       (read-tcilfnoc stream))
110
111      ((char= (aref token 0) #\[)
112       ;; named patch.  there is no space after [, so unread the
113       ;; token.
114       (unread-sequence stream original)
115       (read-named stream))
116
117      (t
118       (error "Unknown patch token ~S." token)))))
119
120(defun read-hunk (stream)
121  "Read a hunk patch from STREAM."
122  ;; Read file name and line number...
123  (let ((filename (read-token stream))
124        (line-number (parse-integer (read-token stream)))
125        old new)
126    (dformat "~&Reading hunk for ~A" filename)
127    ;; Skip context (lines starting with space)
128    (loop for line = (read-binary-line stream)
129       while (= (elt line 0) 32)
130       finally (unread-line stream line))
131    ;; Collect 'old' lines (starting with '-')
132    (setf old
133          (loop for line = (read-binary-line stream nil)
134             while (and line (= (elt line 0) (char-code #\-)))
135             collect (subseq line 1)
136             do (dformat ".")
137             finally (when line (unread-line stream line))))
138    ;; Collect 'new' lines (starting with '+')
139    (setf new
140          (loop for line = (read-binary-line stream nil)
141             while (and line (= (elt line 0) (char-code #\+)))
142             collect (subseq line 1)
143             do (dformat ".")
144             finally (when line (unread-line stream line))))
145    (make-instance 
146     'hunk-patch :filename (sanitize-filename filename)
147     :line-number line-number
148     :old old :new new)))
149
150(defun read-named (stream)
151  "Read a named patch."
152  ;; A named patch starts with a patchinfo.
153  (let ((patchinfo (read-patchinfo stream))
154        dependencies)
155    (dformat "~&Reading named patch: ~A" patchinfo)
156    ;; If the next token is '<', it has a list of dependencies.
157    (multiple-value-bind (next-token maybe-unread-this) (read-token stream)
158      (if (string= next-token "<")
159          ;; The list of dependencies ends with '>'.
160          (loop for (next-token original) =
161               (multiple-value-list (read-token stream))
162               until (string= next-token ">")
163               do (unread-sequence stream original)
164               (push (read-patchinfo stream) dependencies)
165               finally (setf dependencies (nreverse dependencies)))
166          ;; It wasn't '<', so unread it.
167          (unread-sequence stream maybe-unread-this)))
168    (dformat "~&Got dependencies: ~A" dependencies)
169
170    ;; And then comes the patch itself.
171    (let ((patch (read-patch stream)))
172      (make-instance 
173       'named-patch :patchinfo patchinfo 
174       :dependencies dependencies
175       :patch patch))))
176
177(defun read-binary (stream)
178  "Read a binary patch."
179  ;; A binary patch consists of the token "oldhex", the old contents,
180  ;; "newhex", and the new contents.  Contents is in lines starting
181  ;; with '*', hex-encoded.
182  (flet ((read-binary-data ()
183           (let* ((bytes (make-array 1024 :element-type '(unsigned-byte 8)
184                                     :adjustable t :fill-pointer 0)))
185             (loop for line = (read-binary-line stream nil)
186                while (and line (= (elt line 0) (char-code #\*)))
187                do (loop for i from 1 below (length line) by 2
188                      do (vector-push-extend 
189                          (+ (* 16 (hex-to-number (elt line i)))
190                             (hex-to-number (elt line (1+ i))))
191                          bytes))
192                do (dformat ".")
193                finally (when line (unread-line stream line)))
194             bytes)))
195    (let ((filename (read-token stream)))
196      (dformat "~&Reading binary patch for ~A" filename)
197      (let ((oldhex (progn 
198
199                      (read-token stream)
200                      (read-binary-data)))
201            (newhex (progn (read-token stream) (read-binary-data))))
202        (make-instance 'binary-patch
203                       :filename (sanitize-filename filename)
204                       :oldhex oldhex
205                       :newhex newhex)))))
206   
207(defun read-add-file (stream)
208  "Read an 'add file' patch."
209  (make-instance 'add-file-patch
210                 :filename (sanitize-filename (read-token stream))))
211
212(defun read-rm-file (stream)
213  "Read a 'remove file' patch."
214  (make-instance 'rm-file-patch 
215                 :filename (sanitize-filename (read-token stream))))
216
217(defun read-add-dir (stream)
218  "Read an 'add directory' patch."
219  (make-instance 'add-dir-patch 
220                 :directory (sanitize-filename (read-token stream)
221                                               :type :directory)))
222
223(defun read-rm-dir (stream)
224  "Read a 'remove directory' patch."
225  (make-instance 'rm-dir-patch
226                 :directory (sanitize-filename (read-token stream)
227                                               :type :directory)))
228
229(defun read-change-pref (stream)
230  "Read a 'change preferences' patch."
231  ;; Read the name. (assume that read-token gobbles the newline)
232  (let ((name (read-token stream))
233        ;; Read old value.
234        (from (bytes-to-string (read-binary-line stream)))
235        ;; Read new value.
236        (to (bytes-to-string (read-binary-line stream))))
237    (make-instance 'change-pref-patch :pref name :from from :to to)))
238
239(defun read-move (stream)
240  "Read a 'move file' patch."
241  (let ((from (sanitize-filename (read-token stream)))
242        (to (sanitize-filename (read-token stream))))
243    (make-instance 'move-patch :from from :to to)))
244
245(defun read-merger (stream inverted)
246  "Read a merger patch."
247  ;; XXX: this needs much more work
248  (let ((version (read-token stream)))
249    (read-token stream)                 ; #\(
250    (let ((p1 (read-patch stream))
251          (p2 (read-patch stream)))
252      (read-token stream)               ; #\)
253      (let ((merger (make-instance 'merger-patch
254                                   :version version :first p1 :second p2
255                                   :inverted inverted)))
256        (let* ((is-merger1 (typep p1 'merger-patch))
257               (is-merger2 (typep p2 'merger-patch)))
258          (setf (merger-undo merger)
259                (cond
260                  ((and is-merger1 is-merger2)
261                   (make-instance 'composite-patch
262                                  :patches (mapcar #'invert-patch
263                                                   (cdr (unwind merger)))))
264                  ((and (not is-merger1) (not is-merger2))
265                   (invert-patch p1))
266                  ((and is-merger1 (not is-merger2))
267                   (make-instance 'composite-patch)) ;empty patch
268                  ((and (not is-merger1) is-merger2)
269                   (make-instance 'composite-patch
270                                  :patches (list (invert-patch p1)
271                                                 (merger-undo p2)))))))
272        merger))))
273
274(defun read-token-replace (stream)
275  "Read a token replacing patch."
276  (let ((filename (sanitize-filename (read-token stream)))
277        (token-regexp (read-token stream))
278        (old-token (read-token stream))
279        (new-token (read-token stream)))
280    (make-instance 'token-replace-patch
281                   :filename filename
282                   :regexp (subseq token-regexp 1 (1- (length token-regexp)))
283                   :old-token old-token
284                   :new-token new-token)))
Note: See TracBrowser for help on using the repository browser.