/[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.6 - (show annotations)
Thu Apr 24 04:06:37 2003 UTC (10 years, 11 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-branch~merged-to-HEAD-1, mcvs-1-0-branch~merged-to-HEAD-0, mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-13, mcvs-1-0-12, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7
Changes since 1.29.2.5: +1 -1 lines
Change restoration message to match that of the move command.
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 (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 (nreverse expanded-paths)
32
33 (dolist (full-name expanded-paths)
34 (can-restart-here ("Continue mapping files.")
35 (let ((abs-name (real-to-abstract-path full-name))
36 (file-info (stat full-name)))
37 (cond
38 ((path-prefix-equal *mcvs-dir* full-name)
39 (error "cannot add ~a: path is in a reserved Meta-CVS area."
40 full-name))
41 ((mapping-lookup filemap abs-name)
42 (chatter-info "~a already added.~%" full-name))
43 ((directory-p file-info)
44 (when (not recursivep)
45 (error "cannot add ~a: it is a directory, use -R to add." full-name)))
46 ((regular-p file-info)
47 (let* ((suffix (suffix full-name))
48 (f-file (mapping-generate-id :suffix suffix)))
49 (when suffix
50 (setf new-types (adjoin (list suffix :default)
51 new-types :test #'equal)))
52 (push (make-mapping-entry :kind :file
53 :id f-file
54 :path abs-name
55 :executable (executable-p
56 file-info))
57 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 (error "cannot add ~a: not regular file or symlink."
67 full-name))))))))
68
69 (setf new-types (set-difference
70 new-types types :key #'first :test #'string=))
71
72 (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
77 (setf new-map-entries (types-remove-ignores new-types new-map-entries))
78 (setf new-map-entries (types-remove-ignores types new-map-entries))
79
80 (when new-map-entries
81 (dolist (map-entry new-map-entries)
82 (with-slots (kind id path) map-entry
83 (push map-entry filemap)
84 (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
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 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
95
96 (let ((add-commands (types-make-cvs-adds types new-map-entries))
97 (restore-needed t))
98 (unwind-protect
99 (loop
100 (restart-case
101 (current-dir-restore
102 (chdir *mcvs-dir*)
103 (chatter-debug "Invoking CVS.~%")
104 (dolist (add-args add-commands)
105 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
106 "add" ,@(format-opt add-options)
107 ,@add-args)))
108 (error "CVS add failed.")))
109 (when (and types (not types-exists) (not *dry-run-option*))
110 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
111 "add" ,*mcvs-types-name*)))
112 (error "CVS add failed.")))
113 (setf restore-needed nil)
114 (return))
115 (retry ()
116 :report "Try invoking CVS again.")))
117 (when restore-needed
118 (chatter-terse "Undoing changes to map.~%")
119 (mapping-write saved-filemap *mcvs-map*)
120 (ignore-errors
121 (dolist (entry new-map-entries)
122 (unlink (mapping-entry-id entry)))))))
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 If any added files have suffixes that were not previously added to the
161 project before, Meta-CVS will pop up a text editor to allow you to edit
162 a specification that assigns to each new file type its CVS expansion
163 mode.")

  ViewVC Help
Powered by ViewVC 1.1.5