/[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.5 - (hide annotations)
Thu Apr 24 04:02:55 2003 UTC (10 years, 11 months ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.29.2.4: +27 -26 lines
Improved error handling again in a flash of sanity. The whole
idea of ``bail'' as a restart is gone. All code which must perform
some complex cleanup action does so as part of normal unwinding.
And so termination becomes safe.

* code/update.lisp (mcvs-update): Change bail restart to continue.

* code/mcvs-main.lisp (*global-options*): Remove "error-bail".
(*usage*): Remove description of --error-bail.
(mcvs-execute): Bind *mcvs-error-treatment* to :terminate rather
than :bail if controlling TTY cannot be opened.

* code/move.lisp (mcvs-move): Change "Undoing move" error message
to "Undoing changes to map".

* code/add.lisp (mcvs-add): Get rid of bail restart; move cleanup
code into unwind-protect block.

* code/error.lisp (*mcvs-error-treatment*): Touch up docstring.
(mcvs-error-handler): Remove anything having to do with :bail.
Change description of `T' command to suggest that it is safe.

* code/options.lisp (filter-mcvs-options): Remove handling of
"error-bail" option.

* code/mapping.lisp (mapping-update): Get rid of outermost
restart-case, which had just a bail restart. Replace it with
unwind-protect block which does exactly the same restoration.
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 kaz 1.28 (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 kaz 1.4 (nreverse expanded-paths)
32    
33 kaz 1.5 (dolist (full-name expanded-paths)
34 kaz 1.28 (can-restart-here ("Continue mapping files.")
35 kaz 1.27 (let ((abs-name (real-to-abstract-path full-name))
36     (file-info (stat full-name)))
37 kaz 1.22 (cond
38     ((path-prefix-equal *mcvs-dir* full-name)
39 kaz 1.26 (error "cannot add ~a: path is in a reserved Meta-CVS area."
40 kaz 1.22 full-name))
41     ((mapping-lookup filemap abs-name)
42 kaz 1.26 (chatter-info "~a already added.~%" full-name))
43 kaz 1.23 ((directory-p file-info)
44 kaz 1.22 (when (not recursivep)
45 kaz 1.26 (error "cannot add ~a: it is a directory, use -R to add." full-name)))
46 kaz 1.23 ((regular-p file-info)
47 kaz 1.22 (let* ((suffix (suffix full-name))
48 kaz 1.23 (f-file (mapping-generate-id :suffix suffix)))
49 kaz 1.22 (when suffix
50     (setf new-types (adjoin (list suffix :default)
51     new-types :test #'equal)))
52 kaz 1.23 (push (make-mapping-entry :kind :file
53     :id f-file
54 kaz 1.24 :path abs-name
55     :executable (executable-p
56     file-info))
57 kaz 1.23 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 kaz 1.26 (error "cannot add ~a: not regular file or symlink."
67 kaz 1.23 full-name))))))))
68 kaz 1.18
69     (setf new-types (set-difference
70     new-types types :key #'first :test #'string=))
71    
72 kaz 1.29.2.2 (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 kaz 1.18
77     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
78 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
79 kaz 1.18
80     (when new-map-entries
81     (dolist (map-entry new-map-entries)
82 kaz 1.23 (with-slots (kind id path) map-entry
83 kaz 1.18 (push map-entry filemap)
84 kaz 1.23 (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 kaz 1.18
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 kaz 1.23 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
95    
96 kaz 1.29.2.5 (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-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 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 kaz 1.29.2.1 -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 kaz 1.25 -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