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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Thu Jan 31 06:17:50 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-2
Changes since 1.10: +18 -14 lines
Factored out repeated code for reading and writing of the MAP and
MAP-LOCAL files.

* mapping.lisp (mapping-read, mapping-write): New functions.
(mapping-synchronize, mapping-update): Use new functions.
* move.lisp (mcvs-move): Likewise.
* filt.lisp (mcvs-filt): Likewise.
* add.lisp (mcvs-add): Likewise.
* remove.lisp (mcvs-remove): Likewise.
* checkout.lisp (mcvs-checkout): Likewise.
* diff.lisp (mcvs-diff): Likewise.
* import.lisp (mcvs-import): Likewise.
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.1 (defun filemap-generate-name ()
50     (let ((name (format nil "F-~32,'0X" (guid-gen))))
51     (path-cat *mcvs-dir* name)))
52    
53     (defun filemap-sort (filemap)
54     (sort filemap #'(lambda (i1 i2) (string-lessp (second i1) (second i2)))))
55    
56 kaz 1.4 (defun filemap-extract-paths (filemap)
57     (mapcar #'second filemap))
58     (declaim (inline filemap-extract-paths))
59    
60 kaz 1.1 (defun filemap-lookup (filemap path)
61 kaz 1.6 (find path filemap :test #'path-equal :key #'second))
62    
63     (defun filemap-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 kaz 1.1
68 kaz 1.6 (defun filemap-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.1 (defun filemap-object-lookup (filemap object)
75 kaz 1.6 (find object filemap :test #'string= :key #'first))
76 kaz 1.1
77     (defun filemap-same-object-p (entry-one entry-two)
78     (string= (first entry-one) (first entry-two)))
79    
80     (defun filemap-same-path-p (entry-one entry-two)
81     (path-equal (second entry-one) (second entry-two)))
82    
83     (defun filemap-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 kaz 1.3 (defun filemap-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 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     (set-difference filemap delete-map :test #'filemap-same-path-p)
114     replace-map :test #'filemap-same-path-p)
115 kaz 1.4 replace-map))))
116 kaz 1.3
117     (defun filemap-sane-p (filemap)
118 kaz 1.10 "Performs various integrity checks on a Meta-CVS file map. Checks that
119 kaz 1.1 it's a list of lists, that all paths and object names are unique.
120     Returns T if checks pass otherwise NIL."
121     (cond
122     ((not (block :structure-check
123     (dolist (item filemap)
124     (when (not (and (listp item) (= 2 (length item))))
125     (return-from :structure-check nil))))) nil)))
126    
127 kaz 1.11 (defun mapping-read (filename &key sanity-check)
128     (let (filemap)
129     (with-open-file (file filename :direction :input)
130     (setf filemap (read file)))
131     (if sanity-check
132     (filemap-sane-p filemap)
133     filemap)))
134    
135     (defun mapping-write (filemap filename &key sort-map)
136     (with-open-file (file filename :direction :output)
137     (let ((*print-right-margin* 1))
138     (prin1 (if sort-map (filemap-sort filemap) filemap) file)
139     (terpri file))))
140    
141 kaz 1.1 (defun mapping-synchronize ()
142     "Synchronizes the contents of files in the sandbox, and their corresponding
143 kaz 1.10 CVS files in the Meta-CVS directory. This must be done before any CVS operation
144     such as commit or update, so that the Meta-CVS files have the correct contents
145 kaz 1.1 reflecting local changes. It must also be done after any CVS update operation,
146     to ensure that the newly incorporated changes are propagated to the sandbox"
147 kaz 1.11 (let ((filemap (mapping-read *mcvs-map-local*)))
148 kaz 1.1 (dolist (item filemap)
149     (can-restart-here ("Continue synchronizing files.")
150     (destructuring-bind (left right) item
151     (case (synchronize-files left right)
152     ((:left)
153     (chatter-info "synchronizing ~a -> ~a~%" left right))
154     ((:right)
155     (chatter-info "synchronizing ~a <- ~a~%" left right))
156     ((:same))
157     ((nil)
158     (error "mcvs-sync: neither ~a nor ~a exists."
159     left right))))))))
160    
161     (defun mapping-update ()
162     #.(format nil
163 kaz 1.10 "Reads the Meta-CVS mapping files ~a and ~a, the local
164 kaz 1.1 mapping and repository mapping, respectively. It computes the difference
165     between them and then reorganizes the file structure of the sandbox as
166     necessary to make the mapping up to date. Then the local mapping file is
167     overwritten so it is identical to the repository one. This is necessary to
168     bring the local structure up to date after after CVS updates, adds or removes."
169     *mcvs-map-local* *mcvs-map*)
170 kaz 1.11 (let ((old-filemap (mapping-read *mcvs-map-local*))
171     (new-filemap (mapping-read *mcvs-map*)))
172 kaz 1.1
173     (let ((added-files (set-difference new-filemap old-filemap
174     :test #'filemap-same-object-p))
175     (deleted-files (set-difference old-filemap new-filemap
176     :test #'filemap-same-object-p))
177     (moved-files (intersection new-filemap old-filemap
178     :test #'filemap-moved-p)))
179    
180     (dolist (item deleted-files)
181     (can-restart-here ("Continue updating file structure.")
182     (ensure-directories-gone (second item))
183     (chatter-info "deleting ~a~%" (second item))))
184    
185     (dolist (item moved-files)
186     (can-restart-here ("Continue updating file structure.")
187     (let ((old-item (filemap-object-lookup old-filemap (first item)))
188     (new-item (filemap-object-lookup new-filemap (first item))))
189     (ensure-directories-gone (second old-item))
190     (ensure-directories-exist (second new-item))
191     (synchronize-files (first new-item) (second new-item))
192     (chatter-info "moving ~a -> ~a~%" (second old-item)
193     (second new-item)))))
194    
195     (dolist (item added-files)
196     (can-restart-here ("Continue updating file structure.")
197     (synchronize-files (first item) (second item))
198     (chatter-info "adding ~a~%" (second item)))))
199    
200 kaz 1.11 (mapping-write new-filemap *mcvs-map-local*)))

  ViewVC Help
Powered by ViewVC 1.1.5