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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36.2.1 - (show annotations)
Fri Jul 5 16:39:23 2002 UTC (11 years, 9 months ago) by kaz
Branch: partial-sandbox-branch
Changes since 1.36: +94 -49 lines
Start of experimental ``partial sandbox'' work.

* mapping.lisp (*mcvs-displaced-name*, *mcvs-displaced*): New
constants, hold name of administrative file MCVS/DISPLACED which stores
the displaced path prefix.
(*displaced-path-prefix*): New special variable, holds displaced
path prefix read from MCVS/DISPLACED.
(*displaced-path-length*): New special variable, holds length
of string stored in *displaced-path-prefix*.
(real-path-exists, abstract-to-real-path, real-to-abstract-path):
New functions for mapping between actual sandbox path, and
the abstract sandbox path stored in the mapping.
(in-sandbox-root-dir): Macro modified to read *mcvs-displaced*
administrative file, and set up the new special variables.
(mapping-synchronize): Only operate on files that are present
in the sandbox; i.e. that have real paths corresponding to their
abstract paths. Convert to the real path when calling lower
level file manipulation functions.
(mapping-update): Likewise, but this conversion is not complete.
(displaced-path-read, displaced-path-write): New functions for
reading and writing MCVS/DISPLACED.
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 (defconstant *mcvs-displaced-name* "DISPLACED"))
17
18 (eval-when (:compile-toplevel :load-toplevel :execute)
19 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
20 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*))
21 (defconstant *mcvs-displaced* #.(path-cat *mcvs-dir* *mcvs-displaced-name*)))
22
23 (defvar *displaced-path-prefix* nil)
24 (defvar *displaced-path-length* nil)
25
26 ;; TODO: use getcwd()
27 (defun mcvs-locate ()
28 "Search for Meta-CVS directory by looking in the current directory, and
29 if it is not found there, by changing directory up through successive
30 parent directories. Returns the path from the new current directory
31 down to the original one, or the value nil if not found."
32 (if (ignore-errors (stat *mcvs-dir*))
33 "."
34 (let ((came-from (go-up)))
35 (if came-from
36 (let ((locate (mcvs-locate)))
37 (if locate
38 (path-cat locate came-from)))))))
39
40 (defun real-path-exists (path)
41 (or (null *displaced-path-prefix*)
42 (and (>= (length path) *displaced-path-length*)
43 (string= path *displaced-path-prefix*
44 :start1 0 :end1 *displaced-path-length*))))
45
46 (defun abstract-to-real-path (path)
47 (if *displaced-path-length*
48 (substring 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 (declaim (inline abstract-to-real-path 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 (defun mapping-generate-name (suffix &key no-dir)
80 (let* ((suffix (if (or (null suffix)
81 (string= "" suffix))
82 ""
83 (format nil ".~a" suffix)))
84 (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))
85 (if no-dir
86 name
87 (path-cat *mcvs-dir* name))))
88
89 (defun mapping-extract-paths (filemap)
90 (mapcar #'second filemap))
91 (declaim (inline mapping-extract-paths))
92
93 (defun mapping-lookup (filemap path)
94 (find path filemap :test #'path-equal :key #'second))
95
96 (defun mapping-prefix-lookup (filemap prefix)
97 (if (path-equal *this-dir* prefix)
98 (first filemap)
99 (find prefix filemap :test #'path-prefix-equal :key #'second)))
100
101 (defun mapping-prefix-matches (filemap path)
102 (if (path-equal *this-dir* path)
103 filemap
104 (remove-if-not #'(lambda (entry)
105 (path-prefix-equal path (second entry))) filemap)))
106
107 (defun mapping-object-lookup (filemap object)
108 (find object filemap :test #'string= :key #'first))
109
110 (defun mapping-same-object-p (entry-one entry-two)
111 (string= (first entry-one) (first entry-two)))
112
113 (defun mapping-same-path-p (entry-one entry-two)
114 (path-equal (second entry-one) (second entry-two)))
115
116 (defun mapping-moved-p (entry-one entry-two)
117 (and (string= (first entry-one) (first entry-two))
118 (not (path-equal (second entry-one) (second entry-two)))))
119
120 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
121 "Returns a new filemap, in which the pathames in the list file-list are edited
122 by replacing the old-prefix with the new-prefix. If any path thus created
123 matches an existing map entry, that map entry is removed. The sorting order
124 of the map is not preserved."
125 (flet ((combine (prefix path)
126 (if (string= path "")
127 prefix
128 (canonicalize-path (path-cat prefix path)))))
129 (let* ((op-len (length old-prefix))
130 (delete-map (mapcan #'(lambda (entry)
131 (let ((path (second entry)))
132 (if (and (member path file-list
133 :test #'path-equal)
134 (path-prefix-equal old-prefix
135 path))
136 (list entry)))) filemap))
137 (replace-map (mapcan #'(lambda (entry)
138 (destructuring-bind (object path) entry
139 (list (list object
140 (combine new-prefix
141 (subseq path
142 op-len))))))
143 delete-map)))
144 (append
145 (set-difference
146 (set-difference filemap delete-map :test #'mapping-same-path-p)
147 replace-map :test #'mapping-same-path-p)
148 replace-map))))
149
150 (defun malformed-map ()
151 (error "mcvs: malformed map (merge conflicts?): correct and run mcvs update."))
152
153 (defun mapping-dupe-check (filemap)
154 "Signals an error condition if the filemap contains duplicate paths or
155 duplicate objects. Otherwise returns the filemap, sorted by path."
156 (dolist (entry filemap)
157 (when (or (not (consp entry))
158 (not (and (stringp (first entry))
159 (stringp (second entry)))))
160 (malformed-map)))
161
162 (let (dupes
163 (sorted-map (sort (copy-list filemap) #'string< :key #'first)))
164 (let ((iter (rest filemap)) (current-item (first (first filemap))))
165 (loop
166 (when (endp iter)
167 (return))
168 (if (string= (first (first iter)) current-item)
169 (push (first iter) dupes)
170 (setf current-item (first (first iter))))
171 (setf iter (rest iter))))
172
173 (setf sorted-map (sort sorted-map #'string< :key #'second))
174
175 (let ((iter (rest filemap)) (current-item (second (first filemap))))
176 (loop
177 (when (endp iter)
178 (return))
179 (if (path-equal (second (first iter)) current-item)
180 (push (first iter) dupes)
181 (setf current-item (second (first iter))))
182 (setf iter (rest iter))))
183
184 (when dupes
185 (dolist (dupe dupes)
186 (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second dupe)))
187 (error "mcvs: duplicates in map: correct and run mcvs update.")))
188 filemap)
189
190 (defun mapping-read (filename &key sanity-check)
191 (let (filemap)
192 (with-open-file (file filename :direction :input)
193 (setf filemap (read file nil :error))
194 (when (or (eq filemap :error)
195 (and (not (consp filemap)) (not (null filemap))))
196 (malformed-map)))
197 (if sanity-check
198 (mapping-dupe-check filemap)
199 filemap)))
200
201 (defun mapping-write (filemap filename &key sort-map)
202 (with-open-file (file filename :direction :output)
203 (let ((*print-right-margin* 1))
204 (prin1 (if sort-map
205 (sort (copy-list filemap) #'string< :key #'first)
206 filemap) file)
207 (terpri file))))
208
209 (defun mapping-synchronize ()
210 "Synchronizes the contents of files in the sandbox, and their corresponding
211 CVS files in the Meta-CVS directory. This must be done before any CVS operation
212 such as commit or update, so that the Meta-CVS files have the correct contents
213 reflecting local changes. It must also be done after any CVS update operation,
214 to ensure that the newly incorporated changes are propagated to the sandbox"
215 (let ((filemap (mapping-read *mcvs-map-local*)))
216 (dolist (item filemap)
217 (can-restart-here ("Continue synchronizing files.")
218 (destructuring-bind (left right) item
219 (when (real-path-exists right)
220 (setf right (abstract-to-real-path right))
221 (case (synchronize-files left right)
222 ((:left)
223 (chatter-info "sync ~a -> ~a~%" left right))
224 ((:right)
225 (chatter-info "sync ~a <- ~a~%" left right))
226 ((:same))
227 ((:dir)
228 (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
229 left right))
230 ((nil)
231 (error "mcvs-sync: neither ~a nor ~a exists."
232 left right)))))))))
233
234 (defun mapping-difference (old-mapping new-mapping)
235 "Compute the difference between two mappings. Returns three values:
236 - a mapping containing only elements added by new-mapping;
237 - a mapping containing only elements removed by new-mapping; and
238 - a list of moved items, which contains pairs of elements from both, whose
239 object name matches, but path differs."
240 (let (added-items removed-items moved-pairs)
241 (setf old-mapping (sort (copy-list old-mapping) #'string< :key #'first))
242 (setf new-mapping (sort (copy-list new-mapping) #'string< :key #'first))
243
244 (loop
245 (let* ((old-item (first old-mapping))
246 (new-item (first new-mapping)))
247 (cond
248 ((and (endp old-item) (endp new-item)) (return))
249 ((string< (first old-item) (first new-item))
250 (pop old-mapping)
251 (push old-item removed-items))
252 ((string= (first old-item) (first new-item))
253 (pop old-mapping)
254 (pop new-mapping)
255 (when (not (path-equal (second old-item) (second new-item)))
256 (push (list old-item new-item) moved-pairs)))
257 (t
258 (pop new-mapping)
259 (push new-item added-items)))))
260 (values added-items removed-items moved-pairs)))
261
262 (defun mapping-update (&key no-delete-removed)
263 #.(format nil
264 "Reads the Meta-CVS mapping files ~a and ~a, the local
265 mapping and repository mapping, respectively. It computes the difference
266 between them and then reorganizes the file structure of the sandbox as
267 necessary to make the mapping up to date. Then the local mapping file is
268 overwritten so it is identical to the repository one. This is necessary to
269 bring the local structure up to date after incorporating mapping changes
270 whether they came from the CVS repository, or from local operations."
271 *mcvs-map-local* *mcvs-map*)
272 (let ((old-filemap (mapping-read *mcvs-map-local*))
273 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
274 rollback-remove-items rollback-restore-items)
275 (restart-case
276 (multiple-value-bind (added-items removed-items moved-pairs)
277 (mapping-difference old-filemap new-filemap)
278 ;; First remove what has to be removed. This way when we
279 ;; do sanity checks, we won't complain about clobbering things
280 ;; that are slated to disappear.
281 (unless no-delete-removed
282 (dolist (item removed-items)
283 (let ((real (abstract-to-real-path (second item))))
284 (chatter-terse "removing ~a~%" real)
285 (restart-case
286 (ensure-directories-gone real)
287 (ignore () :report "Ignore file removal error."))
288 (push item rollback-restore-items))))
289
290 (dolist (pair moved-pairs)
291 (let ((old-item (first pair)))
292 (ensure-directories-gone (abstract-to-real-path (second old-item)))
293 (push old-item rollback-restore-items)))
294
295 ;; Now check sanity of adds and moves, to verify they don't
296 ;; clobber any local files.
297 (let (clobber-add-items clobber-move-pairs)
298 (dolist (item added-items)
299 (let ((file-info (exists (abstract-to-real-path (second item)))))
300 (when (and file-info
301 (not (same-file-p file-info (stat (first item))))
302 (not (mapping-lookup old-filemap (second item))))
303 (push item clobber-add-items))))
304
305 (dolist (item moved-pairs)
306 (destructuring-bind (old-item new-item) item
307 (declare (ignore old-item))
308 (let ((file-info (exists (abstract-to-real-path (second new-item)))))
309 (when (and file-info
310 (not (mapping-lookup old-filemap (second new-item))))
311
312 (push item clobber-move-pairs)))))
313
314 (when (or clobber-add-items clobber-move-pairs)
315 (block nil
316 (restart-bind
317 ((print-clobbers
318 #'(lambda ()
319 (dolist (item clobber-add-items)
320 (format t "add: ~a~%"
321 (abstract-to-real-path (second item))))
322 (dolist (pair clobber-move-pairs)
323 (format t "move ~a -> ~a~%"
324 (second (abstract-to-real-path (first pair)))
325 (second (abstract-to-real-path (second pair))))))
326 :report-function
327 #'(lambda (stream)
328 (write-string "Print list of adds or moves which want to overwrite."
329 stream)))
330 (do-clobber
331 #'(lambda ()
332 (return))
333 :report-function
334 #'(lambda (stream)
335 (write-string "Go ahead and overwrite the target files."
336 stream))))
337 (error "mcvs: some moves or adds want to overwrite local files or directories.")))))
338
339 ;; Sanity check passed, complete moves and adds.
340 (dolist (item moved-pairs)
341 (destructuring-bind (old-item new-item) item
342 (let ((real-old (abstract-to-real-path (second old-item)))
343 (real-new (abstract-to-real-path (second new-item))))
344 (chatter-terse "moving ~a -> ~a~%" real-old real-new)
345 (no-existence-error (unlink real-new))
346 (synchronize-files (first new-item) real-new)
347 (push new-item rollback-remove-items))))
348
349 (dolist (item added-items)
350 (when (real-path-exists (second item))
351 (let ((real (abstract-to-real-path (second item))))
352 (can-restart-here ("Continue updating file structure.")
353 (chatter-terse "adding ~a~%" real)
354 (synchronize-files (first item) real)
355 (push item rollback-remove-items))))))
356 (continue ()
357 :report "Restore all restructuring done so far."
358 (chatter-debug "Restoring.~%")
359 (dolist (item rollback-remove-items)
360 (let ((real (abstract-to-real-path (second item))))
361 (chatter-terse "removing ~a~%" real)
362 (ensure-directories-gone real)))
363 (dolist (item rollback-restore-items)
364 (let ((real (abstract-to-real-path (second item))))
365 (chatter-terse "restoring ~a~%" real)
366 (synchronize-files (first item) real)))
367 (return-from mapping-update nil)))
368
369 (mapping-write new-filemap *mcvs-map-local*))
370 t)
371
372 (defun mapping-removed-files (filemap)
373 (let ((to-be-removed ())
374 (f-hash (make-hash-table :test #'equal)))
375 (dolist (entry filemap)
376 (setf (gethash (first entry) f-hash) entry))
377 (for-each-file-info (fi *mcvs-dir*)
378 (let ((base (basename (file-name fi))))
379 (multiple-value-bind (suffix name) (suffix base)
380 (declare (ignore suffix))
381 (when (and (= (length name) 34)
382 (string= (subseq name 0 2) "F-")
383 (not (gethash (file-name fi) f-hash)))
384 (push (file-name fi) to-be-removed)))))
385 to-be-removed))
386
387 (defun displaced-path-read ()
388 (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
389 (read file))))
390
391 (defun displaced-path-write (path)
392 (with-open-file (file *mcvs-displaced* :direction :output)
393 (prin1 path file)
394 (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5