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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.66 - (show annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.65: +18 -18 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5