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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5