/[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.21 - (hide annotations)
Sat Oct 5 18:09:48 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97
Branch point for: mcvs-1-0-branch
Changes since 1.20: +3 -3 lines
Error messages no longer specify prefixes like "mcvs:" or
"mcvs-remove:".

When no restarts are available, the error handler now adds the "mcvs:"
prefix when dumping the error text to the standard error stream,
and also adds a terminating newline.

The inability to write to the MAP file is converted to a more
informative error message.

New --debug option is supported to set the chatter level to 3.
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.17 (let (pairs moved-files taken-added taken-removed)
111 kaz 1.1 (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 kaz 1.17 (push pair moved-files)))
127     (values moved-files
128 kaz 1.1 (set-difference added-files taken-added :test #'eq)
129     (set-difference removed-files taken-removed :test #'eq))))
130    
131 kaz 1.17 (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 kaz 1.15
184 kaz 1.12 (defun mcvs-grab (global-options command-options module subdir)
185 kaz 1.13 (find-bind (:test #'string= :key #'first)
186     ((branch "r") (trunk "A"))
187     command-options
188     (when (and branch trunk)
189 kaz 1.21 (error "both -r and -A specified."))
190 kaz 1.13 (when (and (not branch) (not trunk))
191 kaz 1.21 (error "specify branch using -r or main trunk using -A."))
192 kaz 1.12 (mcvs-checkout module subdir global-options
193 kaz 1.13 `(("d" ,*this-dir*) ,@(if branch (list branch)))
194 kaz 1.12 :no-generate t)
195     (in-sandbox-root-dir
196 kaz 1.15 (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 kaz 1.12 (chatter-info "Scanning directory structure.~%")
203     (multiple-value-setq (old-paths invisible-old-paths)
204 kaz 1.15 (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 kaz 1.9
214 kaz 1.12 (for-each-file-info (fi *this-dir*)
215     (let* ((path (canonicalize-path (file-name fi))))
216     (cond
217     ((regular-p fi)
218 kaz 1.15 (push path new-file-paths))
219     ((symlink-p fi)
220     (push path new-symlink-paths))
221 kaz 1.12 ((directory-p fi)
222     (when (path-equal path *mcvs-dir*)
223     (skip))))))
224 kaz 1.1
225 kaz 1.12 (multiple-value-setq (stable-files removed-files added-files)
226 kaz 1.15 (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 kaz 1.12 :test #'equal))
236 kaz 1.15
237    
238 kaz 1.12 (cond
239     ((or (null added-files) (null removed-files))
240     (setf added-files (mapcar #'(lambda (name) (list name)) added-files))
241 kaz 1.15 (setf removed-files (mapcar #'(lambda (entry)
242     (with-slots (id path) entry
243     (list path nil id)))
244 kaz 1.12 removed-files)))
245 kaz 1.18 (t (chatter-terse "Analyzing ~a added file~:p.~%" (length added-files))
246 kaz 1.12 (setf added-files (mapcar #'(lambda (name)
247     (list name (word-hash-file name)))
248     added-files))
249 kaz 1.1
250 kaz 1.18 (chatter-terse "Analyzing ~a removed file~:p.~%" (length removed-files))
251 kaz 1.15 (setf removed-files (mapcar #'(lambda (entry)
252     (with-slots (id path) entry
253     (list path
254     (word-hash-file id) id)))
255 kaz 1.12 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 kaz 1.15
265 kaz 1.12 (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 kaz 1.15 (determine-moved-files added-files
269     removed-files))
270     (when added-symlinks
271 kaz 1.18 (chatter-terse "Reading ~a added symbolic link~:p.~%"
272 kaz 1.15 (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 kaz 1.17 moved-files
284     stable-files))
285 kaz 1.15
286 kaz 1.16 (let ((moved-hash (make-hash-table :test #'equal))
287     (all-hash (make-hash-table :test #'equal))
288 kaz 1.15 (mapping (mapping-read *mcvs-map*)))
289 kaz 1.16 (dolist (entry mapping)
290     (setf (gethash (mapping-entry-id entry) all-hash) entry))
291 kaz 1.15 (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 kaz 1.16 (setf (gethash f-file moved-hash) target-name)))
300 kaz 1.15 (dolist (pair moved-symlinks)
301 kaz 1.17 (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 kaz 1.15
309     (mapc #'(lambda (entry)
310     (with-slots (id path) entry
311 kaz 1.16 (let ((replacement (gethash id moved-hash)))
312 kaz 1.15 (if replacement
313     (setf path
314     (real-to-abstract-path replacement))))))
315     mapping)
316     (dolist (entry mapping)
317 kaz 1.20 (with-slots (kind id path executable) entry
318 kaz 1.16 (when (and (gethash id moved-hash) (eq kind :file))
319 kaz 1.15 (unlink id)
320 kaz 1.20 (link (abstract-to-real-path path) id)
321     (setf executable (executable-p id))))))
322 kaz 1.16 (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 kaz 1.17 (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 kaz 1.20 (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 kaz 1.16 (mapping-write mapping *mcvs-map*)
341     (mapping-write mapping *mcvs-map-local*))
342 kaz 1.15 (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 kaz 1.1
355     (defun mcvs-grab-wrapper (global-options command-options args)
356 kaz 1.9 (flet ((error ()
357 kaz 1.21 (error "specify module name, and optional subdirectory.")))
358 kaz 1.12 (when (zerop (length args))
359 kaz 1.9 (error))
360 kaz 1.12 (destructuring-bind (module &optional subdir &rest superfluous) args
361 kaz 1.9 (when superfluous
362     (error))
363 kaz 1.12 (mcvs-grab global-options command-options module subdir))))
364 kaz 1.19
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