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

  ViewVC Help
Powered by ViewVC 1.1.5