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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.52: +4 -1 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

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

  ViewVC Help
Powered by ViewVC 1.1.5