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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5