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

  ViewVC Help
Powered by ViewVC 1.1.5