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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Tue Feb 5 03:19:03 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-4
Changes since 1.17: +3 -4 lines
* mapping.lisp (mapping-sort): Removed function.
(mapping-write): Sort written map by F- file names,
not by path names. This is far better for merging, because
files stay in the same place when they are renamed.
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
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* "MAP"))
17 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* "MAP-LOCAL")))
18
19 ;; TODO: use getcwd()
20 (defun mcvs-locate ()
21 "Search for Meta-CVS directory by looking in the current directory, and
22 if it is not found there, by changing directory up through successive
23 parent directories. Returns the path from the new current directory
24 down to the original one, or the value nil if not found."
25 (if (ignore-errors (stat *mcvs-dir*))
26 "."
27 (let ((came-from (go-up)))
28 (if came-from
29 (let ((locate (mcvs-locate)))
30 (if locate
31 (path-cat locate came-from)))))))
32
33 (defmacro in-sandbox-root-dir (&body forms)
34 (let ((downpath-sym (gensym "DOWNPATH-")))
35 `(current-dir-restore
36 (let ((,downpath-sym (mcvs-locate)))
37 (when (not ,downpath-sym)
38 (error "mcvs: could not locate ~a directory." *mcvs-dir*))
39 (flet ((sandbox-translate-path (in-path)
40 (multiple-value-bind (out-path out-of-bounds)
41 (canonicalize-path
42 (path-cat ,downpath-sym in-path))
43 (if out-of-bounds
44 (error "mcvs: path ~a is not within sandbox." out-path)
45 out-path))))
46 (symbol-macrolet ((sandbox-down-path ',downpath-sym))
47 ,@forms))))))
48
49 (defun mapping-generate-name ()
50 (let ((name (format nil "F-~32,'0X" (guid-gen))))
51 (path-cat *mcvs-dir* name)))
52
53 (defun mapping-extract-paths (filemap)
54 (mapcar #'second filemap))
55 (declaim (inline mapping-extract-paths))
56
57 (defun mapping-lookup (filemap path)
58 (find path filemap :test #'path-equal :key #'second))
59
60 (defun mapping-prefix-lookup (filemap prefix)
61 (if (path-equal *this-dir* prefix)
62 (first filemap)
63 (find prefix filemap :test #'path-prefix-equal :key #'second)))
64
65 (defun mapping-prefix-matches (filemap path)
66 (if (path-equal *this-dir* path)
67 filemap
68 (remove-if-not #'(lambda (entry)
69 (path-prefix-equal path (second entry))) filemap)))
70
71 (defun mapping-object-lookup (filemap object)
72 (find object filemap :test #'string= :key #'first))
73
74 (defun mapping-same-object-p (entry-one entry-two)
75 (string= (first entry-one) (first entry-two)))
76
77 (defun mapping-same-path-p (entry-one entry-two)
78 (path-equal (second entry-one) (second entry-two)))
79
80 (defun mapping-moved-p (entry-one entry-two)
81 (and (string= (first entry-one) (first entry-two))
82 (not (path-equal (second entry-one) (second entry-two)))))
83
84 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
85 "Returns a new filemap, in which the pathames in the list file-list are edited
86 by replacing the old-prefix with the new-prefix. If any path thus created
87 matches an existing map entry, that map entry is removed. The sorting order
88 of the map is not preserved."
89 (flet ((combine (prefix path)
90 (if (string= path "")
91 prefix
92 (canonicalize-path (path-cat prefix path)))))
93 (let* ((op-len (length old-prefix))
94 (delete-map (mapcan #'(lambda (entry)
95 (let ((path (second entry)))
96 (if (and (member path file-list
97 :test #'path-equal)
98 (path-prefix-equal old-prefix
99 path))
100 (list entry)))) filemap))
101 (replace-map (mapcan #'(lambda (entry)
102 (destructuring-bind (object path) entry
103 (list (list object
104 (combine new-prefix
105 (subseq path
106 op-len))))))
107 delete-map)))
108 (append
109 (set-difference
110 (set-difference filemap delete-map :test #'mapping-same-path-p)
111 replace-map :test #'mapping-same-path-p)
112 replace-map))))
113
114 (defun mapping-dupe-check (filemap)
115 "Signals an error condition if the filemap contains duplicate paths or
116 duplicate objects. Otherwise returns the filemap, sorted by path."
117 (let (dupes)
118 (sort filemap #'string-lessp :key #'first)
119
120 (let ((iter (rest filemap)) (current-item (first (first filemap))))
121 (loop
122 (when (endp iter)
123 (return))
124 (if (string= (first (first iter)) current-item)
125 (push (first iter) dupes)
126 (setf current-item (first (first iter))))
127 (setf iter (rest iter))))
128
129 (sort filemap #'string-lessp :key #'second)
130
131 (let ((iter (rest filemap)) (current-item (second (first filemap))))
132 (loop
133 (when (endp iter)
134 (return))
135 (if (path-equal (second (first iter)) current-item)
136 (push (first iter) dupes)
137 (setf current-item (second (first iter))))
138 (setf iter (rest iter))))
139
140 (when dupes
141 (dolist (dupe dupes)
142 (chatter-info "duplicate ~a -> ~a~%" (first dupe) (second dupe)))
143 (error "mcvs: duplicates in map: correct and run mcvs update~%")))
144 filemap)
145
146 (defun mapping-read (filename &key sanity-check)
147 (let (filemap)
148 (with-open-file (file filename :direction :input)
149 (setf filemap (read file)))
150 (if sanity-check
151 (mapping-dupe-check filemap)
152 filemap)))
153
154 (defun mapping-write (filemap filename &key sort-map)
155 (with-open-file (file filename :direction :output)
156 (let ((*print-right-margin* 1))
157 (prin1 (if sort-map
158 (sort filemap #'string-lessp :key #'first)
159 filemap) file)
160 (terpri file))))
161
162 (defun mapping-synchronize ()
163 "Synchronizes the contents of files in the sandbox, and their corresponding
164 CVS files in the Meta-CVS directory. This must be done before any CVS operation
165 such as commit or update, so that the Meta-CVS files have the correct contents
166 reflecting local changes. It must also be done after any CVS update operation,
167 to ensure that the newly incorporated changes are propagated to the sandbox"
168 (let ((filemap (mapping-read *mcvs-map-local*)))
169 (dolist (item filemap)
170 (can-restart-here ("Continue synchronizing files.")
171 (destructuring-bind (left right) item
172 (case (synchronize-files left right)
173 ((:left)
174 (chatter-info "synchronizing ~a -> ~a~%" left right))
175 ((:right)
176 (chatter-info "synchronizing ~a <- ~a~%" left right))
177 ((:same))
178 ((nil)
179 (error "mcvs-sync: neither ~a nor ~a exists."
180 left right))))))))
181
182 (defun mapping-difference (old-mapping new-mapping)
183 "Compute the difference between two mappings. Returns three values:
184 a mapping containing only elements added by new-mapping, a mapping
185 containing only elements removed by new-mapping, and a list
186 of moved items, which contains pairs of elements from both,
187 whose object name matches, but path differs."
188 (let (added-items removed-items moved-pairs)
189 (sort old-mapping #'string-lessp :key #'first)
190 (sort new-mapping #'string-lessp :key #'first)
191
192 (loop
193 (let* ((old-item (first old-mapping))
194 (new-item (first new-mapping)))
195 (cond
196 ((and (endp old-item) (endp new-item)) (return))
197 ((string-lessp (first old-item) (first new-item))
198 (pop old-mapping)
199 (push old-item removed-items))
200 ((string= (first old-item) (first new-item))
201 (pop old-mapping)
202 (pop new-mapping)
203 (when (not (path-equal (second old-item) (second new-item)))
204 (push (list old-item new-item) moved-pairs)))
205 (t
206 (pop new-mapping)
207 (push new-item added-items)))))
208 (values added-items removed-items moved-pairs)))
209
210 (defun mapping-update ()
211 #.(format nil
212 "Reads the Meta-CVS mapping files ~a and ~a, the local
213 mapping and repository mapping, respectively. It computes the difference
214 between them and then reorganizes the file structure of the sandbox as
215 necessary to make the mapping up to date. Then the local mapping file is
216 overwritten so it is identical to the repository one. This is necessary to
217 bring the local structure up to date after after CVS updates, adds or removes."
218 *mcvs-map-local* *mcvs-map*)
219 (let ((old-filemap (mapping-read *mcvs-map-local*))
220 (new-filemap (mapping-read *mcvs-map* :sanity-check t)))
221 (multiple-value-bind (added-items removed-items moved-pairs)
222 (mapping-difference old-filemap new-filemap)
223 (dolist (item removed-items)
224 (can-restart-here ("Continue updating file structure.")
225 (ensure-directories-gone (second item))
226 (chatter-info "deleting ~a~%" (second item))))
227
228 (dolist (item moved-pairs)
229 (destructuring-bind (old-item new-item) item
230 (can-restart-here ("Continue updating file structure.")
231 (ensure-directories-gone (second old-item))
232 (ensure-directories-exist (second new-item))
233 (no-existence-error (unlink (second new-item)))
234 (synchronize-files (first new-item) (second new-item))
235 (chatter-info "moving ~a -> ~a~%" (second old-item)
236 (second new-item)))))
237
238 (dolist (item added-items)
239 (can-restart-here ("Continue updating file structure.")
240 (synchronize-files (first item) (second item))
241 (chatter-info "adding ~a~%" (second item)))))
242
243 (mapping-write new-filemap *mcvs-map-local*)))

  ViewVC Help
Powered by ViewVC 1.1.5