/[meta-cvs]/meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8
ViewVC logotype

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Wed Mar 13 21:46:39 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-9, mcvs-0-10, deferred-adds-branch~branch-point
Branch point for: deferred-adds-branch
Changes since 1.28: +13 -1 lines
* mapping.lisp (malformed-map): New function.
(mapping-dupe-check): Perform extra error checks when reading
mapping, and turn them into a condition with a ``nice'' error message.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "dirwalk")
6 (require "system")
7 (require "sync")
8 (require "chatter")
9 (require "restart")
10 (provide "mapping")
11
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (defconstant *mcvs-dir* #.(path-cat "MCVS"))
14 (defconstant *mcvs-map-name* "MAP")
15 (defconstant *mcvs-map-local-name* "MAP-LOCAL"))
16
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
19 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*)))
20
21 ;; TODO: use getcwd()
22 (defun mcvs-locate ()
23 "Search for Meta-CVS directory by looking in the current directory, and
24 if it is not found there, by changing directory up through successive
25 parent directories. Returns the path from the new current directory
26 down to the original one, or the value nil if not found."
27 (if (ignore-errors (stat *mcvs-dir*))
28 "."
29 (let ((came-from (go-up)))
30 (if came-from
31 (let ((locate (mcvs-locate)))
32 (if locate
33 (path-cat locate came-from)))))))
34
35 (defmacro in-sandbox-root-dir (&body forms)
36 (let ((downpath-sym (gensym "DOWNPATH-")))
37 `(current-dir-restore
38 (let ((,downpath-sym (mcvs-locate)))
39 (when (not ,downpath-sym)
40 (error "mcvs: could not locate ~a directory." *mcvs-dir*))
41 (flet ((sandbox-translate-path (in-path)
42 (multiple-value-bind (out-path out-of-bounds)
43 (canonicalize-path
44 (path-cat ,downpath-sym in-path))
45 (if out-of-bounds
46 (error "mcvs: path ~a is not within sandbox." out-path)
47 out-path))))
48 (symbol-macrolet ((sandbox-down-path ',downpath-sym))
49 ,@forms))))))
50
51 (defun mapping-generate-name (suffix &key no-dir)
52 (let* ((suffix (if (or (null suffix)
53 (string= "" suffix))
54 ""
55 (format nil ".~a" suffix)))
56 (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))
57 (if no-dir
58 name
59 (path-cat *mcvs-dir* name))))
60
61 (defun mapping-extract-paths (filemap)
62 (mapcar #'second filemap))
63 (declaim (inline mapping-extract-paths))
64
65 (defun mapping-lookup (filemap path)
66 (find path filemap :test #'path-equal :key #'second))
67
68 (defun mapping-prefix-lookup (filemap prefix)
69 (if (path-equal *this-dir* prefix)
70 (first filemap)
71 (find prefix filemap :test #'path-prefix-equal :key #'second)))
72
73 (defun mapping-prefix-matches (filemap path)
74 (if (path-equal *this-dir* path)
75 filemap
76 (remove-if-not #'(lambda (entry)
77 (path-prefix-equal path (second entry))) filemap)))
78
79 (defun mapping-object-lookup (filemap object)
80 (find object filemap :test #'string= :key #'first))
81
82 (defun mapping-same-object-p (entry-one entry-two)
83 (string= (first entry-one) (first entry-two)))
84
85 (defun mapping-same-path-p (entry-one entry-two)
86 (path-equal (second entry-one) (second entry-two)))
87
88 (defun mapping-moved-p (entry-one entry-two)
89 (and (string= (first entry-one) (first entry-two))
90 (not (path-equal (second entry-one) (second entry-two)))))
91
92 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
93 "Returns a new filemap, in which the pathames in the list file-list are edited
94 by replacing the old-prefix with the new-prefix. If any path thus created
95 matches an existing map entry, that map entry is removed. The sorting order
96 of the map is not preserved."
97 (flet ((combine (prefix path)
98 (if (string= path "")
99 prefix
100 (canonicalize-path (path-cat prefix path)))))
101 (let* ((op-len (length old-prefix))
102 (delete-map (mapcan #'(lambda (entry)
103 (let ((path (second entry)))
104 (if (and (member path file-list
105 :test #'path-equal)
106 (path-prefix-equal old-prefix
107 path))
108 (list entry)))) filemap))
109 (replace-map (mapcan #'(lambda (entry)
110 (destructuring-bind (object path) entry
111 (list (list object
112 (combine new-prefix
113 (subseq path
114 op-len))))))
115 delete-map)))
116 (append
117 (set-difference
118 (set-difference filemap delete-map :test #'mapping-same-path-p)
119 replace-map :test #'mapping-same-path-p)
120 replace-map))))
121
122 (defun malformed-map ()
123 (error "mcvs: malformed map (merge conflicts?): correct and run mcvs update."))
124
125 (defun mapping-dupe-check (filemap)
126 "Signals an error condition if the filemap contains duplicate paths or
127 duplicate objects. Otherwise returns the filemap, sorted by path."
128 (dolist (entry filemap)
129 (when (or (not (consp entry))
130 (not (and (stringp (first entry))
131 (stringp (second entry)))))
132 (malformed-map)))
133
134 (let (dupes)
135 (sort filemap #'string-lessp :key #'first)
136
137 (let ((iter (rest filemap)) (current-item (first (first filemap))))
138 (loop
139 (when (endp iter)
140 (return))
141 (if (string= (first (first iter)) current-item)
142 (push (first iter) dupes)
143 (setf current-item (first (first iter))))
144 (setf iter (rest iter))))
145
146 (sort filemap #'string-lessp :key #'second)
147
148 (let ((iter (rest filemap)) (current-item (second (first filemap))))
149 (loop
150 (when (endp iter)
151 (return))
152 (if (path-equal (second (first iter)) current-item)
153 (push (first iter) dupes)
154 (setf current-item (second (first iter))))
155 (setf iter (rest iter))))
156
157 (when dupes
158 (dolist (dupe dupes)
159 (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second dupe)))
160 (error "mcvs: duplicates in map: correct and run mcvs update.")))
161 filemap)
162
163 (defun mapping-read (filename &key sanity-check)
164 (let (filemap)
165 (with-open-file (file filename :direction :input)
166 (setf filemap (read file nil :error))
167 (when (or (eq filemap :error)
168 (and (not (consp filemap)) (not (null filemap))))
169 (malformed-map)))
170 (if sanity-check
171 (mapping-dupe-check filemap)
172 filemap)))
173
174 (defun mapping-write (filemap filename &key sort-map)
175 (with-open-file (file filename :direction :output)
176 (let ((*print-right-margin* 1))
177 (prin1 (if sort-map
178 (sort filemap #'string-lessp :key #'first)
179 filemap) file)
180 (terpri file))))
181
182 (defun mapping-synchronize ()
183 "Synchronizes the contents of files in the sandbox, and their corresponding
184 CVS files in the Meta-CVS directory. This must be done before any CVS operation
185 such as commit or update, so that the Meta-CVS files have the correct contents
186 reflecting local changes. It must also be done after any CVS update operation,
187 to ensure that the newly incorporated changes are propagated to the sandbox"
188 (let ((filemap (mapping-read *mcvs-map-local*)))
189 (dolist (item filemap)
190 (can-restart-here ("Continue synchronizing files.")
191 (destructuring-bind (left right) item
192 (case (synchronize-files left right)
193 ((:left)
194 (chatter-info "sync ~a -> ~a~%" left right))
195 ((:right)
196 (chatter-info "sync ~a <- ~a~%" left right))
197 ((:same))
198 ((:dir)
199 (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
200 left right))
201 ((nil)
202 (error "mcvs-sync: neither ~a nor ~a exists."
203 left right))))))))
204
205 (defun mapping-difference (old-mapping new-mapping)
206 "Compute the difference between two mappings. Returns three values:
207 - a mapping containing only elements added by new-mapping;
208 - a mapping containing only elements removed by new-mapping; and
209 - a list of moved items, which contains pairs of elements from both, whose
210 object name matches, but path differs."
211 (let (added-items removed-items moved-pairs)
212 (sort old-mapping #'string-lessp :key #'first)
213 (sort new-mapping #'string-lessp :key #'first)
214
215 (loop
216 (let* ((old-item (first old-mapping))
217 (new-item (first new-mapping)))
218 (cond
219 ((and (endp old-item) (endp new-item)) (return))
220 ((string-lessp (first old-item) (first new-item))
221 (pop old-mapping)
222 (push old-item removed-items))
223 ((string= (first old-item) (first new-item))
224 (pop old-mapping)
225 (pop new-mapping)
226 (when (not (path-equal (second old-item) (second new-item)))
227 (push (list old-item new-item) moved-pairs)))
228 (t
229 (pop new-mapping)
230 (push new-item added-items)))))
231 (values added-items removed-items moved-pairs)))
232
233 (defun mapping-update ()
234 #.(format nil
235 "Reads the Meta-CVS mapping files ~a and ~a, the local
236 mapping and repository mapping, respectively. It computes the difference
237 between them and then reorganizes the file structure of the sandbox as
238 necessary to make the mapping up to date. Then the local mapping file is
239 overwritten so it is identical to the repository one. This is necessary to
240 bring the local structure up to date after incorporating mapping changes
241 whether they came from the CVS repository, or from local operations."
242 *mcvs-map-local* *mcvs-map*)
243 (let ((old-filemap (mapping-read *mcvs-map-local*))
244 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
245 rollback-remove-items rollback-restore-items)
246 (restart-case
247 (multiple-value-bind (added-items removed-items moved-pairs)
248 (mapping-difference old-filemap new-filemap)
249 ;; First remove what has to be removed. This way when we
250 ;; do sanity checks, we won't complain about clobbering things
251 ;; that are slated to disappear.
252 (dolist (item removed-items)
253 (chatter-terse "removing ~a~%" (second item))
254 (ensure-directories-gone (second item))
255 (push item rollback-restore-items))
256
257 (dolist (pair moved-pairs)
258 (let ((old-item (first pair)))
259 (ensure-directories-gone (second old-item))
260 (push old-item rollback-restore-items)))
261
262 ;; Now check sanity of adds and moves, to verify they don't
263 ;; clobber any local files.
264 (let (clobber-add-items clobber-move-pairs)
265 (dolist (item added-items)
266 (let ((file-info (exists (second item))))
267 (when (and file-info
268 (not (same-file-p file-info (stat (first item))))
269 (not (mapping-lookup old-filemap (second item))))
270 (push item clobber-add-items))))
271
272 (dolist (item moved-pairs)
273 (destructuring-bind (old-item new-item) item
274 (declare (ignore old-item))
275 (let ((file-info (exists (second new-item))))
276 (when (and file-info
277 (not (mapping-lookup old-filemap (second new-item))))
278
279 (push item clobber-move-pairs)))))
280
281 (when (or clobber-add-items clobber-move-pairs)
282 (block nil
283 (restart-bind
284 ((print-clobbers
285 #'(lambda ()
286 (dolist (item clobber-add-items)
287 (format t "add: ~a~%" (second item)))
288 (dolist (pair clobber-move-pairs)
289 (format t "move ~a -> ~a~%" (second (first pair))
290 (second (second pair)))))
291 :report-function
292 #'(lambda (stream)
293 (write-string "Print list of adds or moves which want to overwrite."
294 stream)))
295 (do-clobber
296 #'(lambda ()
297 (return))
298 :report-function
299 #'(lambda (stream)
300 (write-string "Go ahead and overwrite the target files."
301 stream))))
302 (error "mcvs: some moves or adds want to overwrite local files or directories.")))))
303
304 ;; Sanity check passed, complete moves and adds.
305 (dolist (item moved-pairs)
306 (destructuring-bind (old-item new-item) item
307 (chatter-terse "moving ~a -> ~a~%" (second old-item)
308 (second new-item))
309 (no-existence-error (unlink (second new-item)))
310 (synchronize-files (first new-item) (second new-item))
311 (push new-item rollback-remove-items)))
312
313 (dolist (item added-items)
314 (can-restart-here ("Continue updating file structure.")
315 (chatter-terse "adding ~a~%" (second item))
316 (synchronize-files (first item) (second item))
317 (push item rollback-remove-items))))
318 (continue ()
319 :report "Restore all restructuring done so far."
320 (chatter-debug "Restoring.~%")
321 (dolist (item rollback-remove-items)
322 (chatter-terse "removing ~a~%" (second item))
323 (ensure-directories-gone (second item)))
324 (dolist (item rollback-restore-items)
325 (chatter-terse "restoring ~a~%" (second item))
326 (synchronize-files (first item) (second item)))
327 (return-from mapping-update nil)))
328
329 (mapping-write new-filemap *mcvs-map-local*))
330 t)

  ViewVC Help
Powered by ViewVC 1.1.5