/[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.2 - (hide annotations)
Fri Jul 5 17:37:10 2002 UTC (11 years, 9 months ago) by kaz
Branch: partial-sandbox-branch
Changes since 1.36.2.1: +7 -5 lines
* mapping.lisp (real-path-exists): Use path-prefix-equal, because
that handles all the tricky cases.
(abstract-to-real-path): Handle the case when abstract path
is the same as the path prefix, with or without the trailing
slash.
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     (provide "mapping")
11    
12 kaz 1.6 (eval-when (:compile-toplevel :load-toplevel :execute)
13 kaz 1.20 (defconstant *mcvs-dir* #.(path-cat "MCVS"))
14     (defconstant *mcvs-map-name* "MAP")
15 kaz 1.36.2.1 (defconstant *mcvs-map-local-name* "MAP-LOCAL")
16     (defconstant *mcvs-displaced-name* "DISPLACED"))
17 kaz 1.6
18     (eval-when (:compile-toplevel :load-toplevel :execute)
19 kaz 1.20 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
20 kaz 1.36.2.1 (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 kaz 1.1
26     ;; TODO: use getcwd()
27     (defun mcvs-locate ()
28 kaz 1.10 "Search for Meta-CVS directory by looking in the current directory, and
29 kaz 1.1 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 kaz 1.36.2.1 (defun real-path-exists (path)
41     (or (null *displaced-path-prefix*)
42 kaz 1.36.2.2 (path-prefix-equal *displaced-path-prefix* path)))
43 kaz 1.36.2.1
44     (defun abstract-to-real-path (path)
45     (if *displaced-path-length*
46 kaz 1.36.2.2 (if (or (= (length path) (1- *displaced-path-length*))
47     (= (length path) *displaced-path-length*))
48     *this-dir*
49     (substring path *displaced-path-length*))
50 kaz 1.36.2.1 path))
51    
52     (defun real-to-abstract-path (path)
53     (if *displaced-path-prefix*
54     (concatenate 'string *displaced-path-prefix* path)
55     path))
56    
57 kaz 1.36.2.2 (declaim (inline real-path-exists abstract-to-real-path
58     real-to-abstract-path))
59 kaz 1.36.2.1
60 kaz 1.4 (defmacro in-sandbox-root-dir (&body forms)
61     (let ((downpath-sym (gensym "DOWNPATH-")))
62     `(current-dir-restore
63     (let ((,downpath-sym (mcvs-locate)))
64     (when (not ,downpath-sym)
65     (error "mcvs: could not locate ~a directory." *mcvs-dir*))
66 kaz 1.36.2.1 (let* ((*displaced-path-prefix* (displaced-path-read))
67     (*displaced-path-length* (if *displaced-path-prefix*
68     (length *displaced-path-prefix*))))
69     (flet ((sandbox-translate-path (in-path)
70     (multiple-value-bind (out-path out-of-bounds)
71     (canonicalize-path
72     (if (path-absolute-p in-path)
73     (path-cat *this-dir* in-path)
74     (path-cat ,downpath-sym in-path)))
75     (if out-of-bounds
76     (error "mcvs: path ~a is not within sandbox." out-path)
77     out-path))))
78     (symbol-macrolet ((sandbox-down-path ,downpath-sym))
79     ,@forms)))))))
80 kaz 1.4
81 kaz 1.25 (defun mapping-generate-name (suffix &key no-dir)
82     (let* ((suffix (if (or (null suffix)
83     (string= "" suffix))
84     ""
85     (format nil ".~a" suffix)))
86     (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))
87 kaz 1.20 (if no-dir
88     name
89     (path-cat *mcvs-dir* name))))
90 kaz 1.1
91 kaz 1.12 (defun mapping-extract-paths (filemap)
92 kaz 1.4 (mapcar #'second filemap))
93 kaz 1.12 (declaim (inline mapping-extract-paths))
94 kaz 1.4
95 kaz 1.12 (defun mapping-lookup (filemap path)
96 kaz 1.6 (find path filemap :test #'path-equal :key #'second))
97    
98 kaz 1.12 (defun mapping-prefix-lookup (filemap prefix)
99 kaz 1.6 (if (path-equal *this-dir* prefix)
100     (first filemap)
101     (find prefix filemap :test #'path-prefix-equal :key #'second)))
102 kaz 1.1
103 kaz 1.12 (defun mapping-prefix-matches (filemap path)
104 kaz 1.2 (if (path-equal *this-dir* path)
105     filemap
106     (remove-if-not #'(lambda (entry)
107     (path-prefix-equal path (second entry))) filemap)))
108    
109 kaz 1.12 (defun mapping-object-lookup (filemap object)
110 kaz 1.6 (find object filemap :test #'string= :key #'first))
111 kaz 1.1
112 kaz 1.12 (defun mapping-same-object-p (entry-one entry-two)
113 kaz 1.1 (string= (first entry-one) (first entry-two)))
114    
115 kaz 1.12 (defun mapping-same-path-p (entry-one entry-two)
116 kaz 1.1 (path-equal (second entry-one) (second entry-two)))
117    
118 kaz 1.12 (defun mapping-moved-p (entry-one entry-two)
119 kaz 1.1 (and (string= (first entry-one) (first entry-two))
120     (not (path-equal (second entry-one) (second entry-two)))))
121    
122 kaz 1.12 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
123 kaz 1.3 "Returns a new filemap, in which the pathames in the list file-list are edited
124     by replacing the old-prefix with the new-prefix. If any path thus created
125     matches an existing map entry, that map entry is removed. The sorting order
126     of the map is not preserved."
127 kaz 1.4 (flet ((combine (prefix path)
128     (if (string= path "")
129     prefix
130     (canonicalize-path (path-cat prefix path)))))
131     (let* ((op-len (length old-prefix))
132     (delete-map (mapcan #'(lambda (entry)
133 kaz 1.8 (let ((path (second entry)))
134 kaz 1.4 (if (and (member path file-list
135     :test #'path-equal)
136     (path-prefix-equal old-prefix
137     path))
138     (list entry)))) filemap))
139     (replace-map (mapcan #'(lambda (entry)
140     (destructuring-bind (object path) entry
141     (list (list object
142     (combine new-prefix
143     (subseq path
144     op-len))))))
145     delete-map)))
146 kaz 1.3 (append
147     (set-difference
148 kaz 1.12 (set-difference filemap delete-map :test #'mapping-same-path-p)
149     replace-map :test #'mapping-same-path-p)
150 kaz 1.4 replace-map))))
151 kaz 1.3
152 kaz 1.29 (defun malformed-map ()
153     (error "mcvs: malformed map (merge conflicts?): correct and run mcvs update."))
154    
155 kaz 1.13 (defun mapping-dupe-check (filemap)
156     "Signals an error condition if the filemap contains duplicate paths or
157 kaz 1.17 duplicate objects. Otherwise returns the filemap, sorted by path."
158 kaz 1.29 (dolist (entry filemap)
159     (when (or (not (consp entry))
160     (not (and (stringp (first entry))
161     (stringp (second entry)))))
162     (malformed-map)))
163    
164 kaz 1.31 (let (dupes
165 kaz 1.34 (sorted-map (sort (copy-list filemap) #'string< :key #'first)))
166 kaz 1.17 (let ((iter (rest filemap)) (current-item (first (first filemap))))
167     (loop
168     (when (endp iter)
169     (return))
170     (if (string= (first (first iter)) current-item)
171     (push (first iter) dupes)
172     (setf current-item (first (first iter))))
173     (setf iter (rest iter))))
174    
175 kaz 1.34 (setf sorted-map (sort sorted-map #'string< :key #'second))
176 kaz 1.17
177     (let ((iter (rest filemap)) (current-item (second (first filemap))))
178     (loop
179     (when (endp iter)
180     (return))
181     (if (path-equal (second (first iter)) current-item)
182     (push (first iter) dupes)
183     (setf current-item (second (first iter))))
184     (setf iter (rest iter))))
185    
186 kaz 1.13 (when dupes
187     (dolist (dupe dupes)
188 kaz 1.26 (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second 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.11 (defun mapping-read (filename &key sanity-check)
193     (let (filemap)
194     (with-open-file (file filename :direction :input)
195 kaz 1.29 (setf filemap (read file nil :error))
196     (when (or (eq filemap :error)
197     (and (not (consp filemap)) (not (null filemap))))
198     (malformed-map)))
199 kaz 1.11 (if sanity-check
200 kaz 1.14 (mapping-dupe-check filemap)
201 kaz 1.11 filemap)))
202    
203     (defun mapping-write (filemap filename &key sort-map)
204     (with-open-file (file filename :direction :output)
205     (let ((*print-right-margin* 1))
206 kaz 1.18 (prin1 (if sort-map
207 kaz 1.34 (sort (copy-list filemap) #'string< :key #'first)
208 kaz 1.18 filemap) file)
209 kaz 1.11 (terpri file))))
210    
211 kaz 1.1 (defun mapping-synchronize ()
212     "Synchronizes the contents of files in the sandbox, and their corresponding
213 kaz 1.10 CVS files in the Meta-CVS directory. This must be done before any CVS operation
214     such as commit or update, so that the Meta-CVS files have the correct contents
215 kaz 1.1 reflecting local changes. It must also be done after any CVS update operation,
216     to ensure that the newly incorporated changes are propagated to the sandbox"
217 kaz 1.11 (let ((filemap (mapping-read *mcvs-map-local*)))
218 kaz 1.1 (dolist (item filemap)
219     (can-restart-here ("Continue synchronizing files.")
220     (destructuring-bind (left right) item
221 kaz 1.36.2.1 (when (real-path-exists right)
222     (setf right (abstract-to-real-path right))
223     (case (synchronize-files left right)
224     ((:left)
225     (chatter-info "sync ~a -> ~a~%" left right))
226     ((:right)
227     (chatter-info "sync ~a <- ~a~%" left right))
228     ((:same))
229     ((:dir)
230     (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
231     left right))
232     ((nil)
233     (error "mcvs-sync: neither ~a nor ~a exists."
234     left right)))))))))
235 kaz 1.1
236 kaz 1.17 (defun mapping-difference (old-mapping new-mapping)
237     "Compute the difference between two mappings. Returns three values:
238 kaz 1.22 - a mapping containing only elements added by new-mapping;
239     - a mapping containing only elements removed by new-mapping; and
240     - a list of moved items, which contains pairs of elements from both, whose
241     object name matches, but path differs."
242 kaz 1.17 (let (added-items removed-items moved-pairs)
243 kaz 1.34 (setf old-mapping (sort (copy-list old-mapping) #'string< :key #'first))
244     (setf new-mapping (sort (copy-list new-mapping) #'string< :key #'first))
245 kaz 1.17
246     (loop
247     (let* ((old-item (first old-mapping))
248     (new-item (first new-mapping)))
249     (cond
250     ((and (endp old-item) (endp new-item)) (return))
251 kaz 1.34 ((string< (first old-item) (first new-item))
252 kaz 1.17 (pop old-mapping)
253     (push old-item removed-items))
254     ((string= (first old-item) (first new-item))
255     (pop old-mapping)
256     (pop new-mapping)
257     (when (not (path-equal (second old-item) (second new-item)))
258     (push (list old-item new-item) moved-pairs)))
259     (t
260     (pop new-mapping)
261     (push new-item added-items)))))
262     (values added-items removed-items moved-pairs)))
263    
264 kaz 1.35 (defun mapping-update (&key no-delete-removed)
265 kaz 1.1 #.(format nil
266 kaz 1.10 "Reads the Meta-CVS mapping files ~a and ~a, the local
267 kaz 1.1 mapping and repository mapping, respectively. It computes the difference
268     between them and then reorganizes the file structure of the sandbox as
269     necessary to make the mapping up to date. Then the local mapping file is
270     overwritten so it is identical to the repository one. This is necessary to
271 kaz 1.19 bring the local structure up to date after incorporating mapping changes
272     whether they came from the CVS repository, or from local operations."
273 kaz 1.1 *mcvs-map-local* *mcvs-map*)
274 kaz 1.11 (let ((old-filemap (mapping-read *mcvs-map-local*))
275 kaz 1.22 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
276     rollback-remove-items rollback-restore-items)
277     (restart-case
278     (multiple-value-bind (added-items removed-items moved-pairs)
279     (mapping-difference old-filemap new-filemap)
280     ;; First remove what has to be removed. This way when we
281     ;; do sanity checks, we won't complain about clobbering things
282     ;; that are slated to disappear.
283 kaz 1.35 (unless no-delete-removed
284     (dolist (item removed-items)
285 kaz 1.36.2.1 (let ((real (abstract-to-real-path (second item))))
286     (chatter-terse "removing ~a~%" real)
287     (restart-case
288     (ensure-directories-gone real)
289     (ignore () :report "Ignore file removal error."))
290     (push item rollback-restore-items))))
291 kaz 1.22
292     (dolist (pair moved-pairs)
293     (let ((old-item (first pair)))
294 kaz 1.36.2.1 (ensure-directories-gone (abstract-to-real-path (second old-item)))
295 kaz 1.22 (push old-item rollback-restore-items)))
296    
297     ;; Now check sanity of adds and moves, to verify they don't
298     ;; clobber any local files.
299 kaz 1.23 (let (clobber-add-items clobber-move-pairs)
300     (dolist (item added-items)
301 kaz 1.36.2.1 (let ((file-info (exists (abstract-to-real-path (second item)))))
302 kaz 1.22 (when (and file-info
303 kaz 1.23 (not (same-file-p file-info (stat (first item))))
304     (not (mapping-lookup old-filemap (second item))))
305     (push item clobber-add-items))))
306    
307     (dolist (item moved-pairs)
308     (destructuring-bind (old-item new-item) item
309     (declare (ignore old-item))
310 kaz 1.36.2.1 (let ((file-info (exists (abstract-to-real-path (second new-item)))))
311 kaz 1.23 (when (and file-info
312     (not (mapping-lookup old-filemap (second new-item))))
313    
314     (push item clobber-move-pairs)))))
315    
316     (when (or clobber-add-items clobber-move-pairs)
317     (block nil
318     (restart-bind
319     ((print-clobbers
320     #'(lambda ()
321     (dolist (item clobber-add-items)
322 kaz 1.36.2.1 (format t "add: ~a~%"
323     (abstract-to-real-path (second item))))
324 kaz 1.23 (dolist (pair clobber-move-pairs)
325 kaz 1.36.2.1 (format t "move ~a -> ~a~%"
326     (second (abstract-to-real-path (first pair)))
327     (second (abstract-to-real-path (second pair))))))
328 kaz 1.23 :report-function
329     #'(lambda (stream)
330     (write-string "Print list of adds or moves which want to overwrite."
331     stream)))
332     (do-clobber
333     #'(lambda ()
334     (return))
335     :report-function
336     #'(lambda (stream)
337     (write-string "Go ahead and overwrite the target files."
338     stream))))
339     (error "mcvs: some moves or adds want to overwrite local files or directories.")))))
340 kaz 1.19
341 kaz 1.22 ;; Sanity check passed, complete moves and adds.
342     (dolist (item moved-pairs)
343     (destructuring-bind (old-item new-item) item
344 kaz 1.36.2.1 (let ((real-old (abstract-to-real-path (second old-item)))
345     (real-new (abstract-to-real-path (second new-item))))
346     (chatter-terse "moving ~a -> ~a~%" real-old real-new)
347     (no-existence-error (unlink real-new))
348     (synchronize-files (first new-item) real-new)
349     (push new-item rollback-remove-items))))
350 kaz 1.1
351 kaz 1.22 (dolist (item added-items)
352 kaz 1.36.2.1 (when (real-path-exists (second item))
353     (let ((real (abstract-to-real-path (second item))))
354     (can-restart-here ("Continue updating file structure.")
355     (chatter-terse "adding ~a~%" real)
356     (synchronize-files (first item) real)
357     (push item rollback-remove-items))))))
358 kaz 1.22 (continue ()
359     :report "Restore all restructuring done so far."
360 kaz 1.28 (chatter-debug "Restoring.~%")
361 kaz 1.22 (dolist (item rollback-remove-items)
362 kaz 1.36.2.1 (let ((real (abstract-to-real-path (second item))))
363     (chatter-terse "removing ~a~%" real)
364     (ensure-directories-gone real)))
365 kaz 1.22 (dolist (item rollback-restore-items)
366 kaz 1.36.2.1 (let ((real (abstract-to-real-path (second item))))
367     (chatter-terse "restoring ~a~%" real)
368     (synchronize-files (first item) real)))
369 kaz 1.24 (return-from mapping-update nil)))
370 kaz 1.1
371 kaz 1.24 (mapping-write new-filemap *mcvs-map-local*))
372     t)
373 kaz 1.36
374     (defun mapping-removed-files (filemap)
375     (let ((to-be-removed ())
376     (f-hash (make-hash-table :test #'equal)))
377     (dolist (entry filemap)
378     (setf (gethash (first entry) f-hash) entry))
379     (for-each-file-info (fi *mcvs-dir*)
380     (let ((base (basename (file-name fi))))
381     (multiple-value-bind (suffix name) (suffix base)
382     (declare (ignore suffix))
383     (when (and (= (length name) 34)
384     (string= (subseq name 0 2) "F-")
385     (not (gethash (file-name fi) f-hash)))
386     (push (file-name fi) to-be-removed)))))
387     to-be-removed))
388 kaz 1.36.2.1
389     (defun displaced-path-read ()
390     (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
391     (read file))))
392    
393     (defun displaced-path-write (path)
394     (with-open-file (file *mcvs-displaced* :direction :output)
395     (prin1 path file)
396     (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5