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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40.2.4 - (show annotations)
Tue Aug 27 03:19:05 2002 UTC (11 years, 7 months ago) by kaz
Branch: symlink-branch
CVS Tags: symlink-branch~merged-to-HEAD-0
Changes since 1.40.2.3: +12 -0 lines
* code/remap.lisp (mcvs-remap): Use new mapping entry structure.
For now, preserve symbolic link entries as they are, processing only
files.

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

  ViewVC Help
Powered by ViewVC 1.1.5