/[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.31 - (hide annotations)
Tue Nov 28 07:47:21 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.30: +5 -5 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5