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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Mon Jul 1 16:16:25 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
Changes since 1.34: +8 -7 lines
Grab no longer synchronizes to recreate deleted files immediately
before blowing them away.

* grab.lisp (mcvs-grab): Specify :no-sync t when calling mcvs-remove.

* remove.lisp (mcvs-remove): Support new no-sync keyword. This tells
mcvs-remove that the files being removed from the mapping,
don't exist in the sandbox. So it's not necessary to call
mapping-synchronize, and mapping-update can be told via
:no-delete-removed t not to try to remove deleted files.

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

  ViewVC Help
Powered by ViewVC 1.1.5