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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Sat Feb 16 19:41:43 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-7
Changes since 1.24: +6 -2 lines
Support for filetypes in import.

* posix.lisp (suffix): Separator character parameter is optional;
multiple occurences of character lead to one big suffix like
".tar.gz" instead of ".gz".  A leading dot means it's not a suffix but
a hidden file like ".exrc".
(edit-file): New function, brings up text editor for specified file.

* clisp-linux.lisp (env-lookup): New function for environment
variable lookup.

* types.lisp: New source file.
(*mcvs-types-name*, *mcvs-types*): New constants for TYPES filename.
(types-read, types-write, types-sanity-check,
types-to-import-wrapper-args): New functions.

* import.lisp (*types-comments*): New constant.
(mcvs-import): Restructured to build up list of file suffixes,
allow the user to edit the file which determines how they
are treated, filter out ignored files and pass -W options to cvs import
to handle the rest. Failed cvs import is turned into restartable
condition.

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

  ViewVC Help
Powered by ViewVC 1.1.5