/[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.2.1 - (show annotations)
Sat Oct 26 21:09:27 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0, mcvs-0-99, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-1, mcvs-1-0-2
Changes since 1.21: +29 -22 lines
* code/grab.lisp (*grab-help*): Rewritten.

* code/checkout.lisp (*export-help*): Formatted for 80 columns.
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 "both -r and -A specified."))
190 (when (and (not branch) (not trunk))
191 (error "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 "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 is a tool for incorporating external code streams
378 into a Meta-CVS module.
379
380 Grab works by comparing the contents of the current directory and its
381 subdirectories, to the tip of the trunk or a branch of an existing
382 Meta-CVS module. It produces a sandbox which contains a minimized set
383 of local edits that are needed to make the branch or trunk in the repository
384 look exactly like the current directory.
385
386 These local edits have to be committed just like hand-made edits; the grab
387 command itself has no effect on the contents of the repository, and does
388 not change the local directory in any way other than by creating the MCVS
389 subdirectory.
390
391 If it was run with the wrong arguments, the recovery procedure is simply
392 to recursively remove the MCVS subdirectory. Then it's possible to run grab
393 again with different arguments, as necessary.
394
395 If the subdirectory-path is specified, then grab will operate on
396 just that subdirectory of the module, making just that subtree look
397 like the current directory. The result will be a partial sandbox
398 containing local edits to just the visible part of the module.
399 (See the help for the checkout command, which also takes a subdirectory path
400 parameter to create a partial sandbox).
401
402 Either the -A option or the -r option must be specified. This forces
403 users to be explicitly clear about where they want the grab to go;
404 the main trunk or a branch.
405
406 Grab performs no merging whatsoever. It's job is to place a new document
407 baseline at the tip of a code stream. Third party source tracking is
408 performed by grabbing snapshots to a branch, and then merging that branch
409 in the usual way. ")

  ViewVC Help
Powered by ViewVC 1.1.5