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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (show annotations)
Fri Sep 6 04:09:46 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-95, mcvs-0-96
Changes since 1.44: +4 -4 lines
New prop command for manipulating property lists.

* code/mcvs-main.lisp (*prop-options*): New constant.
(*mcvs-command-table*): New entry.
(*usage*): Update.

* code/mapping.lisp (mapping-entry-parse-plist): Just unconditionally
set execute slot based on :exec property.

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

  ViewVC Help
Powered by ViewVC 1.1.5