/[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.30 - (show annotations)
Tue Nov 28 04:12:08 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.29: +13 -13 lines
Getting rid of mcvs- prefixes.

* code/package.lisp (defpackage): shadow the merge symbol.

* code/purge.lisp (mcvs-purge): renamed to purge
(mcvs-purge-wrapper): renamed to purge-wrapper

* code/restore.lisp (mcvs-restore): renamed to restore
(mcvs-restore-wrapper): renamed to restore-wrapper

* code/update.lisp (mcvs-update): renamed to update
(mcvs-update-wrapper): renamed to update-wrapper

* code/main.lisp (mcvs-help): renamed to help
(*mcvs-command-table*): renamed to *command-table*
(mcvs-terminate catch): renamed to terminate.

* code/execute.lisp (mcvs-execute): renamed to execute

* code/move.lisp (mcvs-move): renamed to move
(mcvs-move-wrapper): renamed to move-wrapper

* code/grab.lisp (mcvs-grab): renamed to grab
(mcvs-grab-wrapper): renamed to grab-wrapper

* code/prop.lisp (mcvs-prop): renamed to prop
(mcvs-prop-wrapper): renamed to prop-wrapper

* code/filt.lisp (mcvs-filt-loop): renamed to filt-loop
(mcvs-filt): renamed to filt
(mcvs-remote-filt): renamed to remote-filt
(mcvs-filt-wrapper): renamed to filt-wrapper
(mcvs-remote-filt-wrapper): renamed to remote-filt-wrapper

* code/branch.lisp (mcvs-branch): renamed to branch
(mcvs-branch-wrapper): renamed to branch-wrapper
(mcvs-merge): renamed to merge
(mcvs-list-branches): renamed to list-branches
(mcvs-merge-wrapper): renamed to merge-wrapper
(mcvs-remerge-wrapper): renamed to remerge-wrapper
(mcvs-list-branches-wrapper): renamed to list-branches-wrapper
(mcvs-switch-wrapper): renamed to switch-wrapper

* code/link.lisp (mcvs-link): renamed to ln
(mcvs-link-wrapper): renamed to link-wrapper

* code/watch.lisp (mcvs-watch): renamed to watch
(mcvs-watch-wrapper): renamed to watch-wrapper

* code/add.lisp (mcvs-add): renamed to add
(mcvs-add-wrapper): renamed to add-wrapper

* code/remove.lisp (mcvs-remove): renamed to rm
(mcvs-remove-wrapper): renamed to remove-wrapper

* code/convert.lisp (mcvs-convert): renamed to convert
(mcvs-convert-wrapper): renamed to convert-wrapper

* code/error.lisp (mcvs-terminate): renamed to terminate
(mcvs-error-handler): renamed to error-handler
(*mcvs-error-treatment*): renamed to *error-treatment*
(*mcvs-errors-occured-p*): renamed to *errors-occured-p*

* code/checkout.lisp (mcvs-checkout): renamed to checkout
(mcvs-checkout-wrapper): renamed to checkout-wrapper
(mcvs-export-wrapper): renamed to export-wrapper

* code/generic.lisp (mcvs-generic): renamed to generic
(mcvs-commit-wrapper): renamed to commit-wrapper
(mcvs-diff-wrapper): renamed to diff-wrapper
(mcvs-tag-wrapper): renamed to tag-wrapper
(mcvs-log-wrapper): renamed to log-wrapper
(mcvs-status-wrapper): renamed to status-wrapper
(mcvs-annotate-wrapper): renamed to annotate-wrapper
(mcvs-watchers-wrapper): renamed to watchers-wrapper
(mcvs-edit-wrapper): renamed to edit-wrapper
(mcvs-unedit-wrapper): renamed to unedit-wrapper
(mcvs-editors-wrapper): renamed to editors-wrapper
(mcvs-sync-to-wrapper): renamed to sync-to-wrapper
(mcvs-sync-from-wrapper): renamed to sync-from-wrapper

* code/create.lisp (mcvs-create): renamed to create
(mcvs-create-wrapper): renamed to create-wrapper

* code/remap.lisp (mcvs-remap): renamed to remap
(mcvs-remap-wrapper): renamed to remap-wrapper

* code/mapping.lisp (mcvs-locate): renamed to locate
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 (in-package :meta-cvs)
6
7 (defun read-word-hash (&optional (byte-stream t))
8 (let ((word-hash (make-hash-table :test #'equalp))
9 token
10 (state :junk))
11 (labels ((new-token ()
12 (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 (let ((copy (make-string (length token))))
21 (replace copy token)
22 (setf (gethash copy word-hash) copy)))))
23 (do ((byte (read-byte byte-stream nil)
24 (read-byte byte-stream nil)))
25 ((null byte) (if (eq state :word) (save-token)) word-hash)
26 (let ((ch (code-char byte)))
27 (ecase state
28 ((:junk)
29 (when (or (alpha-char-p ch) (digit-char-p ch)
30 (char= ch #\_))
31 (new-token)
32 (vector-push-extend ch token)
33 (setf state :word)))
34 ((:word)
35 (cond
36 ((or (alpha-char-p ch) (digit-char-p ch)
37 (char= ch #\_) (char= ch #\-))
38 (vector-push-extend ch token))
39 (t (setf state :junk)
40 (save-token))))))))))
41
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 (defun correlate-word-hashes (hash-1 hash-2)
49 (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 (let ((total-count (- (+ hc-1 hc-2) common-count)))
61 (if (zerop total-count)
62 0
63 (/ common-count total-count))))))
64
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 (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 (defun determine-moved-files (added-files removed-files)
100 (let (pairs moved-files taken-added taken-removed)
101 (dolist (added added-files)
102 (dolist (removed removed-files)
103 (let ((correlation (correlate-word-hashes (second added)
104 (second removed))))
105 (when (>= correlation 30/100)
106 (push (list added removed
107 (* correlation (correlate-paths (first added)
108 (first removed))))
109 pairs)))))
110 (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 (push pair moved-files)))
117 (values moved-files
118 (set-difference added-files taken-added :test #'eq)
119 (set-difference removed-files taken-removed :test #'eq))))
120
121 (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
174 (defun grab (global-options command-options module subdir)
175 (find-bind (:test #'string= :key #'first)
176 ((branch "r") (trunk "A"))
177 command-options
178 (when (and branch trunk)
179 (error "both -r and -A specified."))
180 (when (and (not branch) (not trunk))
181 (error "specify branch using -r or main trunk using -A."))
182 (checkout module subdir global-options
183 `(("d" ,*this-dir*) ,@(if branch (list branch)))
184 :no-generate t)
185 (in-sandbox-root-dir
186 (let ((mapping (mapping-read *mcvs-map*))
187 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 (chatter-info "Scanning directory structure.~%")
193 (multiple-value-setq (old-paths invisible-old-paths)
194 (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
204 (for-each-file-info (fi *this-dir*)
205 (let* ((path (canonicalize-path (file-name fi))))
206 (cond
207 ((regular-p fi)
208 (push path new-file-paths))
209 ((symlink-p fi)
210 (push path new-symlink-paths))
211 ((directory-p fi)
212 (when (path-equal path *mcvs-dir*)
213 (skip))))))
214
215 (multiple-value-setq (stable-files removed-files added-files)
216 (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 :test #'equal))
226
227
228 (cond
229 ((or (null added-files) (null removed-files))
230 (setf added-files (mapcar #'(lambda (name) (list name)) added-files))
231 (setf removed-files (mapcar #'(lambda (entry)
232 (with-slots (id path) entry
233 (list path nil id)))
234 removed-files)))
235 (t (chatter-terse "Analyzing ~a added file~:p.~%" (length added-files))
236 (setf added-files (mapcar #'(lambda (name)
237 (list name (word-hash-file name)))
238 added-files))
239
240 (chatter-terse "Analyzing ~a removed file~:p.~%" (length removed-files))
241 (setf removed-files (mapcar #'(lambda (entry)
242 (with-slots (id path) entry
243 (list path
244 (word-hash-file id) id)))
245 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
255 (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 (determine-moved-files added-files
259 removed-files))
260 (when added-symlinks
261 (chatter-terse "Reading ~a added symbolic link~:p.~%"
262 (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 moved-files
274 stable-files))
275
276 (let ((moved-hash (make-hash-table :test #'equal))
277 (all-hash (make-hash-table :test #'equal))
278 (mapping (mapping-read *mcvs-map*)))
279 (dolist (entry mapping)
280 (setf (gethash (mapping-entry-id entry) all-hash) entry))
281 (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 (setf (gethash f-file moved-hash) target-name)))
290 (dolist (pair moved-symlinks)
291 (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
299 (mapc #'(lambda (entry)
300 (with-slots (id path) entry
301 (let ((replacement (gethash id moved-hash)))
302 (if replacement
303 (setf path
304 (real-to-abstract-path replacement))))))
305 mapping)
306 (dolist (entry mapping)
307 (with-slots (kind id path executable) entry
308 (when (and (gethash id moved-hash) (eq kind :file))
309 (unlink id)
310 (link (abstract-to-real-path path) id)
311 (setf executable (executable-p id))))))
312 (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 (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 (readlink (abstract-to-real-path
322 (mapping-entry-path map-entry)))))))
323 (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 (executable-p path)))
328 (when (eq kind :file)
329 (unlink id)
330 (link path id))))
331 (mapping-write mapping *mcvs-map*)
332 (mapping-write mapping *mcvs-map-local*))
333 (when removed-files
334 (rm nil (mapcar #'first removed-files) :no-sync t))
335 (when removed-symlinks
336 (rm nil (mapcar #'mapping-entry-path removed-symlinks)
337 :no-sync t))
338 (when added-files
339 (add nil global-options
340 nil (mapcar #'first added-files)))
341
342 (when added-symlinks
343 (add nil global-options
344 nil (mapcar #'first added-symlinks)))))))))
345
346 (defun grab-wrapper (global-options command-options args)
347 (flet ((error ()
348 (error "specify module name, and optional subdirectory.")))
349 (when (zerop (length args))
350 (error))
351 (destructuring-bind (module &optional subdir &rest superfluous) args
352 (when superfluous
353 (error))
354 (grab global-options command-options module subdir))))
355
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 The grab command is a tool for incorporating external code streams
369 into a Meta-CVS module.
370
371 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
377 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 users to be explicitly clear about where they want the grab to go;
395 the main trunk or a branch.
396
397 Grab performs no merging whatsoever. Its job is to place a new document
398 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