/[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.18 - (show annotations)
Sun Sep 8 01:34:53 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24
Changes since 1.17: +3 -3 lines
Eliminate inappropriate pluralization in messages.

* code/grab.lisp (mcvs-grab): Use ~:p to substitute a 's'
if the parameter is other than 1.

* code/options.lisp (parse-opt): Likewise.
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) entry
318 (when (and (gethash id moved-hash) (eq kind :file))
319 (unlink id)
320 (link (abstract-to-real-path path) id)))))
321 (dolist (symlink-entry stable-symlinks)
322 (with-slots (kind id path target) symlink-entry
323 (let ((map-entry (gethash id all-hash)))
324 (setf (mapping-entry-target map-entry)
325 (readlink path)))))
326 (dolist (pair moved-symlinks)
327 (with-slots (kind id path target) (second pair)
328 (let ((map-entry (gethash id all-hash)))
329 (setf (mapping-entry-target map-entry)
330 (readlink (mapping-entry-path map-entry))))))
331 (mapping-write mapping *mcvs-map*)
332 (mapping-write mapping *mcvs-map-local*))
333 (dolist (entry stable-files)
334 (with-slots (kind id path) entry
335 (when (eq kind :file)
336 (unlink id)
337 (link path id))))
338 (when removed-files
339 (mcvs-remove nil (mapcar #'first removed-files) :no-sync t))
340 (when removed-symlinks
341 (mcvs-remove nil (mapcar #'mapping-entry-path removed-symlinks)
342 :no-sync t))
343 (when added-files
344 (mcvs-add nil global-options
345 nil (mapcar #'first added-files)))
346
347 (when added-symlinks
348 (mcvs-add nil global-options
349 nil (mapcar #'first added-symlinks)))))))))
350
351 (defun mcvs-grab-wrapper (global-options command-options args)
352 (flet ((error ()
353 (error "mcvs-grab: specify module name, and optional subdirectory.")))
354 (when (zerop (length args))
355 (error))
356 (destructuring-bind (module &optional subdir &rest superfluous) args
357 (when superfluous
358 (error))
359 (mcvs-grab global-options command-options module subdir))))

  ViewVC Help
Powered by ViewVC 1.1.5