/[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.5 - (show annotations)
Mon Nov 4 02:07:35 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-0-99
Changes since 1.49.2.4: +24 -15 lines
More support for -n option.

* code/mcvs-main.lisp (*usage*): Document -n option.

* code/move.lisp (mcvs-move-wrapper): Remove bogus error check
for presence of global options.

* code/options.lisp (honor-dry-run): New macro for conditionally
not executing some forms if it's a dry run, and logging some
debugging information.

* code/sync.lisp (synchronize-files): Honor dry run.

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

  ViewVC Help
Powered by ViewVC 1.1.5