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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sat Jan 26 01:38:38 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.5: +15 -8 lines
Moving closer toward delivery.
1 (require "dirwalk")
2 (require "system")
3 (require "sync")
4 (require "chatter")
5 (require "restart")
6 (provide "mapping")
7
8 (eval-when (:compile-toplevel :load-toplevel :execute)
9 (defconstant *mcvs-dir* #.(path-cat "MCVS")))
10
11 (eval-when (:compile-toplevel :load-toplevel :execute)
12 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* "MAP"))
13 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* "MAP-LOCAL")))
14
15 ;; TODO: use getcwd()
16 (defun mcvs-locate ()
17 "Search for MCVS directory by looking in the current directory, and
18 if it is not found there, by changing directory up through successive
19 parent directories. Returns the path from the new current directory
20 down to the original one, or the value nil if not found."
21 (if (ignore-errors (stat *mcvs-dir*))
22 "."
23 (let ((came-from (go-up)))
24 (if came-from
25 (let ((locate (mcvs-locate)))
26 (if locate
27 (path-cat locate came-from)))))))
28
29 (defmacro in-sandbox-root-dir (&body forms)
30 (let ((downpath-sym (gensym "DOWNPATH-")))
31 `(current-dir-restore
32 (let ((,downpath-sym (mcvs-locate)))
33 (when (not ,downpath-sym)
34 (error "mcvs: could not locate ~a directory." *mcvs-dir*))
35 (flet ((sandbox-translate-path (in-path)
36 (multiple-value-bind (out-path out-of-bounds)
37 (canonicalize-path
38 (path-cat ,downpath-sym in-path))
39 (if out-of-bounds
40 (error "mcvs: path ~a is not within sandbox." out-path)
41 out-path))))
42 (symbol-macrolet ((sandbox-down-path ',downpath-sym))
43 ,@forms))))))
44
45 (defun filemap-generate-name ()
46 (let ((name (format nil "F-~32,'0X" (guid-gen))))
47 (path-cat *mcvs-dir* name)))
48
49 (defun filemap-sort (filemap)
50 (sort filemap #'(lambda (i1 i2) (string-lessp (second i1) (second i2)))))
51
52 (defun filemap-extract-paths (filemap)
53 (mapcar #'second filemap))
54 (declaim (inline filemap-extract-paths))
55
56 (defun filemap-lookup (filemap path)
57 (find path filemap :test #'path-equal :key #'second))
58
59 (defun filemap-prefix-lookup (filemap prefix)
60 (if (path-equal *this-dir* prefix)
61 (first filemap)
62 (find prefix filemap :test #'path-prefix-equal :key #'second)))
63
64 (defun filemap-prefix-matches (filemap path)
65 (if (path-equal *this-dir* path)
66 filemap
67 (remove-if-not #'(lambda (entry)
68 (path-prefix-equal path (second entry))) filemap)))
69
70 (defun filemap-object-lookup (filemap object)
71 (find object filemap :test #'string= :key #'first))
72
73 (defun filemap-same-object-p (entry-one entry-two)
74 (string= (first entry-one) (first entry-two)))
75
76 (defun filemap-same-path-p (entry-one entry-two)
77 (path-equal (second entry-one) (second entry-two)))
78
79 (defun filemap-moved-p (entry-one entry-two)
80 (and (string= (first entry-one) (first entry-two))
81 (not (path-equal (second entry-one) (second entry-two)))))
82
83 (defun filemap-remove (filemap file-list)
84 "Returns a new filemap, with the specified files removed."
85 (mapcan #'(lambda (entry)
86 (if (member (second entry) file-list :test #'path-equal)
87 nil
88 entry))))
89
90 (defun filemap-rename-files (filemap file-list old-prefix new-prefix)
91 "Returns a new filemap, in which the pathames in the list file-list are edited
92 by replacing the old-prefix with the new-prefix. If any path thus created
93 matches an existing map entry, that map entry is removed. The sorting order
94 of the map is not preserved."
95 (break)
96 (flet ((combine (prefix path)
97 (if (string= path "")
98 prefix
99 (canonicalize-path (path-cat prefix path)))))
100 (let* ((op-len (length old-prefix))
101 (delete-map (mapcan #'(lambda (entry)
102 (destructuring-bind (object path) entry
103 (if (and (member path file-list
104 :test #'path-equal)
105 (path-prefix-equal old-prefix
106 path))
107 (list entry)))) filemap))
108 (replace-map (mapcan #'(lambda (entry)
109 (destructuring-bind (object path) entry
110 (list (list object
111 (combine new-prefix
112 (subseq path
113 op-len))))))
114 delete-map)))
115 (append
116 (set-difference
117 (set-difference filemap delete-map :test #'filemap-same-path-p)
118 replace-map :test #'filemap-same-path-p)
119 replace-map))))
120
121 (defun filemap-sane-p (filemap)
122 "Performs various integrity checks on a MCVS file map. Checks that
123 it's a list of lists, that all paths and object names are unique.
124 Returns T if checks pass otherwise NIL."
125 (cond
126 ((not (block :structure-check
127 (dolist (item filemap)
128 (when (not (and (listp item) (= 2 (length item))))
129 (return-from :structure-check nil))))) nil)))
130
131 (defun mapping-synchronize ()
132 "Synchronizes the contents of files in the sandbox, and their corresponding
133 CVS files in the MCVS directory. This must be done before any CVS operation
134 such as commit or update, so that the MCVS files have the correct contents
135 reflecting local changes. It must also be done after any CVS update operation,
136 to ensure that the newly incorporated changes are propagated to the sandbox"
137 (let (filemap)
138 (with-open-file (file *mcvs-map-local* :direction :input)
139 (setf filemap (read file)))
140
141 (dolist (item filemap)
142 (can-restart-here ("Continue synchronizing files.")
143 (destructuring-bind (left right) item
144 (case (synchronize-files left right)
145 ((:left)
146 (chatter-info "synchronizing ~a -> ~a~%" left right))
147 ((:right)
148 (chatter-info "synchronizing ~a <- ~a~%" left right))
149 ((:same))
150 ((nil)
151 (error "mcvs-sync: neither ~a nor ~a exists."
152 left right))))))))
153
154 (defun mapping-update ()
155 #.(format nil
156 "Reads the MCVS mapping files ~a and ~a, the local
157 mapping and repository mapping, respectively. It computes the difference
158 between them and then reorganizes the file structure of the sandbox as
159 necessary to make the mapping up to date. Then the local mapping file is
160 overwritten so it is identical to the repository one. This is necessary to
161 bring the local structure up to date after after CVS updates, adds or removes."
162 *mcvs-map-local* *mcvs-map*)
163 (let (old-filemap new-filemap)
164 (with-open-file (file *mcvs-map* :direction :input)
165 (setf new-filemap (read file)))
166
167 (with-open-file (file *mcvs-map-local* :direction :input)
168 (setf old-filemap (read file)))
169
170 (let ((added-files (set-difference new-filemap old-filemap
171 :test #'filemap-same-object-p))
172 (deleted-files (set-difference old-filemap new-filemap
173 :test #'filemap-same-object-p))
174 (moved-files (intersection new-filemap old-filemap
175 :test #'filemap-moved-p)))
176
177 (dolist (item deleted-files)
178 (can-restart-here ("Continue updating file structure.")
179 (ensure-directories-gone (second item))
180 (chatter-info "deleting ~a~%" (second item))))
181
182 (dolist (item moved-files)
183 (can-restart-here ("Continue updating file structure.")
184 (let ((old-item (filemap-object-lookup old-filemap (first item)))
185 (new-item (filemap-object-lookup new-filemap (first item))))
186 (ensure-directories-gone (second old-item))
187 (ensure-directories-exist (second new-item))
188 (synchronize-files (first new-item) (second new-item))
189 (chatter-info "moving ~a -> ~a~%" (second old-item)
190 (second new-item)))))
191
192 (dolist (item added-files)
193 (can-restart-here ("Continue updating file structure.")
194 (synchronize-files (first item) (second item))
195 (chatter-info "adding ~a~%" (second item)))))
196
197 (with-open-file (file *mcvs-map-local* :direction :output)
198 (let ((*print-right-margin* 1))
199 (prin1 new-filemap file)
200 (terpri file)))))

  ViewVC Help
Powered by ViewVC 1.1.5