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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Sun Apr 13 14:39:11 2003 UTC (11 years ago) by kaz
Branch: MAIN
Changes since 1.32: +0 -3 lines
Merging from mcvs-1-0-branch.

* code/mapping.lisp (mapping-read): Provide a restart for
file errors, which lets the user interactively substitute an
empty map if the file can't be read. This is intended to handle
the case when MCVS/MAP is missing; for example, the user
updated to a sticky date for which no revision of the MAP
exists. The effect of continuing will be that all files
will disappear.
(mapping-synchronize): New :direction key
parameter, passed down to synchronize-filed. The new :no-sync
return value from synchronize-files is handled.
(mapping-update): Select the :right direction for synchronizing
moves, adds or rollbacks.

Revamped the synchronization logic. Synchronization now happens
in a specific direction.  For example, if we are doing a diff,
we just need to push changes from the tree to the MCVS directory,
not the other way around. Or: before an update or commit, we push from
the tree to MCVS, then after the update, in the other direction.

* code/update.lisp (mcvs-update): The before update is done
in the :left direction only, and the after update in the :right.

* code/move.lisp (mcvs-move): The just-in-case sync is done
in the :left direction only.

* code/link.lisp (mcvs-link): Likewise.

* code/remove.lisp (mcvs-remove): Likewise.

* code/add.lisp (mcvs-add): Get rid of mapping-synchronize call;
it's completely unnecessary, since the new files are not even
in the MAP-LOCAL, and the add logic explicitly links them into
the MCVS directory.

* code/generic.lisp (mcvs-generic): New keyword parameter,
need-sync-before. Before-synchronization done in :left direction,
after-synchronization in :right direction. Before-synchronization
is now not done by default; need-sync-before must be specified.
(mcvs-commit-wrapper): Specify before and after sync.
(mcvs-diff-wrapper, mcvs-status-wrapper,
mcvs-edit-wrapper): Explicitly specify before sync.
(mcvs-tag-wrapper, mcvs-annotate-wrapper): Implicitly specify no sync.
(mcvs-unedit-wrapper): Add before sync.

* code/sync.lisp (synchronize-files):  New key parameter :direction,
values can be :left, :right or :either. Default is :either.
If the value is :left or :right, then a sync is done only in that
direction, otherwise the value :no-sync is returned.
Behavior change: if the left file is missing (F- file in MCVS
directory) it is not re-created, but rather :no-sync is returned.
Also, if both files exist, have the same timestamp, and are
distinct objects, if the direction is :left or :right, then
the appropriate restart is automatically chosen. So this will
do the right thing on filesystems where link() is performed by
copying, without bothering the user with the error.
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 (require "mcvs-package")
13 (provide "add")
14
15 (in-package "META-CVS")
16
17 (defun mcvs-add (recursivep cvs-options add-options files)
18 (in-sandbox-root-dir
19 (let* ((filemap (mapping-read *mcvs-map*))
20 (saved-filemap (copy-list filemap))
21 (types-exists (exists *mcvs-types*))
22 (types (and types-exists (types-read *mcvs-types*)))
23 new-map-entries new-types)
24
25 (chatter-debug "Mapping.~%")
26
27 (dolist (file files)
28 (let (expanded-paths)
29 (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 (nreverse expanded-paths)
35
36 (dolist (full-name expanded-paths)
37 (can-restart-here ("Continue mapping files.")
38 (let ((abs-name (real-to-abstract-path full-name))
39 (file-info (stat full-name)))
40 (cond
41 ((path-prefix-equal *mcvs-dir* full-name)
42 (error "cannot add ~a: path is in a reserved Meta-CVS area."
43 full-name))
44 ((mapping-lookup filemap abs-name)
45 (chatter-info "~a already added.~%" full-name))
46 ((directory-p file-info)
47 (when (not recursivep)
48 (error "cannot add ~a: it is a directory, use -R to add." full-name)))
49 ((regular-p file-info)
50 (let* ((suffix (suffix full-name))
51 (f-file (mapping-generate-id :suffix suffix)))
52 (when suffix
53 (setf new-types (adjoin (list suffix :default)
54 new-types :test #'equal)))
55 (push (make-mapping-entry :kind :file
56 :id f-file
57 :path abs-name
58 :executable (executable-p
59 file-info))
60 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 (error "cannot add ~a: not regular file or symlink."
70 full-name))))))))
71
72 (setf new-types (set-difference
73 new-types types :key #'first :test #'string=))
74
75 (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
80 (setf new-map-entries (types-remove-ignores new-types new-map-entries))
81 (setf new-map-entries (types-remove-ignores types new-map-entries))
82
83 (when new-map-entries
84 (dolist (map-entry new-map-entries)
85 (with-slots (kind id path) map-entry
86 (push map-entry filemap)
87 (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
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 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
98
99 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
100 (loop
101 (restart-case
102 (current-dir-restore
103 (chdir *mcvs-dir*)
104 (chatter-debug "Invoking CVS.~%")
105 (dolist (add-args add-commands)
106 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
107 "add" ,@(format-opt add-options)
108 ,@add-args)))
109 (error "CVS add failed.")))
110 (when (and types (not types-exists) (not *dry-run-option*))
111 (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
112 "add" ,*mcvs-types-name*)))
113 (error "CVS add failed.")))
114 (return))
115 (retry ()
116 :report "Try invoking CVS again.")
117 (continue ()
118 :report "Undo everything; restore the mapping."
119 (chatter-debug "Restoring map.~%")
120 (mapping-write saved-filemap *mcvs-map*)
121 (ignore-errors
122 (dolist (entry new-map-entries)
123 (unlink (mapping-entry-id entry))))
124 (return)))))
125
126 (chatter-debug "Updating file structure.~%")
127 (mapping-update))))
128 (values))
129
130 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
131 (multiple-value-bind (recursivep rest-add-options)
132 (separate "R" cvs-command-options
133 :key #'first :test #'string=)
134 (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))
135
136 (defconstant *add-help*
137 "Syntax:
138
139 mcvs add [ options ] objects ...
140
141 Options:
142
143 -R Recursive behavior: recursively add the contents
144 of all objects that are directories. By default,
145 trying to add a directory signals a continuable error.
146 -m \"text ...\" Use the specified text for the creation message.
147 -k key-expansion Add the file with the specified RCS expansion mode.
148
149 Semantics:
150
151 The add command brings local filesystem objects under version control.
152 The changes are not immediately incorporated into the repository; rather,
153 the addition a local change that is ``scheduled'' until the next commit
154 operation.
155
156 Objects that can be added are files and symbolic links. Directories are not
157 versioned objects in Meta-CVS; instead, files and symbolic links have a
158 pathname property which gives rise to the existence of directories in the
159 sandbox. The only significant consequence of this design choice is that empty
160 directories have no direct representation in Meta-CVS.
161
162 If any added files have suffixes that were not previously added to the
163 project before, Meta-CVS will pop up a text editor to allow you to edit
164 a specification that assigns to each new file type its CVS expansion
165 mode.")

  ViewVC Help
Powered by ViewVC 1.1.5