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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Tue Mar 12 23:34:25 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-8
Changes since 1.27: +1 -1 lines
Minor adjustment to chatter level.
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 (provide "mapping")
11
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (defconstant *mcvs-dir* #.(path-cat "MCVS"))
14 (defconstant *mcvs-map-name* "MAP")
15 (defconstant *mcvs-map-local-name* "MAP-LOCAL"))
16
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
19 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*)))
20
21 ;; TODO: use getcwd()
22 (defun mcvs-locate ()
23 "Search for Meta-CVS directory by looking in the current directory, and
24 if it is not found there, by changing directory up through successive
25 parent directories. Returns the path from the new current directory
26 down to the original one, or the value nil if not found."
27 (if (ignore-errors (stat *mcvs-dir*))
28 "."
29 (let ((came-from (go-up)))
30 (if came-from
31 (let ((locate (mcvs-locate)))
32 (if locate
33 (path-cat locate came-from)))))))
34
35 (defmacro in-sandbox-root-dir (&body forms)
36 (let ((downpath-sym (gensym "DOWNPATH-")))
37 `(current-dir-restore
38 (let ((,downpath-sym (mcvs-locate)))
39 (when (not ,downpath-sym)
40 (error "mcvs: could not locate ~a directory." *mcvs-dir*))
41 (flet ((sandbox-translate-path (in-path)
42 (multiple-value-bind (out-path out-of-bounds)
43 (canonicalize-path
44 (path-cat ,downpath-sym in-path))
45 (if out-of-bounds
46 (error "mcvs: path ~a is not within sandbox." out-path)
47 out-path))))
48 (symbol-macrolet ((sandbox-down-path ',downpath-sym))
49 ,@forms))))))
50
51 (defun mapping-generate-name (suffix &key no-dir)
52 (let* ((suffix (if (or (null suffix)
53 (string= "" suffix))
54 ""
55 (format nil ".~a" suffix)))
56 (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))
57 (if no-dir
58 name
59 (path-cat *mcvs-dir* name))))
60
61 (defun mapping-extract-paths (filemap)
62 (mapcar #'second filemap))
63 (declaim (inline mapping-extract-paths))
64
65 (defun mapping-lookup (filemap path)
66 (find path filemap :test #'path-equal :key #'second))
67
68 (defun mapping-prefix-lookup (filemap prefix)
69 (if (path-equal *this-dir* prefix)
70 (first filemap)
71 (find prefix filemap :test #'path-prefix-equal :key #'second)))
72
73 (defun mapping-prefix-matches (filemap path)
74 (if (path-equal *this-dir* path)
75 filemap
76 (remove-if-not #'(lambda (entry)
77 (path-prefix-equal path (second entry))) filemap)))
78
79 (defun mapping-object-lookup (filemap object)
80 (find object filemap :test #'string= :key #'first))
81
82 (defun mapping-same-object-p (entry-one entry-two)
83 (string= (first entry-one) (first entry-two)))
84
85 (defun mapping-same-path-p (entry-one entry-two)
86 (path-equal (second entry-one) (second entry-two)))
87
88 (defun mapping-moved-p (entry-one entry-two)
89 (and (string= (first entry-one) (first entry-two))
90 (not (path-equal (second entry-one) (second entry-two)))))
91
92 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
93 "Returns a new filemap, in which the pathames in the list file-list are edited
94 by replacing the old-prefix with the new-prefix. If any path thus created
95 matches an existing map entry, that map entry is removed. The sorting order
96 of the map is not preserved."
97 (flet ((combine (prefix path)
98 (if (string= path "")
99 prefix
100 (canonicalize-path (path-cat prefix path)))))
101 (let* ((op-len (length old-prefix))
102 (delete-map (mapcan #'(lambda (entry)
103 (let ((path (second entry)))
104 (if (and (member path file-list
105 :test #'path-equal)
106 (path-prefix-equal old-prefix
107 path))
108 (list entry)))) filemap))
109 (replace-map (mapcan #'(lambda (entry)
110 (destructuring-bind (object path) entry
111 (list (list object
112 (combine new-prefix
113 (subseq path
114 op-len))))))
115 delete-map)))
116 (append
117 (set-difference
118 (set-difference filemap delete-map :test #'mapping-same-path-p)
119 replace-map :test #'mapping-same-path-p)
120 replace-map))))
121
122 (defun mapping-dupe-check (filemap)
123 "Signals an error condition if the filemap contains duplicate paths or
124 duplicate objects. Otherwise returns the filemap, sorted by path."
125 (let (dupes)
126 (sort filemap #'string-lessp :key #'first)
127
128 (let ((iter (rest filemap)) (current-item (first (first filemap))))
129 (loop
130 (when (endp iter)
131 (return))
132 (if (string= (first (first iter)) current-item)
133 (push (first iter) dupes)
134 (setf current-item (first (first iter))))
135 (setf iter (rest iter))))
136
137 (sort filemap #'string-lessp :key #'second)
138
139 (let ((iter (rest filemap)) (current-item (second (first filemap))))
140 (loop
141 (when (endp iter)
142 (return))
143 (if (path-equal (second (first iter)) current-item)
144 (push (first iter) dupes)
145 (setf current-item (second (first iter))))
146 (setf iter (rest iter))))
147
148 (when dupes
149 (dolist (dupe dupes)
150 (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second dupe)))
151 (error "mcvs: duplicates in map: correct and run mcvs update.")))
152 filemap)
153
154 (defun mapping-read (filename &key sanity-check)
155 (let (filemap)
156 (with-open-file (file filename :direction :input)
157 (setf filemap (read file)))
158 (if sanity-check
159 (mapping-dupe-check filemap)
160 filemap)))
161
162 (defun mapping-write (filemap filename &key sort-map)
163 (with-open-file (file filename :direction :output)
164 (let ((*print-right-margin* 1))
165 (prin1 (if sort-map
166 (sort filemap #'string-lessp :key #'first)
167 filemap) file)
168 (terpri file))))
169
170 (defun mapping-synchronize ()
171 "Synchronizes the contents of files in the sandbox, and their corresponding
172 CVS files in the Meta-CVS directory. This must be done before any CVS operation
173 such as commit or update, so that the Meta-CVS files have the correct contents
174 reflecting local changes. It must also be done after any CVS update operation,
175 to ensure that the newly incorporated changes are propagated to the sandbox"
176 (let ((filemap (mapping-read *mcvs-map-local*)))
177 (dolist (item filemap)
178 (can-restart-here ("Continue synchronizing files.")
179 (destructuring-bind (left right) item
180 (case (synchronize-files left right)
181 ((:left)
182 (chatter-info "sync ~a -> ~a~%" left right))
183 ((:right)
184 (chatter-info "sync ~a <- ~a~%" left right))
185 ((:same))
186 ((:dir)
187 (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
188 left right))
189 ((nil)
190 (error "mcvs-sync: neither ~a nor ~a exists."
191 left right))))))))
192
193 (defun mapping-difference (old-mapping new-mapping)
194 "Compute the difference between two mappings. Returns three values:
195 - a mapping containing only elements added by new-mapping;
196 - a mapping containing only elements removed by new-mapping; and
197 - a list of moved items, which contains pairs of elements from both, whose
198 object name matches, but path differs."
199 (let (added-items removed-items moved-pairs)
200 (sort old-mapping #'string-lessp :key #'first)
201 (sort new-mapping #'string-lessp :key #'first)
202
203 (loop
204 (let* ((old-item (first old-mapping))
205 (new-item (first new-mapping)))
206 (cond
207 ((and (endp old-item) (endp new-item)) (return))
208 ((string-lessp (first old-item) (first new-item))
209 (pop old-mapping)
210 (push old-item removed-items))
211 ((string= (first old-item) (first new-item))
212 (pop old-mapping)
213 (pop new-mapping)
214 (when (not (path-equal (second old-item) (second new-item)))
215 (push (list old-item new-item) moved-pairs)))
216 (t
217 (pop new-mapping)
218 (push new-item added-items)))))
219 (values added-items removed-items moved-pairs)))
220
221 (defun mapping-update ()
222 #.(format nil
223 "Reads the Meta-CVS mapping files ~a and ~a, the local
224 mapping and repository mapping, respectively. It computes the difference
225 between them and then reorganizes the file structure of the sandbox as
226 necessary to make the mapping up to date. Then the local mapping file is
227 overwritten so it is identical to the repository one. This is necessary to
228 bring the local structure up to date after incorporating mapping changes
229 whether they came from the CVS repository, or from local operations."
230 *mcvs-map-local* *mcvs-map*)
231 (let ((old-filemap (mapping-read *mcvs-map-local*))
232 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
233 rollback-remove-items rollback-restore-items)
234 (restart-case
235 (multiple-value-bind (added-items removed-items moved-pairs)
236 (mapping-difference old-filemap new-filemap)
237 ;; First remove what has to be removed. This way when we
238 ;; do sanity checks, we won't complain about clobbering things
239 ;; that are slated to disappear.
240 (dolist (item removed-items)
241 (chatter-terse "removing ~a~%" (second item))
242 (ensure-directories-gone (second item))
243 (push item rollback-restore-items))
244
245 (dolist (pair moved-pairs)
246 (let ((old-item (first pair)))
247 (ensure-directories-gone (second old-item))
248 (push old-item rollback-restore-items)))
249
250 ;; Now check sanity of adds and moves, to verify they don't
251 ;; clobber any local files.
252 (let (clobber-add-items clobber-move-pairs)
253 (dolist (item added-items)
254 (let ((file-info (exists (second item))))
255 (when (and file-info
256 (not (same-file-p file-info (stat (first item))))
257 (not (mapping-lookup old-filemap (second item))))
258 (push item clobber-add-items))))
259
260 (dolist (item moved-pairs)
261 (destructuring-bind (old-item new-item) item
262 (declare (ignore old-item))
263 (let ((file-info (exists (second new-item))))
264 (when (and file-info
265 (not (mapping-lookup old-filemap (second new-item))))
266
267 (push item clobber-move-pairs)))))
268
269 (when (or clobber-add-items clobber-move-pairs)
270 (block nil
271 (restart-bind
272 ((print-clobbers
273 #'(lambda ()
274 (dolist (item clobber-add-items)
275 (format t "add: ~a~%" (second item)))
276 (dolist (pair clobber-move-pairs)
277 (format t "move ~a -> ~a~%" (second (first pair))
278 (second (second pair)))))
279 :report-function
280 #'(lambda (stream)
281 (write-string "Print list of adds or moves which want to overwrite."
282 stream)))
283 (do-clobber
284 #'(lambda ()
285 (return))
286 :report-function
287 #'(lambda (stream)
288 (write-string "Go ahead and overwrite the target files."
289 stream))))
290 (error "mcvs: some moves or adds want to overwrite local files or directories.")))))
291
292 ;; Sanity check passed, complete moves and adds.
293 (dolist (item moved-pairs)
294 (destructuring-bind (old-item new-item) item
295 (chatter-terse "moving ~a -> ~a~%" (second old-item)
296 (second new-item))
297 (no-existence-error (unlink (second new-item)))
298 (synchronize-files (first new-item) (second new-item))
299 (push new-item rollback-remove-items)))
300
301 (dolist (item added-items)
302 (can-restart-here ("Continue updating file structure.")
303 (chatter-terse "adding ~a~%" (second item))
304 (synchronize-files (first item) (second item))
305 (push item rollback-remove-items))))
306 (continue ()
307 :report "Restore all restructuring done so far."
308 (chatter-debug "Restoring.~%")
309 (dolist (item rollback-remove-items)
310 (chatter-terse "removing ~a~%" (second item))
311 (ensure-directories-gone (second item)))
312 (dolist (item rollback-restore-items)
313 (chatter-terse "restoring ~a~%" (second item))
314 (synchronize-files (first item) (second item)))
315 (return-from mapping-update nil)))
316
317 (mapping-write new-filemap *mcvs-map-local*))
318 t)

  ViewVC Help
Powered by ViewVC 1.1.5