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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.38: +11 -11 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5