/[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.15 - (hide annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-22
Changes since 1.14: +110 -58 lines
Merging symlink-branch to main trunk.
1 kaz 1.3 ;;; 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 kaz 1.1 (require "dirwalk")
6     (require "system")
7 kaz 1.2 (require "split")
8     (require "seqfuncs")
9 kaz 1.1 (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 kaz 1.4 (let ((word-hash (make-hash-table :test #'equalp))
20 kaz 1.1 token
21     (state :junk))
22     (labels ((new-token ()
23 kaz 1.2 (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 kaz 1.1 (do ((byte (read-byte byte-stream nil)
34     (read-byte byte-stream nil)))
35 kaz 1.2 ((null byte) (if (eq state :word) (save-token)) word-hash)
36 kaz 1.1 (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 kaz 1.2 (new-token)
42 kaz 1.1 (vector-push-extend ch token)
43     (setf state :word)))
44     ((:word)
45     (cond
46     ((or (alpha-char-p ch) (digit-char-p ch)
47 kaz 1.6 (char= ch #\_) (char= ch #\-))
48 kaz 1.1 (vector-push-extend ch token))
49     (t (setf state :junk)
50 kaz 1.2 (save-token))))))))))
51 kaz 1.1
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 kaz 1.2 (defun correlate-word-hashes (hash-1 hash-2)
59 kaz 1.1 (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 kaz 1.14 (let ((total-count (- (+ hc-1 hc-2) common-count)))
71     (if (zerop total-count)
72 kaz 1.1 0
73 kaz 1.14 (/ common-count total-count))))))
74 kaz 1.2
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 kaz 1.4 (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 kaz 1.15 (defun determine-moved-files (added-files removed-files)
110 kaz 1.1 (let (pairs candidates taken-added taken-removed)
111     (dolist (added added-files)
112     (dolist (removed removed-files)
113 kaz 1.2 (let ((correlation (correlate-word-hashes (second added)
114     (second removed))))
115 kaz 1.5 (when (>= correlation 30/100)
116 kaz 1.2 (push (list added removed
117     (* correlation (correlate-paths (first added)
118     (first removed))))
119     pairs)))))
120 kaz 1.1 (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 candidates)))
127     (values candidates
128     (set-difference added-files taken-added :test #'eq)
129     (set-difference removed-files taken-removed :test #'eq))))
130    
131 kaz 1.15 (defun determine-moved-symlinks (added-symlinks removed-symlinks moved-files)
132     (declare (ignore moved-files))
133     (values nil added-symlinks removed-symlinks))
134    
135 kaz 1.12 (defun mcvs-grab (global-options command-options module subdir)
136 kaz 1.13 (find-bind (:test #'string= :key #'first)
137     ((branch "r") (trunk "A"))
138     command-options
139     (when (and branch trunk)
140     (error "mcvs-grab: both -r and -A specified."))
141     (when (and (not branch) (not trunk))
142     (error "mcvs-grab: specify branch using -r or main trunk using -A."))
143 kaz 1.12 (mcvs-checkout module subdir global-options
144 kaz 1.13 `(("d" ,*this-dir*) ,@(if branch (list branch)))
145 kaz 1.12 :no-generate t)
146     (in-sandbox-root-dir
147 kaz 1.15 (let ((mapping (mapping-read *mcvs-map*))
148     invisible-old-paths old-paths
149     old-file-paths new-file-paths
150     old-symlink-paths new-symlink-paths
151     added-files removed-files stable-files
152     added-symlinks removed-symlinks stable-symlinks)
153 kaz 1.12 (chatter-info "Scanning directory structure.~%")
154     (multiple-value-setq (old-paths invisible-old-paths)
155 kaz 1.15 (separate-if #'real-path-exists mapping
156     :key #'mapping-entry-path))
157     (dolist (entry old-paths)
158     (with-slots (path) entry
159     (setf path (abstract-to-real-path path))))
160     (multiple-value-setq (old-file-paths old-symlink-paths)
161     (separate :file old-paths
162     :test #'eq
163     :key #'mapping-entry-kind))
164 kaz 1.9
165 kaz 1.12 (for-each-file-info (fi *this-dir*)
166     (let* ((path (canonicalize-path (file-name fi))))
167     (cond
168     ((regular-p fi)
169 kaz 1.15 (push path new-file-paths))
170     ((symlink-p fi)
171     (push path new-symlink-paths))
172 kaz 1.12 ((directory-p fi)
173     (when (path-equal path *mcvs-dir*)
174     (skip))))))
175 kaz 1.1
176 kaz 1.12 (multiple-value-setq (stable-files removed-files added-files)
177 kaz 1.15 (intersection-difference old-file-paths
178     new-file-paths
179     :key1 #'mapping-entry-path
180     :test #'equal))
181    
182     (multiple-value-setq (stable-symlinks removed-symlinks added-symlinks)
183     (intersection-difference old-symlink-paths
184     new-symlink-paths
185     :key1 #'mapping-entry-path
186 kaz 1.12 :test #'equal))
187 kaz 1.15
188    
189 kaz 1.12 (cond
190     ((or (null added-files) (null removed-files))
191     (setf added-files (mapcar #'(lambda (name) (list name)) added-files))
192 kaz 1.15 (setf removed-files (mapcar #'(lambda (entry)
193     (with-slots (id path) entry
194     (list path nil id)))
195 kaz 1.12 removed-files)))
196     (t (chatter-terse "Analyzing ~a added files.~%" (length added-files))
197     (setf added-files (mapcar #'(lambda (name)
198     (list name (word-hash-file name)))
199     added-files))
200 kaz 1.1
201 kaz 1.12 (chatter-terse "Analyzing ~a removed files.~%" (length removed-files))
202 kaz 1.15 (setf removed-files (mapcar #'(lambda (entry)
203     (with-slots (id path) entry
204     (list path
205     (word-hash-file id) id)))
206 kaz 1.12 removed-files))
207     (let ((common-word-hash (make-hash-table :test #'equalp)))
208     (determine-common-words common-word-hash added-files)
209     (determine-common-words common-word-hash removed-files)
210     (let ((threshold (max 5 (* 1/5 (+ (length added-files)
211     (length removed-files))))))
212     (eliminate-common-words common-word-hash added-files threshold)
213     (eliminate-common-words common-word-hash removed-files threshold)))
214     (chatter-terse "Determining move candidates.~%")))
215 kaz 1.15
216 kaz 1.12 (multiple-value-bind (moved-files added-files removed-files)
217     (if (or (null added-files) (null removed-files))
218     (values nil added-files removed-files)
219 kaz 1.15 (determine-moved-files added-files
220     removed-files))
221     (when added-symlinks
222     (chatter-terse "Reading ~a added symbolic links.~%"
223     (length added-symlinks))
224     (setf added-symlinks (mapcar #'(lambda (path)
225     (list path (readlink path)))
226     added-symlinks)))
227    
228     (multiple-value-bind (moved-symlinks added-symlinks removed-symlinks)
229     (if (or (null added-symlinks)
230     (null removed-symlinks))
231     (values nil added-symlinks removed-symlinks)
232     (determine-moved-symlinks added-symlinks
233     removed-symlinks
234     moved-files))
235    
236     (let ((f-hash (make-hash-table :test #'equal))
237     (mapping (mapping-read *mcvs-map*)))
238     (when (or moved-files moved-symlinks)
239     (dolist (pair moved-files)
240     (destructuring-bind ((target-name hash-2)
241     (source-name hash-1 f-file) confidence)
242     pair
243     (declare (ignore hash-1 hash-2))
244     (chatter-terse "moving ~a -> ~a (confidence ~a%)~%"
245     source-name target-name (round (* confidence 100)))
246     (setf (gethash f-file f-hash) target-name)))
247     (dolist (pair moved-symlinks)
248     (destructuring-bind ((target-name symlink-target)
249     source-entry) pair
250     (declare (ignore symlink-target))
251     (with-slots (id (source-name path)) source-entry
252     (chatter-terse "moving symlink ~a -> ~a~%"
253     source-name target-name)
254     (setf (gethash id f-hash) target-name))))
255    
256     (mapc #'(lambda (entry)
257     (with-slots (id path) entry
258     (let ((replacement (gethash id f-hash)))
259     (if replacement
260     (setf path
261     (real-to-abstract-path replacement))))))
262     mapping)
263     (mapping-write mapping *mcvs-map*)
264     (dolist (entry mapping)
265     (with-slots (kind id path) entry
266     (when (and (gethash id f-hash) (eq kind :file))
267     (unlink id)
268     (link (abstract-to-real-path path) id))))
269     (mapping-write mapping *mcvs-map-local*))
270     (dolist (entry stable-files)
271     (with-slots (kind id path) entry
272     (when (eq kind :file)
273     (unlink id)
274     (link path id)))))
275     (when removed-files
276     (mcvs-remove nil (mapcar #'first removed-files) :no-sync t))
277     (when removed-symlinks
278     (mcvs-remove nil (mapcar #'mapping-entry-path removed-symlinks)
279     :no-sync t))
280     (when added-files
281     (mcvs-add nil global-options
282     nil (mapcar #'first added-files)))
283    
284     (when added-symlinks
285     (mcvs-add nil global-options
286     nil (mapcar #'first added-symlinks)))))))))
287 kaz 1.1
288     (defun mcvs-grab-wrapper (global-options command-options args)
289 kaz 1.9 (flet ((error ()
290 kaz 1.12 (error "mcvs-grab: specify module name, and optional subdirectory.")))
291     (when (zerop (length args))
292 kaz 1.9 (error))
293 kaz 1.12 (destructuring-bind (module &optional subdir &rest superfluous) args
294 kaz 1.9 (when superfluous
295     (error))
296 kaz 1.12 (mcvs-grab global-options command-options module subdir))))

  ViewVC Help
Powered by ViewVC 1.1.5