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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Sat Feb 2 10:05:48 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.13: +1 -1 lines
Oops, correcting little function name mismatch.
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-sort (filemap)
54 (sort filemap #'(lambda (i1 i2) (string-lessp (second i1) (second i2)))))
55
56 (defun mapping-extract-paths (filemap)
57 (mapcar #'second filemap))
58 (declaim (inline mapping-extract-paths))
59
60 (defun mapping-lookup (filemap path)
61 (find path filemap :test #'path-equal :key #'second))
62
63 (defun mapping-prefix-lookup (filemap prefix)
64 (if (path-equal *this-dir* prefix)
65 (first filemap)
66 (find prefix filemap :test #'path-prefix-equal :key #'second)))
67
68 (defun mapping-prefix-matches (filemap path)
69 (if (path-equal *this-dir* path)
70 filemap
71 (remove-if-not #'(lambda (entry)
72 (path-prefix-equal path (second entry))) filemap)))
73
74 (defun mapping-object-lookup (filemap object)
75 (find object filemap :test #'string= :key #'first))
76
77 (defun mapping-same-object-p (entry-one entry-two)
78 (string= (first entry-one) (first entry-two)))
79
80 (defun mapping-same-path-p (entry-one entry-two)
81 (path-equal (second entry-one) (second entry-two)))
82
83 (defun mapping-moved-p (entry-one entry-two)
84 (and (string= (first entry-one) (first entry-two))
85 (not (path-equal (second entry-one) (second entry-two)))))
86
87 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
88 "Returns a new filemap, in which the pathames in the list file-list are edited
89 by replacing the old-prefix with the new-prefix. If any path thus created
90 matches an existing map entry, that map entry is removed. The sorting order
91 of the map is not preserved."
92 (flet ((combine (prefix path)
93 (if (string= path "")
94 prefix
95 (canonicalize-path (path-cat prefix path)))))
96 (let* ((op-len (length old-prefix))
97 (delete-map (mapcan #'(lambda (entry)
98 (let ((path (second entry)))
99 (if (and (member path file-list
100 :test #'path-equal)
101 (path-prefix-equal old-prefix
102 path))
103 (list entry)))) filemap))
104 (replace-map (mapcan #'(lambda (entry)
105 (destructuring-bind (object path) entry
106 (list (list object
107 (combine new-prefix
108 (subseq path
109 op-len))))))
110 delete-map)))
111 (append
112 (set-difference
113 (set-difference filemap delete-map :test #'mapping-same-path-p)
114 replace-map :test #'mapping-same-path-p)
115 replace-map))))
116
117 (defun mapping-dupe-check (filemap)
118 "Signals an error condition if the filemap contains duplicate paths or
119 duplicate objects. Otherwise returns the filemap."
120 (let ((dupes (intersection filemap filemap
121 :test #'(lambda (x y)
122 (and (not (eq x y))
123 (or (mapping-same-path-p x y)
124 (mapping-same-object-p x y)))))))
125 (when dupes
126 (dolist (dupe dupes)
127 (chatter-info "duplicate ~a -> ~a~%" (first dupe) (second dupe)))
128 (error "mcvs: duplicates in map~%")))
129 filemap)
130
131 (defun mapping-read (filename &key sanity-check)
132 (let (filemap)
133 (with-open-file (file filename :direction :input)
134 (setf filemap (read file)))
135 (if sanity-check
136 (mapping-dupe-check filemap)
137 filemap)))
138
139 (defun mapping-write (filemap filename &key sort-map)
140 (with-open-file (file filename :direction :output)
141 (let ((*print-right-margin* 1))
142 (prin1 (if sort-map (mapping-sort filemap) filemap) file)
143 (terpri file))))
144
145 (defun mapping-synchronize ()
146 "Synchronizes the contents of files in the sandbox, and their corresponding
147 CVS files in the Meta-CVS directory. This must be done before any CVS operation
148 such as commit or update, so that the Meta-CVS files have the correct contents
149 reflecting local changes. It must also be done after any CVS update operation,
150 to ensure that the newly incorporated changes are propagated to the sandbox"
151 (let ((filemap (mapping-read *mcvs-map-local*)))
152 (dolist (item filemap)
153 (can-restart-here ("Continue synchronizing files.")
154 (destructuring-bind (left right) item
155 (case (synchronize-files left right)
156 ((:left)
157 (chatter-info "synchronizing ~a -> ~a~%" left right))
158 ((:right)
159 (chatter-info "synchronizing ~a <- ~a~%" left right))
160 ((:same))
161 ((nil)
162 (error "mcvs-sync: neither ~a nor ~a exists."
163 left right))))))))
164
165 (defun mapping-update ()
166 #.(format nil
167 "Reads the Meta-CVS mapping files ~a and ~a, the local
168 mapping and repository mapping, respectively. It computes the difference
169 between them and then reorganizes the file structure of the sandbox as
170 necessary to make the mapping up to date. Then the local mapping file is
171 overwritten so it is identical to the repository one. This is necessary to
172 bring the local structure up to date after after CVS updates, adds or removes."
173 *mcvs-map-local* *mcvs-map*)
174 (let ((old-filemap (mapping-read *mcvs-map-local*))
175 (new-filemap (mapping-read *mcvs-map* :sanity-check t)))
176
177 (let ((added-files (set-difference new-filemap old-filemap
178 :test #'mapping-same-object-p))
179 (deleted-files (set-difference old-filemap new-filemap
180 :test #'mapping-same-object-p))
181 (moved-files (intersection new-filemap old-filemap
182 :test #'mapping-moved-p)))
183
184 (dolist (item deleted-files)
185 (can-restart-here ("Continue updating file structure.")
186 (ensure-directories-gone (second item))
187 (chatter-info "deleting ~a~%" (second item))))
188
189 (dolist (item moved-files)
190 (can-restart-here ("Continue updating file structure.")
191 (let ((old-item (mapping-object-lookup old-filemap (first item)))
192 (new-item (mapping-object-lookup new-filemap (first item))))
193 (ensure-directories-gone (second old-item))
194 (ensure-directories-exist (second new-item))
195 (synchronize-files (first new-item) (second new-item))
196 (chatter-info "moving ~a -> ~a~%" (second old-item)
197 (second new-item)))))
198
199 (dolist (item added-files)
200 (can-restart-here ("Continue updating file structure.")
201 (synchronize-files (first item) (second item))
202 (chatter-info "adding ~a~%" (second item)))))
203
204 (mapping-write new-filemap *mcvs-map-local*)))

  ViewVC Help
Powered by ViewVC 1.1.5