/[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.3 - (show annotations)
Sun Aug 25 19:31:51 2002 UTC (11 years, 7 months ago) by kaz
Branch: symlink-branch
Changes since 1.40.2.2: +13 -5 lines
* code/clisp-unix.lisp (initialize-instance link-error): Make
error message less confusing about which path refers to the
object being created, and which path refers to what it links to.

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

  ViewVC Help
Powered by ViewVC 1.1.5