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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.61 - (show annotations)
Tue Apr 22 06:28:16 2003 UTC (10 years, 11 months ago) by kaz
Branch: MAIN
Changes since 1.60: +4 -4 lines
Merging from mcvs-1-0-branch.

Slightly redesigned error handling protocol.

* code/update.lisp (mcvs-update): Change continue restart to bail.

* code/add.lisp (mcvs-add): Likewise.

* code/error.lisp (mcvs-error-handler): Specially recognize two
additional restart symbols, bail and info. A bail restart performs
any rolling back and cleanup and terminates. Continuation is now
properly reserved for actions that proceed boldly to finish
the job, possibly irretrievably clobbering precious data.
The info restart is now a standard way to indicate that more
details about the error can be obtained, so this does not have
to be represented as a special action with an ad-hoc restart.

* code/create.lisp (mcvs-create): Change show restart to info.

* code/remap.lisp (mcvs-remap): Change ignore restart to continue.

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

  ViewVC Help
Powered by ViewVC 1.1.5