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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5