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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations)
Thu Apr 24 04:14:42 2003 UTC (10 years, 11 months ago) by kaz
Branch: MAIN
Changes since 1.61: +7 -8 lines
Merging from mcvs-1-0-branch.

Improved error handling again in a flash of sanity. The whole
idea of ``bail'' as a restart is gone. All code which must perform
some complex cleanup action does so as part of normal unwinding.
And so termination becomes safe.

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

* code/mcvs-main.lisp (*global-options*): Remove "error-bail".
(*usage*): Remove description of --error-bail.
(mcvs-execute): Bind *mcvs-error-treatment* to :terminate rather
than :bail if controlling TTY cannot be opened.

* code/move.lisp (mcvs-move): Change "Undoing move" error message
to "Undoing changes to map".

* code/add.lisp (mcvs-add): Get rid of bail restart; move cleanup
code into unwind-protect block.

* code/error.lisp (*mcvs-error-treatment*): Touch up docstring.
(mcvs-error-handler): Remove anything having to do with :bail.
Change description of `T' command to suggest that it is safe.

* code/options.lisp (filter-mcvs-options): Remove handling of
"error-bail" option.

* code/mapping.lisp (mapping-update): Get rid of outermost
restart-case, which had just a bail restart. Replace it with
unwind-protect block which does exactly the same restoration.
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-needed t)
391 rollback-remove-items rollback-restore-items)
392 (unwind-protect
393 (multiple-value-bind (added-items removed-items moved-pairs)
394 (mapping-difference old-filemap new-filemap)
395 ;; First remove what has to be removed. This way when we
396 ;; do sanity checks, we won't complain about clobbering things
397 ;; that are slated to disappear.
398 (dolist (item removed-items)
399 (when (real-path-exists (mapping-entry-path item))
400 (let ((real (abstract-to-real-path (mapping-entry-path item))))
401 (chatter-terse "removing ~a~%" real)
402 (unless no-delete-removed
403 (restart-case
404 (honor-dry-run (real)
405 (ensure-directories-gone real))
406 (continue () :report "Ignore file removal error."))
407 (push item rollback-restore-items)))))
408
409 (dolist (pair moved-pairs)
410 (let ((old-item (first pair)))
411 (with-slots (path) old-item
412 (when (real-path-exists path)
413 (honor-dry-run (path)
414 (ensure-directories-gone (abstract-to-real-path path)))
415 (push old-item rollback-restore-items)))))
416
417 ;; Now check sanity of adds and moves, to verify they don't
418 ;; clobber any local files.
419 (let (clobber-add-items clobber-move-pairs)
420 (dolist (item added-items)
421 (with-slots (kind id path target) item
422 (when (real-path-exists path)
423 (let* ((real-path (abstract-to-real-path path))
424 (file-info (exists real-path)))
425 (when (and file-info
426 (case kind
427 ((:file)
428 (not (same-file-p file-info (stat id))))
429 ((:symlink)
430 (not (string= (readlink real-path)
431 target)))
432 (otherwise t))
433 (not (mapping-lookup old-filemap path)))
434 (push item clobber-add-items))))))
435
436 (dolist (item moved-pairs)
437 (destructuring-bind (old-item new-item) item
438 (declare (ignore old-item))
439 (with-slots (path) new-item
440 (when (real-path-exists path)
441 (let ((file-info (exists (abstract-to-real-path path))))
442 (when (and file-info
443 (not (mapping-lookup old-filemap path)))
444 (push item clobber-move-pairs)))))))
445
446 (when (or clobber-add-items clobber-move-pairs)
447 (super-restart-case
448 (error "some moves or adds want to overwrite local files or directories.")
449 (info ()
450 :report "Print list of adds or moves which want to overwrite."
451 (dolist (item clobber-add-items)
452 (format t "add: ~a~%"
453 (abstract-to-real-path (mapping-entry-path item))))
454 (dolist (pair clobber-move-pairs)
455 (format t "move ~a -> ~a~%"
456 (abstract-to-real-path (mapping-entry-path
457 (first pair)))
458 (abstract-to-real-path (mapping-entry-path
459 (second pair))))))
460 (continue ()
461 :report "Go ahead and overwrite the target files."
462 (unwind)))))
463
464 ;; Sanity check passed, complete moves and adds.
465 (dolist (item moved-pairs)
466 (destructuring-bind (old-item new-item) item
467 (with-slots ((old-path path) (old-id id)) old-item
468 (with-slots ((new-path path) (new-id id) kind target executable)
469 new-item
470 (let ((real-old-exists (real-path-exists old-path))
471 (real-new-exists (real-path-exists new-path)))
472 (let ((real-old (and real-old-exists
473 (abstract-to-real-path old-path)))
474 (real-new (and real-new-exists
475 (abstract-to-real-path new-path))))
476 (cond
477 ((and real-old-exists real-new-exists)
478 (chatter-terse "moving ~a -> ~a~%" real-old real-new))
479 (real-new-exists
480 (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
481 (real-old-exists
482 (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
483
484 (when real-new-exists
485 (no-existence-error (honor-dry-run (real-new)
486 (unlink real-new)))
487 (case kind
488 ((:file)
489 (synchronize-files new-id real-new executable
490 :direction :right))
491 ((:symlink)
492 (honor-dry-run (target real-new)
493 (ensure-directories-exist real-new)
494 (symlink target real-new))))
495 (push new-item rollback-remove-items))))))))
496
497 (dolist (item added-items)
498 (with-slots (kind id path target executable) item
499 (when (real-path-exists path)
500 (let ((real (abstract-to-real-path path)))
501 (can-restart-here ("Continue updating file structure.")
502 (no-existence-error (honor-dry-run (real)
503 (unlink real)))
504 (case kind
505 ((:file)
506 (chatter-terse "adding ~a~%" real)
507 (synchronize-files id real executable
508 :direction :right))
509 ((:symlink)
510 (chatter-terse "linking ~a -> ~a~%" real target)
511 (honor-dry-run (real)
512 (ensure-directories-exist real)
513 (symlink target real))))
514 (push item rollback-remove-items))))))
515 (setf rollback-needed nil))
516 (when rollback-needed
517 (chatter-debug "Undoing directory structure changes.~%")
518 (dolist (item rollback-remove-items)
519 (let ((real (abstract-to-real-path (mapping-entry-path item))))
520 (chatter-terse "removing ~a~%" real)
521 (honor-dry-run (real)
522 (ensure-directories-gone real))))
523 (dolist (item rollback-restore-items)
524 (with-slots (kind path id target executable) item
525 (let ((real (abstract-to-real-path path)))
526 (chatter-terse "restoring ~a~%" real)
527 (case kind
528 ((:file)
529 (synchronize-files id real executable :direction :right))
530 ((:symlink)
531 (honor-dry-run (real)
532 (ensure-directories-exist real)
533 (symlink target real)))))))))
534 (mapping-write new-filemap *mcvs-map-local*))
535 t)
536
537 (defun mapping-removed-files (filemap)
538 (let ((to-be-removed ())
539 (f-hash (make-hash-table :test #'equal)))
540 (dolist (entry filemap)
541 (setf (gethash (mapping-entry-id entry) f-hash) entry))
542 (for-each-file-info (fi *mcvs-dir*)
543 (when (and (directory-p fi)
544 (path-equal (basename (file-name fi)) "CVS"))
545 (skip))
546 (let ((base (basename (file-name fi))))
547 (multiple-value-bind (suffix name) (suffix base)
548 (declare (ignore suffix))
549 (when (and (= (length name) 34)
550 (string= (subseq name 0 2) "F-")
551 (not (gethash (file-name fi) f-hash)))
552 (push (file-name fi) to-be-removed)))))
553 to-be-removed))
554
555 (defun displaced-path-read ()
556 (let ((*read-eval* nil))
557 (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
558 (read file)))))
559
560 (defun displaced-path-write (path)
561 (with-open-file (file *mcvs-displaced* :direction :output)
562 (prin1 path file)
563 (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5