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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Tue Sep 17 03:34:25 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-95, mcvs-0-96
Changes since 1.24: +34 -0 lines
* code/mcvs-main.lisp (*checkout-options*): Removed -A and -N
options.
(*mcvs-command-table*): Added help for checkout and add.

* code/checkout.lisp (*checkout-help*): New string constant.

* code/add.help (*add-help*): Likewise.

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

  ViewVC Help
Powered by ViewVC 1.1.5