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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (show annotations)
Mon Aug 5 19:19:58 2002 UTC (11 years, 8 months ago) by kaz
Branch: MAIN
CVS Tags: symlink-branch~branch-point
Branch point for: symlink-branch
Changes since 1.39: +10 -13 lines
Use getcwd to to implement mcvs-locate.

* code/unix-bindings/unix.lisp (getcwd): New call out,
invokes impl_getcwd.

* code/unix-bindings/impl.c (impl_getcwd): New function,
use getcwd() to obtain current working directory, resizing dynamic
buffer if necessary to get the entire path.

* code/clisp-unix.lisp (getcwd): New wrapper function.

* code/dirwalk.lisp (go-up): Function removed.

* code/mapping.lisp (mcvs-locate): Rewritten to obtain
path using getcwd, then try looking for MCVS directory
in successively shorter prefixes of that 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 (require "dirwalk")
6 (require "system")
7 (require "sync")
8 (require "chatter")
9 (require "restart")
10 (require "seqfuncs")
11 (provide "mapping")
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (defconstant *mcvs-dir* "MCVS")
15 (defconstant *mcvs-map-name* "MAP")
16 (defconstant *mcvs-map-local-name* "MAP-LOCAL")
17 (defconstant *mcvs-displaced-name* "DISPLACED"))
18
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
21 (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
27 (defun mcvs-locate ()
28 (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
38 (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 (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 (multiple-value-bind (moved-pairs added-items removed-items)
241 (intersection-difference
242 new-mapping old-mapping
243 :key #'first :test #'equal
244 :combine #'(lambda (new old)
245 (unless (string= (second new)
246 (second old))
247 (list old new)))
248 :squash-nil t)
249 (values added-items removed-items moved-pairs)))
250
251 (defun mapping-update (&key no-delete-removed)
252 #.(format nil
253 "Reads the Meta-CVS mapping files ~a and ~a, the local
254 mapping and repository mapping, respectively. It computes the difference
255 between them and then reorganizes the file structure of the sandbox as
256 necessary to make the mapping up to date. Then the local mapping file is
257 overwritten so it is identical to the repository one. This is necessary to
258 bring the local structure up to date after incorporating mapping changes
259 whether they came from the CVS repository, or from local operations."
260 *mcvs-map-local* *mcvs-map*)
261 (let ((old-filemap (mapping-read *mcvs-map-local*))
262 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
263 rollback-remove-items rollback-restore-items)
264 (restart-case
265 (multiple-value-bind (added-items removed-items moved-pairs)
266 (mapping-difference old-filemap new-filemap)
267 ;; First remove what has to be removed. This way when we
268 ;; do sanity checks, we won't complain about clobbering things
269 ;; that are slated to disappear.
270 (dolist (item removed-items)
271 (when (real-path-exists (second item))
272 (let ((real (abstract-to-real-path (second item))))
273 (chatter-terse "removing ~a~%" real)
274 (unless no-delete-removed
275 (restart-case
276 (ensure-directories-gone real)
277 (ignore () :report "Ignore file removal error."))
278 (push item rollback-restore-items)))))
279
280 (dolist (pair moved-pairs)
281 (let ((old-item (first pair)))
282 (when (real-path-exists (second old-item))
283 (ensure-directories-gone (abstract-to-real-path (second old-item)))
284 (push old-item rollback-restore-items))))
285
286 ;; Now check sanity of adds and moves, to verify they don't
287 ;; clobber any local files.
288 (let (clobber-add-items clobber-move-pairs)
289 (dolist (item added-items)
290 (when (real-path-exists (second item))
291 (let ((file-info (exists (abstract-to-real-path (second item)))))
292 (when (and file-info
293 (not (same-file-p file-info (stat (first item))))
294 (not (mapping-lookup old-filemap (second item))))
295 (push item clobber-add-items)))))
296
297 (dolist (item moved-pairs)
298 (destructuring-bind (old-item new-item) item
299 (declare (ignore old-item))
300 (when (real-path-exists (second new-item))
301 (let ((file-info (exists (abstract-to-real-path (second new-item)))))
302 (when (and file-info
303 (not (mapping-lookup old-filemap (second new-item))))
304
305 (push item clobber-move-pairs))))))
306
307 (when (or clobber-add-items clobber-move-pairs)
308 (block nil
309 (restart-bind
310 ((print-clobbers
311 #'(lambda ()
312 (dolist (item clobber-add-items)
313 (format t "add: ~a~%"
314 (abstract-to-real-path (second item))))
315 (dolist (pair clobber-move-pairs)
316 (format t "move ~a -> ~a~%"
317 (second (abstract-to-real-path (first pair)))
318 (second (abstract-to-real-path (second pair))))))
319 :report-function
320 #'(lambda (stream)
321 (write-string "Print list of adds or moves which want to overwrite."
322 stream)))
323 (do-clobber
324 #'(lambda ()
325 (return))
326 :report-function
327 #'(lambda (stream)
328 (write-string "Go ahead and overwrite the target files."
329 stream))))
330 (error "mcvs: some moves or adds want to overwrite local files or directories.")))))
331
332 ;; Sanity check passed, complete moves and adds.
333 (dolist (item moved-pairs)
334 (destructuring-bind (old-item new-item) item
335 (let ((real-old-exists (real-path-exists (second old-item)))
336 (real-new-exists (real-path-exists (second new-item))))
337 (let ((real-old (and real-old-exists
338 (abstract-to-real-path (second old-item))))
339 (real-new (and real-new-exists
340 (abstract-to-real-path (second new-item)))))
341 (cond
342 ((and real-old-exists real-new-exists)
343 (chatter-terse "moving ~a -> ~a~%" real-old real-new))
344 (real-new-exists
345 (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
346 (real-old-exists
347 (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
348
349 (when real-new-exists
350 (no-existence-error (unlink real-new))
351 (synchronize-files (first new-item) real-new))
352 (push new-item rollback-remove-items)))))
353
354 (dolist (item added-items)
355 (when (real-path-exists (second item))
356 (let ((real (abstract-to-real-path (second item))))
357 (can-restart-here ("Continue updating file structure.")
358 (chatter-terse "adding ~a~%" real)
359 (synchronize-files (first item) real)
360 (push item rollback-remove-items))))))
361 (continue ()
362 :report "Restore all restructuring done so far."
363 (chatter-debug "Restoring.~%")
364 (dolist (item rollback-remove-items)
365 (let ((real (abstract-to-real-path (second item))))
366 (chatter-terse "removing ~a~%" real)
367 (ensure-directories-gone real)))
368 (dolist (item rollback-restore-items)
369 (let ((real (abstract-to-real-path (second item))))
370 (chatter-terse "restoring ~a~%" real)
371 (synchronize-files (first item) real)))
372 (return-from mapping-update nil)))
373
374 (mapping-write new-filemap *mcvs-map-local*))
375 t)
376
377 (defun mapping-removed-files (filemap)
378 (let ((to-be-removed ())
379 (f-hash (make-hash-table :test #'equal)))
380 (dolist (entry filemap)
381 (setf (gethash (first entry) f-hash) entry))
382 (for-each-file-info (fi *mcvs-dir*)
383 (let ((base (basename (file-name fi))))
384 (multiple-value-bind (suffix name) (suffix base)
385 (declare (ignore suffix))
386 (when (and (= (length name) 34)
387 (string= (subseq name 0 2) "F-")
388 (not (gethash (file-name fi) f-hash)))
389 (push (file-name fi) to-be-removed)))))
390 to-be-removed))
391
392 (defun displaced-path-read ()
393 (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
394 (read file))))
395
396 (defun displaced-path-write (path)
397 (with-open-file (file *mcvs-displaced* :direction :output)
398 (prin1 path file)
399 (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5