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. |
---|
21 | Bind INSTREAMVAR to a stream that reads from FILENAME. |
---|
22 | Bind OUTSTREAMVAR to a stream that writes to a temporary file. |
---|
23 | If 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. |
---|
68 | In 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. |
---|
82 | That 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. |
---|
133 | If 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. |
---|
244 | HUNKS is assumed to be a list of HUNK-PATCHes, each acting on the |
---|
245 | same 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")))) |
---|