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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Sat Feb 2 11:39:36 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.15: +1 -0 lines
* mapping.lisp (mapping-update): When moving files, ensure
that the target is unlinked if it exists.

* move.lisp (simple-rename): No longer do target unlinking
here. Also bugfix: it wasn't handling renames of directories
containing just one file.
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     (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 kaz 1.1
19     ;; TODO: use getcwd()
20     (defun mcvs-locate ()
21 kaz 1.10 "Search for Meta-CVS directory by looking in the current directory, and
22 kaz 1.1 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 kaz 1.4 (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 kaz 1.12 (defun mapping-generate-name ()
50 kaz 1.1 (let ((name (format nil "F-~32,'0X" (guid-gen))))
51     (path-cat *mcvs-dir* name)))
52    
53 kaz 1.12 (defun mapping-sort (filemap)
54 kaz 1.1 (sort filemap #'(lambda (i1 i2) (string-lessp (second i1) (second i2)))))
55    
56 kaz 1.12 (defun mapping-extract-paths (filemap)
57 kaz 1.4 (mapcar #'second filemap))
58 kaz 1.12 (declaim (inline mapping-extract-paths))
59 kaz 1.4
60 kaz 1.12 (defun mapping-lookup (filemap path)
61 kaz 1.6 (find path filemap :test #'path-equal :key #'second))
62    
63 kaz 1.12 (defun mapping-prefix-lookup (filemap prefix)
64 kaz 1.6 (if (path-equal *this-dir* prefix)
65     (first filemap)
66     (find prefix filemap :test #'path-prefix-equal :key #'second)))
67 kaz 1.1
68 kaz 1.12 (defun mapping-prefix-matches (filemap path)
69 kaz 1.2 (if (path-equal *this-dir* path)
70     filemap
71     (remove-if-not #'(lambda (entry)
72     (path-prefix-equal path (second entry))) filemap)))
73    
74 kaz 1.12 (defun mapping-object-lookup (filemap object)
75 kaz 1.6 (find object filemap :test #'string= :key #'first))
76 kaz 1.1
77 kaz 1.12 (defun mapping-same-object-p (entry-one entry-two)
78 kaz 1.1 (string= (first entry-one) (first entry-two)))
79    
80 kaz 1.12 (defun mapping-same-path-p (entry-one entry-two)
81 kaz 1.1 (path-equal (second entry-one) (second entry-two)))
82    
83 kaz 1.12 (defun mapping-moved-p (entry-one entry-two)
84 kaz 1.1 (and (string= (first entry-one) (first entry-two))
85     (not (path-equal (second entry-one) (second entry-two)))))
86    
87 kaz 1.12 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
88 kaz 1.3 "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 kaz 1.4 (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 kaz 1.8 (let ((path (second entry)))
99 kaz 1.4 (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 kaz 1.3 (append
112     (set-difference
113 kaz 1.12 (set-difference filemap delete-map :test #'mapping-same-path-p)
114     replace-map :test #'mapping-same-path-p)
115 kaz 1.4 replace-map))))
116 kaz 1.3
117 kaz 1.13 (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 kaz 1.15 (error "mcvs: duplicates in map: correct and run mcvs update~%")))
129 kaz 1.13 filemap)
130 kaz 1.1
131 kaz 1.11 (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 kaz 1.14 (mapping-dupe-check filemap)
137 kaz 1.11 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 kaz 1.12 (prin1 (if sort-map (mapping-sort filemap) filemap) file)
143 kaz 1.11 (terpri file))))
144    
145 kaz 1.1 (defun mapping-synchronize ()
146     "Synchronizes the contents of files in the sandbox, and their corresponding
147 kaz 1.10 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 kaz 1.1 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 kaz 1.11 (let ((filemap (mapping-read *mcvs-map-local*)))
152 kaz 1.1 (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 kaz 1.10 "Reads the Meta-CVS mapping files ~a and ~a, the local
168 kaz 1.1 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 kaz 1.11 (let ((old-filemap (mapping-read *mcvs-map-local*))
175 kaz 1.13 (new-filemap (mapping-read *mcvs-map* :sanity-check t)))
176 kaz 1.1
177     (let ((added-files (set-difference new-filemap old-filemap
178 kaz 1.12 :test #'mapping-same-object-p))
179 kaz 1.1 (deleted-files (set-difference old-filemap new-filemap
180 kaz 1.12 :test #'mapping-same-object-p))
181 kaz 1.1 (moved-files (intersection new-filemap old-filemap
182 kaz 1.12 :test #'mapping-moved-p)))
183 kaz 1.1
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 kaz 1.12 (let ((old-item (mapping-object-lookup old-filemap (first item)))
192     (new-item (mapping-object-lookup new-filemap (first item))))
193 kaz 1.1 (ensure-directories-gone (second old-item))
194     (ensure-directories-exist (second new-item))
195 kaz 1.16 (no-existence-error (unlink (second new-item)))
196 kaz 1.1 (synchronize-files (first new-item) (second new-item))
197     (chatter-info "moving ~a -> ~a~%" (second old-item)
198     (second new-item)))))
199    
200     (dolist (item added-files)
201     (can-restart-here ("Continue updating file structure.")
202     (synchronize-files (first item) (second item))
203     (chatter-info "adding ~a~%" (second item)))))
204    
205 kaz 1.11 (mapping-write new-filemap *mcvs-map-local*)))

  ViewVC Help
Powered by ViewVC 1.1.5