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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sun Oct 6 07:28:30 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-97
Changes since 1.27: +6 -5 lines
* code/add.lisp (mcvs-add): Provide a continue restart around
the code that builds up the expanded-paths for each iteration of the
loop. Without this, errors in that code cause the program to bail, even
though errors in the rest of the loop body are continuable.
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     (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 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
78 kaz 1.18
79     (when new-map-entries
80     (dolist (map-entry new-map-entries)
81 kaz 1.23 (with-slots (kind id path) map-entry
82 kaz 1.18 (push map-entry filemap)
83 kaz 1.23 (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 kaz 1.18
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 kaz 1.20 (chatter-debug "Synchronizing.~%")
94 kaz 1.1 (mapping-synchronize)
95    
96 kaz 1.23 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
97    
98 kaz 1.18 (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 kaz 1.20 (chatter-debug "Invoking CVS.~%")
104 kaz 1.18 (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 kaz 1.20 (chatter-debug "Restoring map.~%")
119 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
120     (ignore-errors
121     (dolist (entry new-map-entries)
122 kaz 1.23 (unlink (mapping-entry-id entry))))
123 kaz 1.18 (return)))))
124 kaz 1.14
125 kaz 1.20 (chatter-debug "Updating file structure.~%")
126 kaz 1.1 (mapping-update))))
127     (values))
128 kaz 1.6
129 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
130 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
131 kaz 1.8 (separate "R" cvs-command-options
132 kaz 1.6 :key #'first :test #'string=)
133     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))
134 kaz 1.25
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     The checkout command retrieves a module from Meta-CVS to form a working copy,
162     also known as a ``sandbox'' in version control jargon.
163    
164     If any added files have suffixes that were not previously added to the
165     project before, Meta-CVS will pop up a text editor to allow you to edit
166     a specification that assigns to each new file type its CVS expansion
167     mode.")

  ViewVC Help
Powered by ViewVC 1.1.5