/[meta-cvs]/meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp
ViewVC logotype

Diff of /meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14.2.1 by kaz, Sat Aug 31 19:26:29 2002 UTC revision 1.31 by kaz, Tue Nov 28 07:47:21 2006 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5  (require "dirwalk")  (in-package :meta-cvs)
 (require "system")  
 (require "split")  
 (require "seqfuncs")  
 (require "mapping")  
 (require "types")  
 (require "chatter")  
 (require "options")  
 (require "checkout")  
 (require "remove")  
 (require "add")  
 (provide "grab")  
6    
7  (defun read-word-hash (&optional (byte-stream t))  (defun read-word-hash (&optional (byte-stream t))
8    (let ((word-hash (make-hash-table :test #'equalp))    (let ((word-hash (make-hash-table :test #'equalp))
# Line 28  Line 17 
17                                           :fill-pointer 0))))                                           :fill-pointer 0))))
18               (save-token ()               (save-token ()
19                 (unless (gethash token word-hash)                 (unless (gethash token word-hash)
20                   (setf (gethash token word-hash) token)                   (let ((copy (make-string (length token))))
21                   (setf token nil))))                     (replace copy token)
22                       (setf (gethash copy word-hash) copy)))))
23        (do ((byte (read-byte byte-stream nil)        (do ((byte (read-byte byte-stream nil)
24                   (read-byte byte-stream nil)))                   (read-byte byte-stream nil)))
25            ((null byte) (if (eq state :word) (save-token)) word-hash)            ((null byte) (if (eq state :word) (save-token)) word-hash)
26          (let ((ch (int-char byte)))          (let ((ch (code-char byte)))
27            (ecase state            (ecase state
28              ((:junk)              ((:junk)
29                (when (or (alpha-char-p ch) (digit-char-p ch)                (when (or (alpha-char-p ch) (digit-char-p ch)
# Line 107  Line 97 
97               (second file))))               (second file))))
98    
99  (defun determine-moved-files (added-files removed-files)  (defun determine-moved-files (added-files removed-files)
100    (let (pairs candidates taken-added taken-removed)    (let (pairs moved-files taken-added taken-removed)
101      (dolist (added added-files)      (dolist (added added-files)
102        (dolist (removed removed-files)        (dolist (removed removed-files)
103          (let ((correlation (correlate-word-hashes (second added)          (let ((correlation (correlate-word-hashes (second added)
# Line 123  Line 113 
113                    (member (second pair) taken-removed :test #'eq))                    (member (second pair) taken-removed :test #'eq))
114          (push (first pair) taken-added)          (push (first pair) taken-added)
115          (push (second pair) taken-removed)          (push (second pair) taken-removed)
116          (push pair candidates)))          (push pair moved-files)))
117      (values candidates      (values moved-files
118              (set-difference added-files taken-added :test #'eq)              (set-difference added-files taken-added :test #'eq)
119              (set-difference removed-files taken-removed :test #'eq))))              (set-difference removed-files taken-removed :test #'eq))))
120    
121  (defun determine-moved-symlinks (added-symlinks removed-symlinks moved-files)  (defun determine-moved-symlinks (added-symlinks removed-symlinks moved-files
122    (declare (ignore moved-files))                                   stable-files)
123    (values nil added-symlinks removed-symlinks))    (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 mcvs-grab (global-options command-options module subdir)  (defun grab (global-options command-options module subdir)
175    (find-bind (:test #'string= :key #'first)    (find-bind (:test #'string= :key #'first)
176               ((branch "r") (trunk "A"))               ((branch "r") (trunk "A"))
177               command-options               command-options
178      (when (and branch trunk)      (when (and branch trunk)
179        (error "mcvs-grab: both -r and -A specified."))        (error "both -r and -A specified."))
180      (when (and (not branch) (not trunk))      (when (and (not branch) (not trunk))
181        (error "mcvs-grab: specify branch using -r or main trunk using -A."))        (error "specify branch using -r or main trunk using -A."))
182      (mcvs-checkout module subdir global-options      (checkout module subdir global-options
183                     `(("d" ,*this-dir*) ,@(if branch (list branch)))                `(("d" ,*this-dir*) ,@(if branch (list branch)))
184                     :no-generate t)                :no-generate t)
185      (in-sandbox-root-dir      (in-sandbox-root-dir
186        (let ((mapping (mapping-read *mcvs-map*))        (let ((mapping (mapping-read *map-path*))
187              invisible-old-paths old-paths              invisible-old-paths old-paths
188              old-file-paths new-file-paths              old-file-paths new-file-paths
189              old-symlink-paths new-symlink-paths              old-symlink-paths new-symlink-paths
# Line 170  Line 209 
209                ((symlink-p fi)                ((symlink-p fi)
210                   (push path new-symlink-paths))                   (push path new-symlink-paths))
211                ((directory-p fi)                ((directory-p fi)
212                  (when (path-equal path *mcvs-dir*)                  (when (path-equal path *admin-dir*)
213                    (skip))))))                    (skip))))))
214    
215          (multiple-value-setq (stable-files removed-files added-files)          (multiple-value-setq (stable-files removed-files added-files)
# Line 193  Line 232 
232                                               (with-slots (id path) entry                                               (with-slots (id path) entry
233                                                 (list path nil id)))                                                 (list path nil id)))
234                                           removed-files)))                                           removed-files)))
235            (t (chatter-terse "Analyzing ~a added files.~%" (length added-files))            (t (chatter-terse "Analyzing ~a added file~:p.~%" (length added-files))
236               (setf added-files (mapcar #'(lambda (name)               (setf added-files (mapcar #'(lambda (name)
237                                          (list name (word-hash-file name)))                                          (list name (word-hash-file name)))
238                                      added-files))                                      added-files))
239    
240               (chatter-terse "Analyzing ~a removed files.~%" (length removed-files))               (chatter-terse "Analyzing ~a removed file~:p.~%" (length removed-files))
241               (setf removed-files (mapcar #'(lambda (entry)               (setf removed-files (mapcar #'(lambda (entry)
242                                               (with-slots (id path) entry                                               (with-slots (id path) entry
243                                                 (list path                                                 (list path
# Line 219  Line 258 
258                                 (determine-moved-files added-files                                 (determine-moved-files added-files
259                                                        removed-files))                                                        removed-files))
260            (when added-symlinks            (when added-symlinks
261              (chatter-terse "Reading ~a added symbolic links.~%"              (chatter-terse "Reading ~a added symbolic link~:p.~%"
262                             (length added-symlinks))                             (length added-symlinks))
263              (setf added-symlinks (mapcar #'(lambda (path)              (setf added-symlinks (mapcar #'(lambda (path)
264                                               (list path (readlink path)))                                               (list path (readlink path)))
# Line 231  Line 270 
270                                   (values nil added-symlinks removed-symlinks)                                   (values nil added-symlinks removed-symlinks)
271                                   (determine-moved-symlinks added-symlinks                                   (determine-moved-symlinks added-symlinks
272                                                             removed-symlinks                                                             removed-symlinks
273                                                             moved-files))                                                             moved-files
274                                                               stable-files))
275    
276              (let ((f-hash (make-hash-table :test #'equal))              (let ((moved-hash (make-hash-table :test #'equal))
277                    (mapping (mapping-read *mcvs-map*)))                    (all-hash (make-hash-table :test #'equal))
278                      (mapping (mapping-read *map-path*)))
279                  (dolist (entry mapping)
280                    (setf (gethash (mapping-entry-id entry) all-hash) entry))
281                (when (or moved-files moved-symlinks)                (when (or moved-files moved-symlinks)
282                  (dolist (pair moved-files)                  (dolist (pair moved-files)
283                    (destructuring-bind ((target-name hash-2)                    (destructuring-bind ((target-name hash-2)
# Line 243  Line 286 
286                      (declare (ignore hash-1 hash-2))                      (declare (ignore hash-1 hash-2))
287                      (chatter-terse "moving ~a -> ~a (confidence ~a%)~%"                      (chatter-terse "moving ~a -> ~a (confidence ~a%)~%"
288                              source-name target-name (round (* confidence 100)))                              source-name target-name (round (* confidence 100)))
289                      (setf (gethash f-file f-hash) target-name)))                      (setf (gethash f-file moved-hash) target-name)))
290                  (dolist (pair moved-symlinks)                  (dolist (pair moved-symlinks)
291                      (destructuring-bind ((target-name symlink-target)                    (destructuring-bind ((target-name symlink-target)
292                                           source-entry) pair                                         source-entry confidence) pair
293                        (declare (ignore symlink-target))                      (declare (ignore symlink-target confidence))
294                        (with-slots (id (source-name path)) source-entry                      (with-slots (id (source-name path)) source-entry
295                          (chatter-terse "moving symlink ~a -> ~a~%"                        (chatter-terse "moving symlink ~a -> ~a~%"
296                                         source-name target-name)                                       source-name target-name)
297                          (setf (gethash id f-hash) target-name))))                        (setf (gethash id moved-hash) target-name))))
298    
299                  (mapc #'(lambda (entry)                  (mapc #'(lambda (entry)
300                            (with-slots (id path) entry                            (with-slots (id path) entry
301                              (let ((replacement (gethash id f-hash)))                              (let ((replacement (gethash id moved-hash)))
302                                (if replacement                                (if replacement
303                                  (setf path                                  (setf path
304                                        (real-to-abstract-path replacement))))))                                        (real-to-abstract-path replacement))))))
305                        mapping)                        mapping)
                 (mapping-write mapping *mcvs-map*)  
306                  (dolist (entry mapping)                  (dolist (entry mapping)
307                    (with-slots (kind id path) entry                    (with-slots (kind id path executable) entry
308                      (when (and (gethash id f-hash) (eq kind :file))                      (when (and (gethash id moved-hash) (eq kind :file))
309                        (unlink id)                        (unlink id)
310                        (link (abstract-to-real-path path) id))))                        (link (abstract-to-real-path path) id)
311                  (mapping-write mapping *mcvs-map-local*))                        (setf executable (executable-p id))))))
312                (dolist (entry stable-files)                (dolist (symlink-entry stable-symlinks)
313                  (with-slots (kind id path) entry                  (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)                    (when (eq kind :file)
329                      (unlink id)                      (unlink id)
330                      (link path id)))))                      (link path id))))
331                  (mapping-write mapping *map-path*)
332                  (mapping-write mapping *map-local-path*))
333              (when removed-files              (when removed-files
334                (mcvs-remove nil (mapcar #'first removed-files) :no-sync t))                (rm nil (mapcar #'first removed-files) :no-sync t))
335              (when removed-symlinks              (when removed-symlinks
336                (mcvs-remove nil (mapcar #'mapping-entry-path removed-symlinks)                (rm nil (mapcar #'mapping-entry-path removed-symlinks)
337                             :no-sync t))                        :no-sync t))
338              (when added-files              (when added-files
339                (mcvs-add nil global-options                (add nil global-options
340                          nil (mapcar #'first added-files)))                     nil (mapcar #'first added-files)))
341    
342              (when added-symlinks              (when added-symlinks
343                (mcvs-add nil global-options                (add nil global-options
344                          nil (mapcar #'first added-symlinks)))))))))                     nil (mapcar #'first added-symlinks)))))))))
345    
346  (defun mcvs-grab-wrapper (global-options command-options args)  (defun grab-wrapper (global-options command-options args)
347    (flet ((error ()    (flet ((error ()
348             (error "mcvs-grab: specify module name, and optional subdirectory.")))             (error "specify module name, and optional subdirectory.")))
349      (when (zerop (length args))      (when (zerop (length args))
350        (error))        (error))
351      (destructuring-bind (module &optional subdir &rest superfluous) args      (destructuring-bind (module &optional subdir &rest superfluous) args
352        (when superfluous        (when superfluous
353          (error))          (error))
354        (mcvs-grab global-options command-options module subdir))))        (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. ")

Legend:
Removed from v.1.14.2.1  
changed lines
  Added in v.1.31

  ViewVC Help
Powered by ViewVC 1.1.5