/[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 - (show 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 ;;; 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 (require "system")
6 (require "mapping")
7 (require "chatter")
8 (require "dirwalk")
9 (require "seqfuncs")
10 (require "options")
11 (require "types")
12 (provide "add")
13
14 (defun mcvs-add (recursivep cvs-options add-options files)
15 (in-sandbox-root-dir
16 (let* ((filemap (mapping-read *mcvs-map*))
17 (saved-filemap (copy-list filemap))
18 (types-exists (exists *mcvs-types*))
19 (types (and types-exists (types-read *mcvs-types*)))
20 new-map-entries new-types)
21
22 (chatter-debug "Mapping.~%")
23
24 (dolist (file files)
25 (let (expanded-paths)
26 (if recursivep
27 (for-each-path (full-name (sandbox-translate-path file))
28 (push (canonicalize-path full-name) expanded-paths))
29 (push (sandbox-translate-path file) expanded-paths))
30 (nreverse expanded-paths)
31
32 (dolist (full-name expanded-paths)
33 (let ((abs-name (real-to-abstract-path full-name))
34 (file-info (stat full-name)))
35 (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 ((directory-p file-info)
43 (when (not recursivep)
44 (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))
45 ((regular-p file-info)
46 (let* ((suffix (suffix full-name))
47 (f-file (mapping-generate-id :suffix suffix)))
48 (when suffix
49 (setf new-types (adjoin (list suffix :default)
50 new-types :test #'equal)))
51 (push (make-mapping-entry :kind :file
52 :id f-file
53 :path abs-name
54 :executable (executable-p
55 file-info))
56 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
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 (setf new-map-entries (types-remove-ignores types new-map-entries))
77
78 (when new-map-entries
79 (dolist (map-entry new-map-entries)
80 (with-slots (kind id path) map-entry
81 (push map-entry filemap)
82 (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
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 (chatter-debug "Synchronizing.~%")
93 (mapping-synchronize)
94
95 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
96
97 (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 (chatter-debug "Invoking CVS.~%")
103 (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 (chatter-debug "Restoring map.~%")
118 (mapping-write saved-filemap *mcvs-map*)
119 (ignore-errors
120 (dolist (entry new-map-entries)
121 (unlink (mapping-entry-id entry))))
122 (return)))))
123
124 (chatter-debug "Updating file structure.~%")
125 (mapping-update))))
126 (values))
127
128 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
129 (multiple-value-bind (recursivep rest-add-options)
130 (separate "R" cvs-command-options
131 :key #'first :test #'string=)
132 (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))
133
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