/[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 - (show annotations)
Thu Oct 10 05:56:15 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-98, mcvs-1-0-branch~branch-point
Branch point for: mcvs-1-0-branch
Changes since 1.28: +0 -3 lines
* code/add.lisp (*add-help*): Remove spurious text cut and pasted from
checkout help.
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 (unwind-protect
73 (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
74 (ignore-errors (unlink *mcvs-new-types*)))
75
76 (setf new-map-entries (types-remove-ignores new-types new-map-entries))
77 (setf new-map-entries (types-remove-ignores types new-map-entries))
78
79 (when new-map-entries
80 (dolist (map-entry new-map-entries)
81 (with-slots (kind id path) map-entry
82 (push map-entry filemap)
83 (let ((real-name (abstract-to-real-path path)))
84 (chatter-info "mapping ~a <- ~a~%" id real-name)
85 (if (eq kind :file)
86 (link real-name id)))))
87
88 (mapping-write filemap *mcvs-map* :sort-map t)
89
90 (when (setf types (append types new-types))
91 (types-write types *mcvs-types*))
92
93 (chatter-debug "Synchronizing.~%")
94 (mapping-synchronize)
95
96 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
97
98 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
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))
110 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
111 "add" ,*mcvs-types-name*)))
112 (error "CVS add failed.")))
113 (return))
114 (retry ()
115 :report "Try invoking CVS again.")
116 (continue ()
117 :report "Undo everything; restore the mapping."
118 (chatter-debug "Restoring map.~%")
119 (mapping-write saved-filemap *mcvs-map*)
120 (ignore-errors
121 (dolist (entry new-map-entries)
122 (unlink (mapping-entry-id entry))))
123 (return)))))
124
125 (chatter-debug "Updating file structure.~%")
126 (mapping-update))))
127 (values))
128
129 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
130 (multiple-value-bind (recursivep rest-add-options)
131 (separate "R" cvs-command-options
132 :key #'first :test #'string=)
133 (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))
134
135 (defconstant *add-help*
136 "Syntax:
137
138 mcvs add [ options ] objects ...
139
140 Options:
141
142 -R Recursive behavior: recursively add the contents
143 of all objects that are directories. By default,
144 trying to add a directory signals a continuable error.
145 -m \"text ...\" Use the specified text for the creation message.
146 -k key-expansion Add the file with the specified RCS expansion mode.
147
148 Semantics:
149
150 The add command brings local filesystem objects under version control.
151 The changes are not immediately incorporated into the repository; rather,
152 the addition a local change that is ``scheduled'' until the next commit
153 operation.
154
155 Objects that can be added are files and symbolic links. Directories are not
156 versioned objects in Meta-CVS; instead, files and symbolic links have a
157 pathname property which gives rise to the existence of directories in the
158 sandbox. The only significant consequence of this design choice is that empty
159 directories have no direct representation in Meta-CVS.
160
161 If any added files have suffixes that were not previously added to the
162 project before, Meta-CVS will pop up a text editor to allow you to edit
163 a specification that assigns to each new file type its CVS expansion
164 mode.")

  ViewVC Help
Powered by ViewVC 1.1.5