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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5