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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Jan 20 20:33:04 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.1: +6 -0 lines
Adding mcvs-diff.
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 (defun filemap-generate-name ()
27 (let ((name (format nil "F-~32,'0X" (guid-gen))))
28 (path-cat *mcvs-dir* name)))
29
30 (defun filemap-sort (filemap)
31 (sort filemap #'(lambda (i1 i2) (string-lessp (second i1) (second i2)))))
32
33 (defun filemap-lookup (filemap path)
34 (find path filemap :test #'(lambda (p entry)
35 (path-equal p (second entry)))))
36
37 (defun filemap-prefix-lookup (filemap path)
38 (if (path-equal *this-dir* path)
39 filemap
40 (remove-if-not #'(lambda (entry)
41 (path-prefix-equal path (second entry))) filemap)))
42
43 (defun filemap-object-lookup (filemap object)
44 (find object filemap :test #'(lambda (o entry)
45 (string= o (first entry)))))
46
47 (defun filemap-same-object-p (entry-one entry-two)
48 (string= (first entry-one) (first entry-two)))
49
50 (defun filemap-same-path-p (entry-one entry-two)
51 (path-equal (second entry-one) (second entry-two)))
52
53 (defun filemap-moved-p (entry-one entry-two)
54 (and (string= (first entry-one) (first entry-two))
55 (not (path-equal (second entry-one) (second entry-two)))))
56
57 (defun mapping-sane-p (filemap)
58 "Performs various integrity checks on a MCVS file map. Checks that
59 it's a list of lists, that all paths and object names are unique.
60 Returns T if checks pass otherwise NIL."
61 (cond
62 ((not (block :structure-check
63 (dolist (item filemap)
64 (when (not (and (listp item) (= 2 (length item))))
65 (return-from :structure-check nil))))) nil)))
66
67 (defun mapping-synchronize ()
68 "Synchronizes the contents of files in the sandbox, and their corresponding
69 CVS files in the MCVS directory. This must be done before any CVS operation
70 such as commit or update, so that the MCVS files have the correct contents
71 reflecting local changes. It must also be done after any CVS update operation,
72 to ensure that the newly incorporated changes are propagated to the sandbox"
73 (let (filemap)
74 (with-open-file (file *mcvs-map-local* :direction :input)
75 (setf filemap (read file)))
76
77 (dolist (item filemap)
78 (can-restart-here ("Continue synchronizing files.")
79 (destructuring-bind (left right) item
80 (case (synchronize-files left right)
81 ((:left)
82 (chatter-info "synchronizing ~a -> ~a~%" left right))
83 ((:right)
84 (chatter-info "synchronizing ~a <- ~a~%" left right))
85 ((:same))
86 ((nil)
87 (error "mcvs-sync: neither ~a nor ~a exists."
88 left right))))))))
89
90 (defun mapping-update ()
91 #.(format nil
92 "Reads the MCVS mapping files ~a and ~a, the local
93 mapping and repository mapping, respectively. It computes the difference
94 between them and then reorganizes the file structure of the sandbox as
95 necessary to make the mapping up to date. Then the local mapping file is
96 overwritten so it is identical to the repository one. This is necessary to
97 bring the local structure up to date after after CVS updates, adds or removes."
98 *mcvs-map-local* *mcvs-map*)
99 (let (old-filemap new-filemap)
100 (with-open-file (file *mcvs-map* :direction :input)
101 (setf new-filemap (read file)))
102
103 (with-open-file (file *mcvs-map-local* :direction :input)
104 (setf old-filemap (read file)))
105
106 (let ((added-files (set-difference new-filemap old-filemap
107 :test #'filemap-same-object-p))
108 (deleted-files (set-difference old-filemap new-filemap
109 :test #'filemap-same-object-p))
110 (moved-files (intersection new-filemap old-filemap
111 :test #'filemap-moved-p)))
112
113 (dolist (item deleted-files)
114 (can-restart-here ("Continue updating file structure.")
115 (ensure-directories-gone (second item))
116 (chatter-info "deleting ~a~%" (second item))))
117
118 (dolist (item moved-files)
119 (can-restart-here ("Continue updating file structure.")
120 (let ((old-item (filemap-object-lookup old-filemap (first item)))
121 (new-item (filemap-object-lookup new-filemap (first item))))
122 (ensure-directories-gone (second old-item))
123 (ensure-directories-exist (second new-item))
124 (synchronize-files (first new-item) (second new-item))
125 (chatter-info "moving ~a -> ~a~%" (second old-item)
126 (second new-item)))))
127
128 (dolist (item added-files)
129 (can-restart-here ("Continue updating file structure.")
130 (synchronize-files (first item) (second item))
131 (chatter-info "adding ~a~%" (second item)))))
132
133 (with-open-file (file *mcvs-map-local* :direction :output)
134 (let ((*print-right-margin* 1))
135 (prin1 new-filemap file)
136 (terpri file)))))

  ViewVC Help
Powered by ViewVC 1.1.5