source: cl-darcs/tags/0.1.0/apply-patch.lisp

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

Make binary patch non-match a continuable error

File size: 12.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(defmacro with-file-patching ((instreamvar outstreamvar filename) &body body)
20  "Open FILENAME for patching.
21Bind INSTREAMVAR to a stream that reads from FILENAME.
22Bind OUTSTREAMVAR to a stream that writes to a temporary file.
23If BODY finishes normally, overwrite FILENAME with the temporary file."
24  (let ((files-copied-gensym (gensym))
25        (filename-gensym (gensym)))
26    `(let ((,files-copied-gensym nil)
27           (,filename-gensym ,filename))
28       (restart-case
29           ;; Open the file to patch for reading.
30           (with-open-stream (,instreamvar
31                              (make-instance 'unreadable-stream
32                                             :base-stream
33                                             (open ,filename-gensym
34                                                   :direction :input
35                                                   :if-does-not-exist :error
36                                                   :element-type '(unsigned-byte 8))
37                                             :haskellish-lines t))
38             ;; Open a temporary file for writing.
39             (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8))
40               (progn ,@body)
41
42               (close ,instreamvar)
43               (close ,outstreamvar)
44
45               (setf ,files-copied-gensym t)
46               ;; Copy the temporary file over the original.
47               (fad:copy-file (pathname ,outstreamvar) ,filename :overwrite t)))
48
49         ;; Until the temporary file is copied over the original, we can
50         ;; retry as many times we want.
51         ;; XXX: how can we enter a new version of the function?
52         ;; (retry-patch ()
53;;         :test (lambda (c) (declare (ignore c)) (not ,files-copied-gensym))
54;;         :report (lambda (stream)
55;;                   (format stream "Revert changes to ~A and retry patch" ,filename-gensym))
56;;         ,retry-form)
57         
58         (ignore-patch ()
59           :report (lambda (stream)
60                     (format stream "Ignore patch to ~A" ,filename-gensym))
61           nil)))))
62
63(defgeneric apply-patch (patch repodir)
64  (:documentation "Apply PATCH to working copy in REPODIR."))
65
66(defmethod apply-patch :around (patch repodir)
67  "Offer a RETRY restart for all patches.
68In some cases, the patch might be applied twice."
69  (restart-case
70      (call-next-method)
71    (retry ()
72      :report (lambda (stream)
73                (format stream "Retry patch ~A (possibly non-idempotent)" patch))
74      (apply-patch patch repodir))
75    (ignore ()
76      :report (lambda (stream)
77                (format stream "Ignore patch ~A" patch))
78      nil)))
79
80(defmethod apply-patch ((patch named-patch) repodir)
81  "Apply PATCH in REPODIR.
82That is, simply apply the patch contained in the named patch."
83  (dformat "~&Applying ~A: \"~A\"."
84           (patchinfo-date (named-patch-patchinfo patch))
85           (patchinfo-name (named-patch-patchinfo patch)))
86  (apply-patch (named-patch-patch patch) repodir))
87
88(defmethod apply-patch ((patch composite-patch) repodir)
89  (apply-patch-list (patches patch) repodir))
90
91(defmethod apply-patch ((patch change-pref-patch) repodir)
92  (with-accessors ((pref change-pref-which)
93                   (from change-pref-from)
94                   (to change-pref-to)) patch
95    (let ((old-value (or (get-pref repodir pref) "")))
96      (unless (string= from old-value)
97        (warn
98         "While changing pref ~S to ~S, expected old value to be ~S, but it was ~S."
99         pref to from old-value))
100      (set-pref repodir pref to))))
101
102(defmethod apply-patch ((patch add-file-patch) repodir)
103  "Create a file in REPODIR, by PATCH."
104  (let ((new-file (merge-pathnames
105                   (patch-filename patch) repodir)))
106    (dformat "~&Creating file ~A." new-file)
107    (open new-file :direction :probe
108          :if-does-not-exist :create
109          :if-exists :error)))
110
111(defmethod apply-patch ((patch binary-patch) repodir)
112  "Apply a binary patch in REPODIR."
113  (let ((file (merge-pathnames (patch-filename patch) repodir)))
114    ;; Check that the file matches the old content.
115    (with-open-file (in file
116                        :direction :input :if-does-not-exist :error
117                        :element-type '(unsigned-byte 8))
118      (when (or (/= (file-length in) (length (binary-oldhex patch)))
119                (let ((bytes (make-array (file-length in)
120                                         :element-type '(unsigned-byte 8))))
121                  (read-sequence bytes in)
122                  (not (equalp bytes (binary-oldhex patch)))))
123        (cerror "Write new contents to ~A anyway."
124                "Contents of ~A don't match patch." file)))
125    ;; Overwrite with new content.
126    (with-open-file (out file
127                         :direction :output :if-exists :supersede
128                         :element-type '(unsigned-byte 8))
129      (write-sequence (binary-newhex patch) out))))
130
131(defmethod apply-patch ((patch rm-file-patch) repodir)
132  "Delete a file in REPODIR.  File should be empty.
133If it's not, a warning will be signalled."
134  (let ((the-file (merge-pathnames
135                   (patch-filename patch) repodir)))
136    (with-open-file (in the-file :direction :input
137                        :if-does-not-exist :error)
138      (let ((length (file-length in)))
139      (unless (zerop length)
140        (warn "File ~A is not empty (contains ~A bytes)." the-file length))))
141    (dformat "~&Deleting file ~A." the-file)
142    (delete-file the-file)))
143
144(defmethod apply-patch ((patch add-dir-patch) repodir)
145  "Create a directory in REPODIR."
146  (let ((new-dir (merge-pathnames (patch-directory patch) repodir)))
147    (dformat "~&Creating directory ~A." new-dir)
148    (make-dir new-dir)))
149
150(defmethod apply-patch ((patch rm-dir-patch) repodir)
151  "Delete a directory in REPODIR.  Directory must be empty."
152  (let ((dir-to-remove (merge-pathnames (patch-directory patch) repodir)))
153    (dformat "~&Deleting directory ~A." dir-to-remove)
154    (delete-dir dir-to-remove)))
155
156(defmethod apply-patch ((patch move-patch) repodir)
157  "Move a file in REPODIR."
158  (let ((from (merge-pathnames (patch-move-from patch) repodir))
159        (to (merge-pathnames (patch-move-to patch) repodir)))
160;;     (fad:copy-file from to :overwrite nil)
161;;     (delete-file from)
162
163    ;; This seems to be an easier method, which works even if we're
164    ;; moving a directory.
165    #+sbcl (sb-ext:run-program "mv" (list (namestring from) (namestring to))
166                               :search t)
167    #+clisp (let ((result (ext:run-program "mv" :arguments (list (namestring from) (namestring to)))))
168              (unless (eql result 0)
169                (error "Couldn't move ~A to ~A." from to)))))
170
171(defmethod apply-patch ((patch token-replace-patch) repodir)
172  "Apply a token replace patch to a file in REPODIR."
173  (let ((filename (merge-pathnames (patch-filename patch) repodir))
174        (old-regexp (cl-ppcre:create-scanner
175                     (format nil "(^|[^~A])~A($|[^~A])"
176                             (token-regexp patch)
177                             (old-token patch)
178                             (token-regexp patch))))
179        (new-regexp (cl-ppcre:create-scanner
180                     (format nil "(^|[^~A])~A($|[^~A])"
181                             (token-regexp patch)
182                             (new-token patch)
183                             (token-regexp patch))))
184        (replacement (format nil "\\1~A\\2" (new-token patch))))
185    (dformat "~&Patching ~A with ~A." filename patch)
186    (with-file-patching (in out filename) (apply-patch patch repodir)
187      (let ((file-empty t))
188        (flet ((maybe-terpri ()
189                 ;; Unless we're writing the first line, we have to
190                 ;; terminate the previous one.
191                 (if file-empty
192                     (setf file-empty nil)
193                     (terpri out))))
194          (loop
195               (multiple-value-bind (line delim) (read-until #\Newline in nil :eof)
196                 (setf line (coerce line 'string))
197                 (when (cl-ppcre:scan new-regexp line)
198                   (cerror "Ignore" "While replacing ~S with ~S, found ~S before patching: ~S."
199                           (old-token patch) (new-token patch) (new-token patch) line))
200
201                 (maybe-terpri)
202                 (when (eql delim :eof)
203                   (return))
204
205                 (let ((patched-line (cl-ppcre:regex-replace-all old-regexp line replacement)))
206                   (write-string patched-line out)))))))))
207     
208(defmethod apply-patch ((patch hunk-patch) repodir)
209  "Apply a single hunk patch to REPODIR."
210  ;; This is just a special case of having several hunks in a row.
211  (apply-hunk-list (list patch) repodir))
212
213(defun apply-patch-list (patches repodir)
214  "Apply a list of patches, attempting to optimize for adjacent hunks."
215  (dformat "~&Looking for adjacent hunks...")
216  (loop while patches
217     do
218     (etypecase (car patches)
219       (hunk-patch
220        (let ((filename (patch-filename (car patches)))
221              (line-number 0))
222          (loop while (and (typep (car patches) 'hunk-patch)
223                           (equal (patch-filename (car patches)) filename)
224                           (>= (hunk-line-number (car patches)) line-number))
225             collect (car patches) into hunks
226             do (setf line-number (+
227                                   (hunk-line-number (car patches))
228                                   (length (hunk-new-lines (car patches)))))
229             (setf patches (cdr patches))
230             finally (loop
231                        (restart-case
232                            (progn
233                              (apply-hunk-list hunks repodir)
234                              (return))
235                          (retry-hunks ()
236                            :report (lambda (stream)
237                                      (format stream "Retry patch ~A to ~A" hunks filename))))))))
238       (patch
239        (apply-patch (car patches) repodir)
240        (setf patches (cdr patches))))))
241
242(defun apply-hunk-list (hunks repodir)
243  "Apply HUNKS to REPODIR.
244HUNKS is assumed to be a list of HUNK-PATCHes, each acting on the
245same file."
246  ;; Darcs' idea of a line is a string of characters
247  ;; terminated by a newline or end-of-file.  Thus, if a
248  ;; file ends with a newline, it has a last line with
249  ;; zero characters.
250  (let* ((filename (merge-pathnames
251                    (patch-filename (car hunks))
252                    repodir)))
253    (dformat "~&Patching ~A with ~A." filename hunks)
254    (with-file-patching (in out filename)
255      (let ((line-number 1) (file-empty t))
256        (flet ((maybe-terpri ()
257                 ;; Unless we're writing the first line, we have to
258                 ;; terminate the previous one.
259                 (if file-empty
260                     (setf file-empty nil)
261                     (write-byte 10 out))))
262          (dolist (hunk hunks)
263            ;; Lines not touched by the hunks are just output.
264            (loop while (< line-number (hunk-line-number hunk))
265               do (let ((line (read-binary-line in nil :eof)))
266                    ;; See if we are skipping more than we have.
267                    (when (and (eql line :eof)
268                               (/= line-number (1- (hunk-line-number hunk))))
269                      (error "Hunk starts at line ~A, but file is shorter."
270                             (hunk-line-number hunk)))
271
272                    (maybe-terpri)
273                    (unless (eql line :eof)
274                      (write-sequence line out))
275
276                    (incf line-number)))
277
278            ;; Start by removing lines...
279            (loop for old on (hunk-old-lines hunk)
280               do
281                 (let ((line (read-binary-line in nil :eof)))
282                   (cond
283                     ((and (eql line :eof) 
284                           (= (length old) 1)
285                           (= (length (car old)) 0))
286                      ;; Sometimes, the file is empty, but the patch
287                      ;; wants to remove one empty line.  That's an
288                      ;; effect of different views of what a line is,
289                      ;; so let it pass.
290                      )
291                     ((eql line :eof)
292                      (error "Hunk ~A too long (looking for ~S)." 
293                             hunk (bytes-to-string (car old))))
294                     ;; Note that equalp would do case-insensitive
295                     ;; comparison if these were not byte arrays.
296                     ((not (equalp (car old) line))
297                      (error "Hunk ~A: text ~S doesn't match file text ~S."
298                             hunk (bytes-to-string (car old))
299                             (bytes-to-string line)))
300                     (t
301                      ;; ...which in this context means not writing
302                      ;; them to the temporary file.
303                      ))))
304           
305            ;; Now, let's add lines.  The obvious way to do it would
306            ;; be to print the lines to output, increasing the line
307            ;; counter for every line.  However, in some circumstances
308            ;; there are two subsequent hunks modifying the same line
309            ;; (i.e. s/A/B/ and s/B/C/ are expected to have the same
310            ;; result as s/A/C/), so we unread the lines instead.
311            (dolist (new (reverse (hunk-new-lines hunk)))
312              (unread-line in new)))
313
314          ;; And output the lines after all hunks
315          (loop for line = (read-binary-line in nil :eof)
316             until (eql line :eof)
317             do (maybe-terpri)
318             (write-sequence line out)))))))
319
320(defmethod apply-patch ((patch merger-patch) repodir)
321  "Apply a merger patch to REPODIR."
322  (dformat "~&Applying merger patch ~A" patch)
323  ;; I'll gladly admit to not understanding what this is supposed to
324  ;; do.  This is a simplified version of merger_equivalent.
325  (let ((undo (merger-undo patch)))
326    (when (null undo)
327      (error "Don't know how to undo ~A." patch))
328
329    (apply-patch undo repodir)
330   
331    ;; After this comes "glump".  As long as version is "0.0", it
332    ;; doesn't do anything.
333    (assert (string= (merger-version patch) "0.0"))))
Note: See TracBrowser for help on using the repository browser.