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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49.2.2 - (show annotations)
Sat Oct 26 18:30:39 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.49.2.1: +3 -0 lines
* code/mapping.lisp (mapping-removed-files): Skip over the MCVS/CVS
directory, which can contain CVS-generated files with F- names and a ,t
suffix. These trip up the algorithm.
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* "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 (defun mcvs-locate ()
28 (let ((current-dir (split-fields (getcwd) *path-sep*)))
29 (dotimes (i (length current-dir) nil)
30 (let* ((path-components (butlast current-dir i))
31 (path-string (reduce #'path-cat path-components)))
32 (when (ignore-errors (stat (path-cat path-string *mcvs-dir*)))
33 (chdir path-string)
34 (return (if (zerop i)
35 "."
36 (reduce #'path-cat (last current-dir i)))))))))
37
38 (defun real-path-exists (path)
39 (or (null *displaced-path-prefix*)
40 (path-prefix-equal *displaced-path-prefix* path)))
41
42 (defun abstract-to-real-path (path)
43 (if *displaced-path-length*
44 (if (or (= (length path) (1- *displaced-path-length*))
45 (= (length path) *displaced-path-length*))
46 *this-dir*
47 (substring path *displaced-path-length*))
48 path))
49
50 (defun real-to-abstract-path (path)
51 (if *displaced-path-prefix*
52 (concatenate 'string *displaced-path-prefix* path)
53 path))
54
55 (declaim (inline real-path-exists abstract-to-real-path
56 real-to-abstract-path))
57
58 (defmacro in-sandbox-root-dir (&body forms)
59 (let ((downpath-sym (gensym "DOWNPATH-")))
60 `(current-dir-restore
61 (let ((,downpath-sym (mcvs-locate)))
62 (when (not ,downpath-sym)
63 (error "could not locate ~a directory." *mcvs-dir*))
64 (let* ((*displaced-path-prefix* (displaced-path-read))
65 (*displaced-path-length* (if *displaced-path-prefix*
66 (length *displaced-path-prefix*))))
67 (flet ((sandbox-translate-path (in-path)
68 (multiple-value-bind (out-path out-of-bounds)
69 (canonicalize-path
70 (if (path-absolute-p in-path)
71 (path-cat *this-dir* in-path)
72 (path-cat ,downpath-sym in-path)))
73 (if out-of-bounds
74 (error "path ~a is not within sandbox." out-path)
75 out-path))))
76 (symbol-macrolet ((sandbox-down-path ,downpath-sym))
77 ,@forms)))))))
78
79 (defstruct mapping-entry
80 (kind :file)
81 (id "")
82 (path "")
83 (target "")
84 (executable nil)
85 (raw-plist nil))
86
87 (defun equal-mapping-entries (left right)
88 (and (eq (mapping-entry-kind left) (mapping-entry-kind right))
89 (string= (mapping-entry-id left) (mapping-entry-id right))
90 (path-equal (mapping-entry-path left) (mapping-entry-path right))
91 (equal (mapping-entry-target left) (mapping-entry-target right))))
92
93 (defun equal-filemaps (left right)
94 (let ((same t))
95 (mapc #'(lambda (le re)
96 (setf same (and same (equal-mapping-entries le re))))
97 left right)
98 same))
99
100 (defun mapping-entry-parse-plist (entry)
101 (with-slots (executable raw-plist) entry
102 (destructuring-bind (&key exec &allow-other-keys)
103 raw-plist
104 (setf executable exec)))
105 (values))
106
107 (defun mapping-generate-id (&key no-dir (suffix "") (prefix "F-"))
108 (format nil "~a~a~32,'0X~a"
109 (if no-dir "" (concatenate 'string *mcvs-dir* *path-sep*))
110 prefix
111 (guid-gen)
112 (if (or (null suffix) (string= "" suffix))
113 ""
114 (concatenate 'string "." suffix))))
115
116 (defun mapping-extract-kind (filemap kind)
117 (remove-if-not #'(lambda (entry-kind)
118 (eq entry-kind kind))
119 filemap
120 :key #'mapping-entry-kind))
121
122 (defun mapping-extract-paths (filemap)
123 (mapcar #'mapping-entry-path filemap))
124 (declaim (inline mapping-extract-paths))
125
126 (defun mapping-lookup (filemap path)
127 (find path filemap :test #'path-equal :key #'mapping-entry-path))
128
129 (defun mapping-prefix-lookup (filemap prefix)
130 (if (path-equal *this-dir* prefix)
131 (first filemap)
132 (find prefix filemap :test #'path-prefix-equal :key #'mapping-entry-path)))
133
134 (defun mapping-prefix-matches (filemap path)
135 (if (path-equal *this-dir* path)
136 filemap
137 (remove-if-not #'(lambda (entry)
138 (path-prefix-equal path (mapping-entry-path entry)))
139 filemap)))
140
141 (defun mapping-same-id-p (entry-one entry-two)
142 (string= (mapping-entry-id entry-one) (mapping-entry-id entry-two)))
143
144 (defun mapping-same-path-p (entry-one entry-two)
145 (path-equal (mapping-entry-path entry-one) (mapping-entry-path entry-two)))
146
147 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
148 "Returns a new filemap, in which the pathames in the list file-list are edited
149 by replacing the old-prefix with the new-prefix. If any path thus created
150 matches an existing map entry, that map entry is removed. The sorting order
151 of the map is not preserved."
152 (flet ((combine (prefix path)
153 (if (string= path "")
154 prefix
155 (canonicalize-path (path-cat prefix path)))))
156 (let* ((op-len (length old-prefix))
157 (delete-map (mapcan #'(lambda (entry)
158 (with-slots (path) entry
159 (if (and (member path file-list
160 :test #'path-equal)
161 (path-prefix-equal old-prefix
162 path))
163 (list entry)))) filemap))
164 (replace-map (mapcan #'(lambda (entry)
165 (with-slots (path) entry
166 (let ((new-entry (copy-mapping-entry
167 entry)))
168 (setf (mapping-entry-path new-entry)
169 (combine new-prefix
170 (subseq path op-len)))
171 (list new-entry))))
172 delete-map)))
173 (append
174 (set-difference
175 (set-difference filemap delete-map :test #'mapping-same-path-p)
176 replace-map :test #'mapping-same-path-p)
177 replace-map))))
178
179 (defun malformed-map ()
180 (error "malformed map (merge conflicts?): correct and run mcvs update."))
181
182 (defun mapping-dupe-check (filemap)
183 "Signals an error condition if the filemap contains duplicate paths or
184 duplicate objects. Otherwise returns the filemap, sorted by path."
185 (let ((dupes)
186 (id-hash (make-hash-table :test #'equal))
187 (path-hash (make-hash-table :test #'equal)))
188 (dolist (entry filemap)
189 (if (gethash (mapping-entry-id entry) id-hash)
190 (push entry dupes)
191 (setf (gethash (mapping-entry-id entry) id-hash) entry))
192 (if (gethash (mapping-entry-path entry) path-hash)
193 (push entry dupes)
194 (setf (gethash (mapping-entry-path entry) path-hash) entry)))
195 (when dupes
196 (dolist (dupe dupes)
197 (chatter-terse "duplicate ~a -> ~a~%"
198 (mapping-entry-id dupe) (mapping-entry-path dupe)))
199 (error "duplicates in map: correct and run mcvs update.")))
200 filemap)
201
202 (defun mapping-convert-old-style-in (raw-filemap)
203 "Converts old-style Meta-CVS file mapping to a list of mapping-entry
204 structures."
205 (mapcar #'(lambda (item)
206 (when (or (not (consp item))
207 (not (and (stringp (first item))
208 (stringp (second item)))))
209 (malformed-map))
210 (make-mapping-entry :kind :file
211 :id (first item)
212 :path (second item)))
213 raw-filemap))
214
215 (defun mapping-convert-in (raw-filemap)
216 "Converts a Meta-CVS filemap as read from a file into its internal
217 representation---a list of mapping-entry structures."
218 (mapcar #'(lambda (item)
219 (when (or (not (consp item))
220 (not (and (keywordp (first item))
221 (stringp (second item)))))
222 (malformed-map))
223 (case (first item)
224 ((:file)
225 (let ((entry (make-mapping-entry :kind :file
226 :id (second item)
227 :path (third item)
228 :raw-plist (fourth item))))
229 (when (fourth item)
230 (mapping-entry-parse-plist entry))
231 entry))
232 ((:symlink)
233 (when (not (third item))
234 (error "bad map: symlink ~a has no target."
235 (second item)))
236 (make-mapping-entry :kind :symlink
237 :id (second item)
238 :path (third item)
239 :target (fourth item)
240 :raw-plist (fifth item)))
241 (otherwise (error "bad type keyword ~s in map."
242 (first item)))))
243 raw-filemap))
244
245 (defun mapping-convert-out (filemap)
246 "Converts the internal representation of a Meta-CVS mapping to
247 the external form that is written out to files."
248 (mapcar #'(lambda (entry)
249 (with-slots (kind id path target executable raw-plist) entry
250 (if executable
251 (setf (getf raw-plist :exec) t)
252 (remf raw-plist :exec))
253 (case kind
254 ((:file) (list* kind id path
255 (if raw-plist (list raw-plist))))
256 ((:symlink) (list* kind id path target
257 (if raw-plist (list raw-plist))))
258 (otherwise (error "unknown mapping entry type ~s." kind)))))
259 filemap))
260
261 (defun mapping-read-raw-map (stream)
262 (let ((map (read stream nil :error)))
263 (if (or (eq map :error)
264 (and (not (consp map)) (not (null map))))
265 (malformed-map)
266 map)))
267
268 (defun mapping-read (source &key sanity-check)
269 "Reads a Meta-CVS from a file, optionally performing a check
270 for duplicate entries"
271 (let (filemap)
272 ;;
273 ;; Read the raw data, ensure that the file contains
274 ;; a Lisp object and that it's a list, or at least a cons.
275 ;;
276 (if (streamp source)
277 (setf filemap (mapping-read-raw-map source))
278 (with-open-file (stream source :direction :input)
279 (setf filemap (mapping-read-raw-map stream))))
280 ;;
281 ;; Distinguish between the old-style Meta-CVS map and
282 ;; the new one. The old one is a list of lists of strings.
283 ;; The new one is a list of lists having a keyword in
284 ;; the first position.
285 ;;
286 (setf filemap (if (or (null filemap) (keywordp (first (first filemap))))
287 (mapping-convert-in filemap)
288 (mapping-convert-old-style-in filemap)))
289
290 (if sanity-check
291 (mapping-dupe-check filemap)
292 filemap)))
293
294 (defun mapping-write (filemap filename &key sort-map)
295 (when sort-map
296 (setf filemap (sort (copy-list filemap)
297 #'string< :key #'mapping-entry-id)))
298 (let ((raw-filemap (mapping-convert-out filemap)))
299 (handler-case
300 (with-open-file (file filename :direction :output)
301 (let ((*print-right-margin* 1))
302 (prin1 raw-filemap file)
303 (terpri file)))
304 (error (cond) (error "unable to write mapping file: ~a" cond)))))
305
306 (defun mapping-synchronize ()
307 "Synchronizes the contents of files in the sandbox, and their corresponding
308 CVS files in the Meta-CVS directory. This must be done before any CVS operation
309 such as commit or update, so that the Meta-CVS files have the correct contents
310 reflecting local changes. It must also be done after any CVS update operation,
311 to ensure that the newly incorporated changes are propagated to the sandbox"
312 (let ((filemap (mapping-read *mcvs-map-local*)))
313 (dolist (entry filemap)
314 (can-restart-here ("Continue synchronizing files.")
315 (with-slots (kind id path target executable) entry
316 (when (real-path-exists path)
317 (case kind
318 ((:file)
319 (let ((left id) (right (abstract-to-real-path path)))
320 (case (synchronize-files left right executable)
321 ((:left)
322 (chatter-info "sync ~a -> ~a~%" left right))
323 ((:right)
324 (chatter-info "sync ~a <- ~a~%" left right))
325 ((:same))
326 ((:dir)
327 (error "cannot sync, either ~a or ~a is a directory."
328 left right))
329 ((nil)
330 (error "cannot sync, neither ~a nor ~a exists."
331 left right)))))
332 ((:symlink)
333 (let* ((symlink (abstract-to-real-path path))
334 (linkdata (no-existence-error (readlink symlink))))
335 (when (or (not linkdata)
336 (not (string= linkdata target)))
337 (no-existence-error (unlink symlink))
338 (ensure-directories-exist symlink)
339 (symlink target symlink)
340 (chatter-info "linking: ~a -> ~a~%"
341 symlink target)))))))))))
342
343 (defun mapping-difference (old-mapping new-mapping)
344 "Compute the difference between two mappings. Returns three values:
345 - a mapping containing only elements added by new-mapping;
346 - a mapping containing only elements removed by new-mapping; and
347 - a list of moved items, which contains pairs of elements from both, whose
348 object name matches, but path differs."
349 (multiple-value-bind (moved-pairs added-items removed-items)
350 (intersection-difference
351 new-mapping old-mapping
352 :key #'mapping-entry-id :test #'equal
353 :combine #'(lambda (new old)
354 (unless (string= (mapping-entry-path new)
355 (mapping-entry-path old))
356 (list old new)))
357 :squash-nil t)
358 (values added-items removed-items moved-pairs)))
359
360 (defun mapping-update (&key no-delete-removed)
361 #.(format nil
362 "Reads the Meta-CVS mapping files ~a and ~a, the local
363 mapping and repository mapping, respectively. It computes the difference
364 between them and then reorganizes the file structure of the sandbox as
365 necessary to make the mapping up to date. Then the local mapping file is
366 overwritten so it is identical to the repository one. This is necessary to
367 bring the local structure up to date after incorporating mapping changes
368 whether they came from the CVS repository, or from local operations."
369 *mcvs-map-local* *mcvs-map*)
370 (let ((old-filemap (mapping-read *mcvs-map-local*))
371 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
372 rollback-remove-items rollback-restore-items)
373 (restart-case
374 (multiple-value-bind (added-items removed-items moved-pairs)
375 (mapping-difference old-filemap new-filemap)
376 ;; First remove what has to be removed. This way when we
377 ;; do sanity checks, we won't complain about clobbering things
378 ;; that are slated to disappear.
379 (dolist (item removed-items)
380 (when (real-path-exists (mapping-entry-path item))
381 (let ((real (abstract-to-real-path (mapping-entry-path item))))
382 (chatter-terse "removing ~a~%" real)
383 (unless no-delete-removed
384 (restart-case
385 (ensure-directories-gone real)
386 (ignore () :report "Ignore file removal error."))
387 (push item rollback-restore-items)))))
388
389 (dolist (pair moved-pairs)
390 (let ((old-item (first pair)))
391 (with-slots (path) old-item
392 (when (real-path-exists path)
393 (ensure-directories-gone (abstract-to-real-path path))
394 (push old-item rollback-restore-items)))))
395
396 ;; Now check sanity of adds and moves, to verify they don't
397 ;; clobber any local files.
398 (let (clobber-add-items clobber-move-pairs)
399 (dolist (item added-items)
400 (with-slots (kind id path target) item
401 (when (real-path-exists path)
402 (let* ((real-path (abstract-to-real-path path))
403 (file-info (exists real-path)))
404 (when (and file-info
405 (case kind
406 ((:file)
407 (not (same-file-p file-info (stat id))))
408 ((:symlink)
409 (not (string= (readlink real-path)
410 target)))
411 (otherwise t))
412 (not (mapping-lookup old-filemap path)))
413 (push item clobber-add-items))))))
414
415 (dolist (item moved-pairs)
416 (destructuring-bind (old-item new-item) item
417 (declare (ignore old-item))
418 (with-slots (path) new-item
419 (when (real-path-exists path)
420 (let ((file-info (exists (abstract-to-real-path path))))
421 (when (and file-info
422 (not (mapping-lookup old-filemap path)))
423 (push item clobber-move-pairs)))))))
424
425 (when (or clobber-add-items clobber-move-pairs)
426 (block nil
427 (restart-bind
428 ((print-clobbers
429 #'(lambda ()
430 (dolist (item clobber-add-items)
431 (format t "add: ~a~%"
432 (abstract-to-real-path (mapping-entry-path item))))
433 (dolist (pair clobber-move-pairs)
434 (format t "move ~a -> ~a~%"
435 (abstract-to-real-path (mapping-entry-path
436 (first pair)))
437 (abstract-to-real-path (mapping-entry-path
438 (second pair))))))
439 :report-function
440 #'(lambda (stream)
441 (write-string "Print list of adds or moves which want to overwrite."
442 stream)))
443 (do-clobber
444 #'(lambda ()
445 (return))
446 :report-function
447 #'(lambda (stream)
448 (write-string "Go ahead and overwrite the target files."
449 stream))))
450 (error "some moves or adds want to overwrite local files or directories.")))))
451
452 ;; Sanity check passed, complete moves and adds.
453 (dolist (item moved-pairs)
454 (destructuring-bind (old-item new-item) item
455 (with-slots ((old-path path) (old-id id)) old-item
456 (with-slots ((new-path path) (new-id id) kind target executable)
457 new-item
458 (let ((real-old-exists (real-path-exists old-path))
459 (real-new-exists (real-path-exists new-path)))
460 (let ((real-old (and real-old-exists
461 (abstract-to-real-path old-path)))
462 (real-new (and real-new-exists
463 (abstract-to-real-path new-path))))
464 (cond
465 ((and real-old-exists real-new-exists)
466 (chatter-terse "moving ~a -> ~a~%" real-old real-new))
467 (real-new-exists
468 (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
469 (real-old-exists
470 (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
471
472 (when real-new-exists
473 (no-existence-error (unlink real-new))
474 (case kind
475 ((:file)
476 (synchronize-files new-id real-new executable))
477 ((:symlink)
478 (ensure-directories-exist real-new)
479 (symlink target real-new)))
480 (push new-item rollback-remove-items))))))))
481
482 (dolist (item added-items)
483 (with-slots (kind id path target executable) item
484 (when (real-path-exists path)
485 (let ((real (abstract-to-real-path path)))
486 (can-restart-here ("Continue updating file structure.")
487 (case kind
488 ((:file)
489 (chatter-terse "adding ~a~%" real)
490 (synchronize-files id real executable))
491 ((:symlink)
492 (chatter-terse "linking ~a -> ~a~%" real target)
493 (no-existence-error (unlink real))
494 (ensure-directories-exist real)
495 (symlink target real)))
496 (push item rollback-remove-items)))))))
497 (continue ()
498 :report "Restore all restructuring done so far."
499 (chatter-debug "Restoring.~%")
500 (dolist (item rollback-remove-items)
501 (let ((real (abstract-to-real-path (mapping-entry-path item))))
502 (chatter-terse "removing ~a~%" real)
503 (ensure-directories-gone real)))
504 (dolist (item rollback-restore-items)
505 (with-slots (kind path id target executable) item
506 (let ((real (abstract-to-real-path path)))
507 (chatter-terse "restoring ~a~%" real)
508 (case kind
509 ((:file)
510 (synchronize-files id real executable))
511 ((:symlink)
512 (ensure-directories-exist real)
513 (symlink target real))))))
514 (return-from mapping-update nil)))
515
516 (mapping-write new-filemap *mcvs-map-local*))
517 t)
518
519 (defun mapping-removed-files (filemap)
520 (let ((to-be-removed ())
521 (f-hash (make-hash-table :test #'equal)))
522 (dolist (entry filemap)
523 (setf (gethash (mapping-entry-id entry) f-hash) entry))
524 (for-each-file-info (fi *mcvs-dir*)
525 (when (and (directory-p fi)
526 (path-equal (basename (file-name fi)) "CVS"))
527 (skip))
528 (let ((base (basename (file-name fi))))
529 (multiple-value-bind (suffix name) (suffix base)
530 (declare (ignore suffix))
531 (when (and (= (length name) 34)
532 (string= (subseq name 0 2) "F-")
533 (not (gethash (file-name fi) f-hash)))
534 (push (file-name fi) to-be-removed)))))
535 to-be-removed))
536
537 (defun displaced-path-read ()
538 (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
539 (read file))))
540
541 (defun displaced-path-write (path)
542 (with-open-file (file *mcvs-displaced* :direction :output)
543 (prin1 path file)
544 (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5