/[meta-cvs]/meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B
ViewVC logotype

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29.2.2 - (hide annotations)
Mon Nov 4 01:09:35 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0, mcvs-0-99, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-1, mcvs-1-0-2
Changes since 1.29.2.1: +5 -4 lines
Start of support for global option -n (dry run).

* code/options.lisp (*dry-run-option*): New boolean variable.
(process-cvs-options): Look for -n and set *dry-run-option*.

* code/types.lisp (types-write): Do not write file if *dry-run-option*
is true.

* code/types.lisp (mapping-write): Likewise.

* code/add.lisp (mcvs-add): When calling types-let-user-edit,
temporarily disable the dry run option, so that TYPES-NEW can
be written. When the dry run option is in effect, do not try
to cvs add the TYPES file.
1 kaz 1.10 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.7 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "system")
6     (require "mapping")
7     (require "chatter")
8 kaz 1.4 (require "dirwalk")
9 kaz 1.6 (require "seqfuncs")
10 kaz 1.8 (require "options")
11 kaz 1.18 (require "types")
12 kaz 1.1 (provide "add")
13    
14 kaz 1.6 (defun mcvs-add (recursivep cvs-options add-options files)
15 kaz 1.3 (in-sandbox-root-dir
16 kaz 1.14 (let* ((filemap (mapping-read *mcvs-map*))
17     (saved-filemap (copy-list filemap))
18 kaz 1.18 (types-exists (exists *mcvs-types*))
19     (types (and types-exists (types-read *mcvs-types*)))
20     new-map-entries new-types)
21 kaz 1.1
22 kaz 1.20 (chatter-debug "Mapping.~%")
23 kaz 1.4
24 kaz 1.1 (dolist (file files)
25 kaz 1.4 (let (expanded-paths)
26 kaz 1.28 (can-restart-here ("Continue processing arguments after ~a." file)
27     (if recursivep
28     (for-each-path (full-name (sandbox-translate-path file))
29     (push (canonicalize-path full-name) expanded-paths))
30     (push (sandbox-translate-path file) expanded-paths)))
31 kaz 1.4 (nreverse expanded-paths)
32    
33 kaz 1.5 (dolist (full-name expanded-paths)
34 kaz 1.28 (can-restart-here ("Continue mapping files.")
35 kaz 1.27 (let ((abs-name (real-to-abstract-path full-name))
36     (file-info (stat full-name)))
37 kaz 1.22 (cond
38     ((path-prefix-equal *mcvs-dir* full-name)
39 kaz 1.26 (error "cannot add ~a: path is in a reserved Meta-CVS area."
40 kaz 1.22 full-name))
41     ((mapping-lookup filemap abs-name)
42 kaz 1.26 (chatter-info "~a already added.~%" full-name))
43 kaz 1.23 ((directory-p file-info)
44 kaz 1.22 (when (not recursivep)
45 kaz 1.26 (error "cannot add ~a: it is a directory, use -R to add." full-name)))
46 kaz 1.23 ((regular-p file-info)
47 kaz 1.22 (let* ((suffix (suffix full-name))
48 kaz 1.23 (f-file (mapping-generate-id :suffix suffix)))
49 kaz 1.22 (when suffix
50     (setf new-types (adjoin (list suffix :default)
51     new-types :test #'equal)))
52 kaz 1.23 (push (make-mapping-entry :kind :file
53     :id f-file
54 kaz 1.24 :path abs-name
55     :executable (executable-p
56     file-info))
57 kaz 1.23 new-map-entries)))
58     ((symlink-p file-info)
59     (let ((id (mapping-generate-id :no-dir t :prefix "S-")))
60     (push (make-mapping-entry :kind :symlink
61     :id id
62     :path abs-name
63     :target (readlink full-name))
64     new-map-entries)))
65     (t
66 kaz 1.26 (error "cannot add ~a: not regular file or symlink."
67 kaz 1.23 full-name))))))))
68 kaz 1.18
69     (setf new-types (set-difference
70     new-types types :key #'first :test #'string=))
71    
72 kaz 1.29.2.2 (let ((*dry-run-option* nil))
73     (unwind-protect
74     (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
75     (ignore-errors (unlink *mcvs-new-types*))))
76 kaz 1.18
77     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
78 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
79 kaz 1.18
80     (when new-map-entries
81     (dolist (map-entry new-map-entries)
82 kaz 1.23 (with-slots (kind id path) map-entry
83 kaz 1.18 (push map-entry filemap)
84 kaz 1.23 (let ((real-name (abstract-to-real-path path)))
85     (chatter-info "mapping ~a <- ~a~%" id real-name)
86     (if (eq kind :file)
87     (link real-name id)))))
88 kaz 1.18
89     (mapping-write filemap *mcvs-map* :sort-map t)
90    
91     (when (setf types (append types new-types))
92     (types-write types *mcvs-types*))
93    
94 kaz 1.20 (chatter-debug "Synchronizing.~%")
95 kaz 1.1 (mapping-synchronize)
96    
97 kaz 1.23 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
98    
99 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
100     (loop
101     (restart-case
102     (current-dir-restore
103     (chdir *mcvs-dir*)
104 kaz 1.20 (chatter-debug "Invoking CVS.~%")
105 kaz 1.18 (dolist (add-args add-commands)
106     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
107     "add" ,@(format-opt add-options)
108     ,@add-args)))
109     (error "CVS add failed.")))
110 kaz 1.29.2.2 (when (and types (not types-exists) (not *dry-run-option*))
111 kaz 1.18 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
112     "add" ,*mcvs-types-name*)))
113     (error "CVS add failed.")))
114     (return))
115     (retry ()
116     :report "Try invoking CVS again.")
117     (continue ()
118     :report "Undo everything; restore the mapping."
119 kaz 1.20 (chatter-debug "Restoring map.~%")
120 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
121     (ignore-errors
122     (dolist (entry new-map-entries)
123 kaz 1.23 (unlink (mapping-entry-id entry))))
124 kaz 1.18 (return)))))
125 kaz 1.14
126 kaz 1.20 (chatter-debug "Updating file structure.~%")
127 kaz 1.1 (mapping-update))))
128     (values))
129 kaz 1.6
130 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
131 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
132 kaz 1.8 (separate "R" cvs-command-options
133 kaz 1.6 :key #'first :test #'string=)
134     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))
135 kaz 1.25
136     (defconstant *add-help*
137     "Syntax:
138    
139     mcvs add [ options ] objects ...
140    
141     Options:
142    
143 kaz 1.29.2.1 -R Recursive behavior: recursively add the contents
144     of all objects that are directories. By default,
145     trying to add a directory signals a continuable error.
146 kaz 1.25 -m \"text ...\" Use the specified text for the creation message.
147     -k key-expansion Add the file with the specified RCS expansion mode.
148    
149     Semantics:
150    
151     The add command brings local filesystem objects under version control.
152     The changes are not immediately incorporated into the repository; rather,
153     the addition a local change that is ``scheduled'' until the next commit
154     operation.
155    
156     Objects that can be added are files and symbolic links. Directories are not
157     versioned objects in Meta-CVS; instead, files and symbolic links have a
158     pathname property which gives rise to the existence of directories in the
159     sandbox. The only significant consequence of this design choice is that empty
160     directories have no direct representation in Meta-CVS.
161    
162     If any added files have suffixes that were not previously added to the
163     project before, Meta-CVS will pop up a text editor to allow you to edit
164     a specification that assigns to each new file type its CVS expansion
165     mode.")

  ViewVC Help
Powered by ViewVC 1.1.5