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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5