/[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.11 - (show annotations)
Sun Apr 13 06:22:43 2003 UTC (11 years ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.49.2.10: +9 -6 lines
Revamped the synchronization logic. Synchronization now happens
in a specific direction.  For example, if we are doing a diff,
we just need to push changes from the tree to the MCVS directory,
not the other way around. Or: before an update or commit, we push from
the tree to MCVS, then after the update, in the other direction.

* code/update.lisp (mcvs-update): The before update is done
in the :left direction only, and the after update in the :right.

* code/move.lisp (mcvs-move): The just-in-case sync is done
in the :left direction only.

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

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

* code/add.lisp (mcvs-add): Get rid of mapping-synchronize call;
it's completely unnecessary, since the new files are not even
in the MAP-LOCAL, and the add logic explicitly links them into
the MCVS directory.

* code/generic.lisp (mcvs-generic): New keyword parameter,
need-sync-before. Before-synchronization done in :left direction,
after-synchronization in :right direction. Before-synchronization
is now not done by default; need-sync-before must be specified.
(mcvs-commit-wrapper): Specify before and after sync.
(mcvs-diff-wrapper, mcvs-status-wrapper,
mcvs-edit-wrapper): Explicitly specify before sync.
(mcvs-tag-wrapper, mcvs-annotate-wrapper): Implicitly specify no sync.
(mcvs-unedit-wrapper): Add before sync.

* code/sync.lisp (synchronize-files):  New key parameter :direction,
values can be :left, :right or :either. Default is :either.
If the value is :left or :right, then a sync is done only in that
direction, otherwise the value :no-sync is returned.
Behavior change: if the left file is missing (F- file in MCVS
directory) it is not re-created, but rather :no-sync is returned.
Also, if both files exist, have the same timestamp, and are
distinct objects, if the direction is :left or :right, then
the appropriate restart is automatically chosen. So this will
do the right thing on filesystems where link() is performed by
copying, without bothering the user with the error.

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