/[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.21.2.4 by kaz, Tue Jan 27 07:32:13 2004 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 34  Line 23 
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 182  Line 171 
171              (set-difference added-symlinks taken-added :test #'eq)              (set-difference added-symlinks taken-added :test #'eq)
172              (set-difference removed-symlinks taken-removed :test #'eq))))              (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
# Line 190  Line 179 
179        (error "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 "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 220  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 286  Line 275 
275    
276              (let ((moved-hash (make-hash-table :test #'equal))              (let ((moved-hash (make-hash-table :test #'equal))
277                    (all-hash (make-hash-table :test #'equal))                    (all-hash (make-hash-table :test #'equal))
278                    (mapping (mapping-read *mcvs-map*)))                    (mapping (mapping-read *map-path*)))
279                (dolist (entry mapping)                (dolist (entry mapping)
280                  (setf (gethash (mapping-entry-id entry) all-hash) entry))                  (setf (gethash (mapping-entry-id entry) all-hash) entry))
281                (when (or moved-files moved-symlinks)                (when (or moved-files moved-symlinks)
# Line 339  Line 328 
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 *mcvs-map*)                (mapping-write mapping *map-path*)
332                (mapping-write mapping *mcvs-map-local*))                (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 "specify module name, and optional subdirectory.")))             (error "specify module name, and optional subdirectory.")))
349      (when (zerop (length args))      (when (zerop (length args))
# Line 362  Line 351 
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*  (defconstant *grab-help*
357  "Syntax:  "Syntax:

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

  ViewVC Help
Powered by ViewVC 1.1.5