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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5