/[meta-cvs]/meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp
ViewVC logotype

Contents of /meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Sat Sep 21 17:58:23 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-96
Changes since 1.19: +11 -7 lines
* code/grab.lisp (mcvs-grab): Inspect the execute permissions
of stable and moved files, and update the :EXEC propery of
their mapping entries accordingly. In other words, grab changes
in execute permissions properly.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "dirwalk")
6 (require "system")
7 (require "split")
8 (require "seqfuncs")
9 (require "mapping")
10 (require "types")
11 (require "chatter")
12 (require "options")
13 (require "checkout")
14 (require "remove")
15 (require "add")
16 (provide "grab")
17
18 (defun read-word-hash (&optional (byte-stream t))
19 (let ((word-hash (make-hash-table :test #'equalp))
20 token
21 (state :junk))
22 (labels ((new-token ()
23 (if token
24 (setf (fill-pointer token) 0)
25 (setf token (make-array '(8)
26 :element-type 'character
27 :adjustable t
28 :fill-pointer 0))))
29 (save-token ()
30 (unless (gethash token word-hash)
31 (setf (gethash token word-hash) token)
32 (setf token nil))))
33 (do ((byte (read-byte byte-stream nil)
34 (read-byte byte-stream nil)))
35 ((null byte) (if (eq state :word) (save-token)) word-hash)
36 (let ((ch (int-char byte)))
37 (ecase state
38 ((:junk)
39 (when (or (alpha-char-p ch) (digit-char-p ch)
40 (char= ch #\_))
41 (new-token)
42 (vector-push-extend ch token)
43 (setf state :word)))
44 ((:word)
45 (cond
46 ((or (alpha-char-p ch) (digit-char-p ch)
47 (char= ch #\_) (char= ch #\-))
48 (vector-push-extend ch token))
49 (t (setf state :junk)
50 (save-token))))))))))
51
52 (defun word-hash-file (name)
53 (with-open-file (s (parse-posix-namestring name)
54 :direction :input
55 :element-type 'unsigned-byte)
56 (read-word-hash s)))
57
58 (defun correlate-word-hashes (hash-1 hash-2)
59 (let ((hc-1 (hash-table-count hash-1))
60 (hc-2 (hash-table-count hash-2)))
61 (when (> hc-1 hc-2)
62 (psetf hash-1 hash-2 hash-2 hash-1
63 hc-1 hc-2 hc-2 hc-1))
64 (let ((common-count 0))
65 (maphash #'(lambda (key element)
66 (declare (ignore key))
67 (when (gethash element hash-2)
68 (incf common-count)))
69 hash-1)
70 (let ((total-count (- (+ hc-1 hc-2) common-count)))
71 (if (zerop total-count)
72 0
73 (/ common-count total-count))))))
74
75 (defun correlate-paths (path-1 path-2)
76 (let* ((split-1 (split-fields path-1 *path-sep*))
77 (split-2 (split-fields path-2 *path-sep*))
78 (longer (max (length split-1) (length split-2)))
79 (lcs-len (length (longest-common-subsequence split-1 split-2
80 :test #'string=))))
81 (case (- longer lcs-len)
82 ((0 1) 1)
83 ((2) 95/100)
84 ((3) 90/100)
85 ((4) 85/100)
86 (otherwise 80/100))))
87
88 (defun determine-common-words (common-hash added-or-removed-files)
89 (dolist (file added-or-removed-files common-hash)
90 (maphash #'(lambda (key value)
91 (declare (ignore value))
92 (let ((existing (gethash key common-hash)))
93 (if existing
94 (setf (gethash key common-hash)
95 (1+ existing))
96 (setf (gethash key common-hash)
97 1))))
98 (second file))))
99
100 (defun eliminate-common-words (common-hash files threshold)
101 (dolist (file files)
102 (maphash #'(lambda (key value)
103 (declare (ignore value))
104 (let ((count (gethash key common-hash)))
105 (if (and count (>= count threshold))
106 (remhash key (second file)))))
107 (second file))))
108
109 (defun determine-moved-files (added-files removed-files)
110 (let (pairs moved-files taken-added taken-removed)
111 (dolist (added added-files)
112 (dolist (removed removed-files)
113 (let ((correlation (correlate-word-hashes (second added)
114 (second removed))))
115 (when (>= correlation 30/100)
116 (push (list added removed
117 (* correlation (correlate-paths (first added)
118 (first removed))))
119 pairs)))))
120 (setf pairs (sort pairs #'> :key #'third))
121 (dolist (pair pairs)
122 (unless (or (member (first pair) taken-added :test #'eq)
123 (member (second pair) taken-removed :test #'eq))
124 (push (first pair) taken-added)
125 (push (second pair) taken-removed)
126 (push pair moved-files)))
127 (values moved-files
128 (set-difference added-files taken-added :test #'eq)
129 (set-difference removed-files taken-removed :test #'eq))))
130
131 (defun determine-moved-symlinks (added-symlinks removed-symlinks moved-files
132 stable-files)
133 (let ((add-hash (make-hash-table :test #'equal))
134 (remove-hash (make-hash-table :test #'equal))
135 moved-symlinks taken-added taken-removed)
136 (macrolet ((process-item (item path target hash)
137 `(unless (path-absolute-p ,target)
138 (multiple-value-bind (base dir) (basename ,path)
139 (declare (ignore base))
140 (if (null dir)
141 (setf dir "."))
142 (multiple-value-bind (resolved-path out-of-bounds)
143 (canonicalize-path (path-cat
144 dir
145 ,target))
146 (unless out-of-bounds
147 (push ,item (gethash resolved-path ,hash))))))))
148 (dolist (added added-symlinks)
149 (destructuring-bind (path target) added
150 (process-item added path target add-hash)))
151 (dolist (removed removed-symlinks)
152 (with-slots (path target) removed
153 (process-item removed path target remove-hash)))
154 (macrolet ((move-symlinks (source-name target-name)
155 `(let ((added-list (gethash ,target-name add-hash))
156 (removed-list (gethash ,source-name remove-hash))
157 (symlink-move-pairs))
158 (dolist (added added-list)
159 (dolist (removed removed-list)
160 (push (list added removed (correlate-paths
161 (first added)
162 (mapping-entry-path removed)))
163 symlink-move-pairs)))
164 (setf symlink-move-pairs (sort symlink-move-pairs #'> :key #'third))
165 (dolist (pair symlink-move-pairs)
166 (unless (or (member (first pair) taken-added :test #'eq)
167 (member (second pair) taken-removed :test #'eq))
168 (push (first pair) taken-added)
169 (push (second pair) taken-removed)
170 (push pair moved-symlinks))))))
171 (dolist (file-move-pair moved-files)
172 (destructuring-bind ((target-name hash-2)
173 (source-name hash-1 f-file) confidence)
174 file-move-pair
175 (declare (ignore hash-1 hash-2 f-file confidence))
176 (move-symlinks source-name target-name)))
177 (dolist (entry stable-files)
178 (with-slots (path) entry
179 (move-symlinks path path)))))
180 (values moved-symlinks
181 (set-difference added-symlinks taken-added :test #'eq)
182 (set-difference removed-symlinks taken-removed :test #'eq))))
183
184 (defun mcvs-grab (global-options command-options module subdir)
185 (find-bind (:test #'string= :key #'first)
186 ((branch "r") (trunk "A"))
187 command-options
188 (when (and branch trunk)
189 (error "mcvs-grab: both -r and -A specified."))
190 (when (and (not branch) (not trunk))
191 (error "mcvs-grab: specify branch using -r or main trunk using -A."))
192 (mcvs-checkout module subdir global-options
193 `(("d" ,*this-dir*) ,@(if branch (list branch)))
194 :no-generate t)
195 (in-sandbox-root-dir
196 (let ((mapping (mapping-read *mcvs-map*))
197 invisible-old-paths old-paths
198 old-file-paths new-file-paths
199 old-symlink-paths new-symlink-paths
200 added-files removed-files stable-files
201 added-symlinks removed-symlinks stable-symlinks)
202 (chatter-info "Scanning directory structure.~%")
203 (multiple-value-setq (old-paths invisible-old-paths)
204 (separate-if #'real-path-exists mapping
205 :key #'mapping-entry-path))
206 (dolist (entry old-paths)
207 (with-slots (path) entry
208 (setf path (abstract-to-real-path path))))
209 (multiple-value-setq (old-file-paths old-symlink-paths)
210 (separate :file old-paths
211 :test #'eq
212 :key #'mapping-entry-kind))
213
214 (for-each-file-info (fi *this-dir*)
215 (let* ((path (canonicalize-path (file-name fi))))
216 (cond
217 ((regular-p fi)
218 (push path new-file-paths))
219 ((symlink-p fi)
220 (push path new-symlink-paths))
221 ((directory-p fi)
222 (when (path-equal path *mcvs-dir*)
223 (skip))))))
224
225 (multiple-value-setq (stable-files removed-files added-files)
226 (intersection-difference old-file-paths
227 new-file-paths
228 :key1 #'mapping-entry-path
229 :test #'equal))
230
231 (multiple-value-setq (stable-symlinks removed-symlinks added-symlinks)
232 (intersection-difference old-symlink-paths
233 new-symlink-paths
234 :key1 #'mapping-entry-path
235 :test #'equal))
236
237
238 (cond
239 ((or (null added-files) (null removed-files))
240 (setf added-files (mapcar #'(lambda (name) (list name)) added-files))
241 (setf removed-files (mapcar #'(lambda (entry)
242 (with-slots (id path) entry
243 (list path nil id)))
244 removed-files)))
245 (t (chatter-terse "Analyzing ~a added file~:p.~%" (length added-files))
246 (setf added-files (mapcar #'(lambda (name)
247 (list name (word-hash-file name)))
248 added-files))
249
250 (chatter-terse "Analyzing ~a removed file~:p.~%" (length removed-files))
251 (setf removed-files (mapcar #'(lambda (entry)
252 (with-slots (id path) entry
253 (list path
254 (word-hash-file id) id)))
255 removed-files))
256 (let ((common-word-hash (make-hash-table :test #'equalp)))
257 (determine-common-words common-word-hash added-files)
258 (determine-common-words common-word-hash removed-files)
259 (let ((threshold (max 5 (* 1/5 (+ (length added-files)
260 (length removed-files))))))
261 (eliminate-common-words common-word-hash added-files threshold)
262 (eliminate-common-words common-word-hash removed-files threshold)))
263 (chatter-terse "Determining move candidates.~%")))
264
265 (multiple-value-bind (moved-files added-files removed-files)
266 (if (or (null added-files) (null removed-files))
267 (values nil added-files removed-files)
268 (determine-moved-files added-files
269 removed-files))
270 (when added-symlinks
271 (chatter-terse "Reading ~a added symbolic link~:p.~%"
272 (length added-symlinks))
273 (setf added-symlinks (mapcar #'(lambda (path)
274 (list path (readlink path)))
275 added-symlinks)))
276
277 (multiple-value-bind (moved-symlinks added-symlinks removed-symlinks)
278 (if (or (null added-symlinks)
279 (null removed-symlinks))
280 (values nil added-symlinks removed-symlinks)
281 (determine-moved-symlinks added-symlinks
282 removed-symlinks
283 moved-files
284 stable-files))
285
286 (let ((moved-hash (make-hash-table :test #'equal))
287 (all-hash (make-hash-table :test #'equal))
288 (mapping (mapping-read *mcvs-map*)))
289 (dolist (entry mapping)
290 (setf (gethash (mapping-entry-id entry) all-hash) entry))
291 (when (or moved-files moved-symlinks)
292 (dolist (pair moved-files)
293 (destructuring-bind ((target-name hash-2)
294 (source-name hash-1 f-file) confidence)
295 pair
296 (declare (ignore hash-1 hash-2))
297 (chatter-terse "moving ~a -> ~a (confidence ~a%)~%"
298 source-name target-name (round (* confidence 100)))
299 (setf (gethash f-file moved-hash) target-name)))
300 (dolist (pair moved-symlinks)
301 (destructuring-bind ((target-name symlink-target)
302 source-entry confidence) pair
303 (declare (ignore symlink-target confidence))
304 (with-slots (id (source-name path)) source-entry
305 (chatter-terse "moving symlink ~a -> ~a~%"
306 source-name target-name)
307 (setf (gethash id moved-hash) target-name))))
308
309 (mapc #'(lambda (entry)
310 (with-slots (id path) entry
311 (let ((replacement (gethash id moved-hash)))
312 (if replacement
313 (setf path
314 (real-to-abstract-path replacement))))))
315 mapping)
316 (dolist (entry mapping)
317 (with-slots (kind id path executable) entry
318 (when (and (gethash id moved-hash) (eq kind :file))
319 (unlink id)
320 (link (abstract-to-real-path path) id)
321 (setf executable (executable-p id))))))
322 (dolist (symlink-entry stable-symlinks)
323 (with-slots (kind id path target) symlink-entry
324 (let ((map-entry (gethash id all-hash)))
325 (setf (mapping-entry-target map-entry)
326 (readlink path)))))
327 (dolist (pair moved-symlinks)
328 (with-slots (kind id path target) (second pair)
329 (let ((map-entry (gethash id all-hash)))
330 (setf (mapping-entry-target map-entry)
331 (readlink (mapping-entry-path map-entry))))))
332 (dolist (file-entry stable-files)
333 (with-slots (kind id path) file-entry
334 (let ((map-entry (gethash id all-hash)))
335 (setf (mapping-entry-executable map-entry)
336 (executable-p (mapping-entry-path map-entry))))
337 (when (eq kind :file)
338 (unlink id)
339 (link path id))))
340 (mapping-write mapping *mcvs-map*)
341 (mapping-write mapping *mcvs-map-local*))
342 (when removed-files
343 (mcvs-remove nil (mapcar #'first removed-files) :no-sync t))
344 (when removed-symlinks
345 (mcvs-remove nil (mapcar #'mapping-entry-path removed-symlinks)
346 :no-sync t))
347 (when added-files
348 (mcvs-add nil global-options
349 nil (mapcar #'first added-files)))
350
351 (when added-symlinks
352 (mcvs-add nil global-options
353 nil (mapcar #'first added-symlinks)))))))))
354
355 (defun mcvs-grab-wrapper (global-options command-options args)
356 (flet ((error ()
357 (error "mcvs-grab: specify module name, and optional subdirectory.")))
358 (when (zerop (length args))
359 (error))
360 (destructuring-bind (module &optional subdir &rest superfluous) args
361 (when superfluous
362 (error))
363 (mcvs-grab global-options command-options module subdir))))
364
365 (defconstant *grab-help*
366 "Syntax:
367
368 mcvs grab { -A | -r branch-name } module-name [ subdirectory-path ]
369
370 Options:
371
372 -A Grab to the main trunk.
373 -r branch-name Grab to the specified branch.
374
375 Semantics:
376
377 The grab command intelligently synchronizes a code stream in the repository
378 to an external directory tree. This means that, after the grab, the
379 specified branch or the main trunk will look exactly like that directory
380 tree. The external directory which is grabbed is the current directory,
381 and its subdirectories.
382
383 If the subdirectory-path is specified, then grab will synchronize to the
384 specified subdirectory of the module, rather than to the entire module.
385 This is useful for incorporating updates of third party source code
386 representing individual components of your module.
387
388 The checkout command takes an optional subdirectory-path as well,
389 allowing you to treat a subtree of a module as a module.
390
391 Either the -r option or the -A option must be specified. This forces
392 users to be explicitly clear about where they want the grab to go;
393 the main trunk or a branch. The last thing you want is someone accidentally
394 grabbing something to the main trunk and then committing.
395
396 Grab is safe: it works by converting the current directory to a working copy
397 of the module, which contains a minimized set of local changes which, when
398 committed, will make the target branch look like the current directory. Your
399 files are left untouched, and the repository is untouched. You can now edit
400 files, rename, view differences and so forth. If you are satisfied with the
401 result of the grab, then commit. To throw away the grab, simply remove the
402 MCVS subdirectory. You can then re-run grab with different arguments.")

  ViewVC Help
Powered by ViewVC 1.1.5