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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Mon Jul 8 05:20:42 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-20, mcvs-0-21, mcvs-0-19
Changes since 1.38: +4 -4 lines
* seqfuncs.lisp (intersection-difference): Support a new
keyword parameter :squash-nil.

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

  ViewVC Help
Powered by ViewVC 1.1.5