/[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 - (show annotations)
Sun Oct 6 08:17:28 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97
Branch point for: mcvs-1-0-branch
Changes since 1.48: +3 -2 lines
* code/remap.lisp (mcvs-remap): Preserve property lists of
mapping entries, and pick up changes in execute permission.

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

  ViewVC Help
Powered by ViewVC 1.1.5