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

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

Fix error signalling when file to create already exists

File size: 12.9 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(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  ;; Maybe we're applying the patch to a pristine directory, in which
93  ;; case we don't care about preferences.
94  (when (has-prefs-dir repodir)
95    (with-accessors ((pref change-pref-which)
96                     (from change-pref-from)
97                     (to change-pref-to)) patch
98      (let ((old-value (or (get-pref repodir pref) "")))
99        (unless (string= from old-value)
100          (warn
101           "While changing pref ~S to ~S, expected old value to be ~S, but it was ~S."
102           pref to from old-value))
103        (set-pref repodir pref to)))))
104
105(defmethod apply-patch ((patch add-file-patch) repodir)
106  "Create a file in REPODIR, by PATCH."
107  (let ((new-file (merge-pathnames
108                   (patch-filename patch) repodir)))
109    (dformat "~&Creating file ~A." new-file)
110    (with-open-file (f new-file :direction :output
111                       :if-does-not-exist :create
112                       :if-exists :error)
113      (declare (ignore f)))))
114
115(defmethod apply-patch ((patch binary-patch) repodir)
116  "Apply a binary patch in REPODIR."
117  (let ((file (merge-pathnames (patch-filename patch) repodir)))
118    ;; Check that the file matches the old content.
119    (with-open-file (in file
120                        :direction :input :if-does-not-exist :error
121                        :element-type '(unsigned-byte 8))
122      (when (or (/= (file-length in) (length (binary-oldhex patch)))
123                (let ((bytes (make-array (file-length in)
124                                         :element-type '(unsigned-byte 8))))
125                  (read-sequence bytes in)
126                  (not (equalp bytes (binary-oldhex patch)))))
127        (cerror "Write new contents to ~A anyway."
128                "Contents of ~A don't match patch." file)))
129    ;; Overwrite with new content.
130    (with-open-file (out file
131                         :direction :output :if-exists :supersede
132                         :element-type '(unsigned-byte 8))
133      (write-sequence (binary-newhex patch) out))))
134
135(defmethod apply-patch ((patch rm-file-patch) repodir)
136  "Delete a file in REPODIR.  File should be empty.
137If it's not, a warning will be signalled."
138  (let ((the-file (merge-pathnames
139                   (patch-filename patch) repodir)))
140    (with-open-file (in the-file :direction :input
141                        :if-does-not-exist :error)
142      (let ((length (file-length in)))
143      (unless (zerop length)
144        (warn "File ~A is not empty (contains ~A bytes)." the-file length))))
145    (dformat "~&Deleting file ~A." the-file)
146    (delete-file the-file)))
147
148(defmethod apply-patch ((patch add-dir-patch) repodir)
149  "Create a directory in REPODIR."
150  (let ((new-dir (merge-pathnames (patch-directory patch) repodir)))
151    (dformat "~&Creating directory ~A." new-dir)
152    (make-dir new-dir)))
153
154(defmethod apply-patch ((patch rm-dir-patch) repodir)
155  "Delete a directory in REPODIR.  Directory must be empty."
156  (let ((dir-to-remove (merge-pathnames (patch-directory patch) repodir)))
157    (dformat "~&Deleting directory ~A." dir-to-remove)
158    (delete-dir dir-to-remove)))
159
160(defmethod apply-patch ((patch move-patch) repodir)
161  "Move a file in REPODIR."
162  (let ((from (merge-pathnames (patch-move-from patch) repodir))
163        (to (merge-pathnames (patch-move-to patch) repodir)))
164;;     (fad:copy-file from to :overwrite nil)
165;;     (delete-file from)
166
167    ;; This seems to be an easier method, which works even if we're
168    ;; moving a directory.
169    #+sbcl (sb-ext:run-program "mv" (list (namestring from) (namestring to))
170                               :search t)
171    #+clisp (let ((result (ext:run-program "mv" :arguments (list (namestring from) (namestring to)))))
172              (unless (eql result 0)
173                (error "Couldn't move ~A to ~A." from to)))
174   
175    ;; In Lispworks, this works for both files and directories.
176    #+lispworks (rename-file from to)
177
178    #-(or clisp sbcl lispworks)
179    (error "Applying a MOVE-PATCH is not implemented for ~A." (lisp-implementation-type))))
180
181(defmethod apply-patch ((patch token-replace-patch) repodir)
182  "Apply a token replace patch to a file in REPODIR."
183  (let ((filename (merge-pathnames (patch-filename patch) repodir))
184        (old-regexp (cl-ppcre:create-scanner
185                     (format nil "(^|[^~A])~A($|[^~A])"
186                             (token-regexp patch)
187                             (old-token patch)
188                             (token-regexp patch))))
189        (new-regexp (cl-ppcre:create-scanner
190                     (format nil "(^|[^~A])~A($|[^~A])"
191                             (token-regexp patch)
192                             (new-token patch)
193                             (token-regexp patch))))
194        (replacement (format nil "\\1~A\\2" (new-token patch))))
195    (dformat "~&Patching ~A with ~A." filename patch)
196    (with-file-patching (in out filename)
197      (let ((file-empty t))
198        (flet ((maybe-terpri ()
199                 ;; Unless we're writing the first line, we have to
200                 ;; terminate the previous one.
201                 (if file-empty
202                     (setf file-empty nil)
203                     (write-byte 10 out))))
204          (loop
205             (let ((line (read-binary-line in nil :eof)))
206               (when (eql line :eof)
207                 (return))
208               (maybe-terpri)
209
210               (setf line (bytes-to-string line))
211               (when (cl-ppcre:scan new-regexp line)
212                 (cerror "Ignore" "While replacing ~S with ~S, found ~S before patching: ~S."
213                         (old-token patch) (new-token patch) (new-token patch) line))
214               
215               (let ((patched-line (cl-ppcre:regex-replace-all old-regexp line replacement)))
216                 (write-sequence (string-to-bytes patched-line) out)))))))))
217     
218(defmethod apply-patch ((patch hunk-patch) repodir)
219  "Apply a single hunk patch to REPODIR."
220  ;; This is just a special case of having several hunks in a row.
221  (apply-hunk-list (list patch) repodir))
222
223(defun apply-patch-list (patches repodir)
224  "Apply a list of patches, attempting to optimize for adjacent hunks."
225  (dformat "~&Looking for adjacent hunks...")
226  (loop while patches
227     do
228     (etypecase (car patches)
229       (hunk-patch
230        (let ((filename (patch-filename (car patches)))
231              (line-number 0))
232          (loop while (and (typep (car patches) 'hunk-patch)
233                           (equal (patch-filename (car patches)) filename)
234                           (>= (hunk-line-number (car patches)) line-number))
235             collect (car patches) into hunks
236             do (setf line-number (+
237                                   (hunk-line-number (car patches))
238                                   (length (hunk-new-lines (car patches)))))
239             (setf patches (cdr patches))
240             finally (loop
241                        (restart-case
242                            (progn
243                              (apply-hunk-list hunks repodir)
244                              (return))
245                          (retry-hunks ()
246                            :report (lambda (stream)
247                                      (format stream "Retry patch ~A to ~A" hunks filename))))))))
248       (patch
249        (apply-patch (car patches) repodir)
250        (setf patches (cdr patches))))))
251
252(defun apply-hunk-list (hunks repodir)
253  "Apply HUNKS to REPODIR.
254HUNKS is assumed to be a list of HUNK-PATCHes, each acting on the
255same file."
256  ;; Darcs' idea of a line is a string of characters
257  ;; terminated by a newline or end-of-file.  Thus, if a
258  ;; file ends with a newline, it has a last line with
259  ;; zero characters.
260  (let* ((filename (merge-pathnames
261                    (patch-filename (car hunks))
262                    repodir)))
263    (dformat "~&Patching ~A with ~A." filename hunks)
264    (with-file-patching (in out filename)
265      (let ((line-number 1) (file-empty t))
266        (flet ((maybe-terpri ()
267                 ;; Unless we're writing the first line, we have to
268                 ;; terminate the previous one.
269                 (if file-empty
270                     (setf file-empty nil)
271                     (write-byte 10 out))))
272          (dolist (hunk hunks)
273            ;; Lines not touched by the hunks are just output.
274            (loop while (< line-number (hunk-line-number hunk))
275               do (let ((line (read-binary-line in nil :eof)))
276                    ;; See if we are skipping more than we have.
277                    (when (and (eql line :eof)
278                               (/= line-number (1- (hunk-line-number hunk))))
279                      (error "Hunk starts at line ~A, but file is shorter."
280                             (hunk-line-number hunk)))
281
282                    (maybe-terpri)
283                    (unless (eql line :eof)
284                      (write-sequence line out))
285
286                    (incf line-number)))
287
288            ;; Start by removing lines...
289            (loop for old on (hunk-old-lines hunk)
290               do
291                 (let ((line (read-binary-line in nil :eof)))
292                   (cond
293                     ((and (eql line :eof) 
294                           (= (length old) 1)
295                           (= (length (car old)) 0))
296                      ;; Sometimes, the file is empty, but the patch
297                      ;; wants to remove one empty line.  That's an
298                      ;; effect of different views of what a line is,
299                      ;; so let it pass.
300                      )
301                     ((eql line :eof)
302                      (error "Hunk ~A too long (looking for ~S)." 
303                             hunk (bytes-to-string (car old))))
304                     ;; Note that equalp would do case-insensitive
305                     ;; comparison if these were not byte arrays.
306                     ((not (equalp (car old) line))
307                      (error "Hunk ~A: text ~S doesn't match file text ~S."
308                             hunk (bytes-to-string (car old))
309                             (bytes-to-string line)))
310                     (t
311                      ;; ...which in this context means not writing
312                      ;; them to the temporary file.
313                      ))))
314           
315            ;; Now, let's add lines.  The obvious way to do it would
316            ;; be to print the lines to output, increasing the line
317            ;; counter for every line.  However, in some circumstances
318            ;; there are two subsequent hunks modifying the same line
319            ;; (i.e. s/A/B/ and s/B/C/ are expected to have the same
320            ;; result as s/A/C/), so we unread the lines instead.
321            (dolist (new (reverse (hunk-new-lines hunk)))
322              (unread-line in new)))
323
324          ;; And output the lines after all hunks
325          (loop for line = (read-binary-line in nil :eof)
326             until (eql line :eof)
327             do (maybe-terpri)
328             (write-sequence line out)))))))
329
330(defmethod apply-patch ((patch merger-patch) repodir)
331  "Apply a merger patch to REPODIR."
332  (dformat "~&Applying merger patch ~A" patch)
333  ;; I'll gladly admit to not understanding what this is supposed to
334  ;; do.  This is a simplified version of merger_equivalent.
335  (let ((undo (merger-undo patch)))
336    (when (null undo)
337      (error "Don't know how to undo ~A." patch))
338
339    (apply-patch undo repodir)
340   
341    ;; After this comes "glump".  As long as version is "0.0", it
342    ;; doesn't do anything.
343    (assert (string= (merger-version patch) "0.0"))))
Note: See TracBrowser for help on using the repository browser.