/[meta-cvs]/meta-cvs/F-58F396B2ADF675136DD8552C6FFD5310.lisp
ViewVC logotype

Contents of /meta-cvs/F-58F396B2ADF675136DD8552C6FFD5310.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12.2.2 - (show annotations)
Tue Jan 14 05:50:42 2003 UTC (11 years, 3 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-7, mcvs-1-0-6, mcvs-1-0-1, mcvs-1-0-2
Changes since 1.12.2.1: +5 -6 lines
Support -k CVS option in merge and remerge commands.
Reported by Jamie Wellnitz.

* code/mcvs-main.lisp (*merge-options*, *remerge-options*): Add
one argument -k option.

* code/merge.lisp (mcvs-merge): Support extra argument for passing
command options. Pass them down to mcvs-update.
(mcvs-merge-wrapper, mcvs-remerge-wrapper): Don't ignore command
options but pass them to mcvs-merge.
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 "split")
6 (require "mapping")
7 (require "options")
8 (require "update")
9 (require "system")
10
11 (defconstant *branch-char* #\~)
12
13 (defun tags-from-cvs-log (stream)
14 "Parse stream which is assumed to be the output of a cvs log -h command
15 for a single file. Return two associative lists, one of version tags
16 and one of branch tags."
17 (let (syms (state :initial))
18 (loop
19 (let ((line (read-line stream nil)))
20 (when (null line)
21 (return-from tags-from-cvs-log (nreverse syms)))
22 (ecase state
23 ((:initial)
24 (if (string= line "symbolic names:")
25 (setf state :syms)))
26 ((:syms)
27 (cond
28 ((and (not (zerop (length line)))
29 (char= (char line 0) #\tab))
30 (push (split-words line #(#\: #\space #\tab)) syms))
31 (t (setf state :final))))
32 ((:final)))))))
33
34 (defun parse-sticky (sticky)
35 (if (string= "" sticky)
36 nil
37 (let ((first-char (char sticky 0))
38 (rest-string (substring sticky 1)))
39 (case first-char
40 (#\T (list :branch rest-string))
41 (#\D (list :date rest-string))
42 (#\N (list :tag rest-string))
43 (otherwise (list :other sticky))))))
44
45 (defun read-cvs-entries ()
46 (with-open-file (f "CVS/Entries" :direction :input :if-does-not-exist nil)
47 (when (not f)
48 (error "cannot read CVS/Entries"))
49 (let (entries)
50 (do ((line (read-line f nil) (read-line f nil)))
51 ((null line) (nreverse entries))
52 (let ((split (split-fields line #(#\/))))
53 (setf (first split)
54 (cond
55 ((string= "" (first split)) :file)
56 ((string= "D" (first split)) :directory)
57 (t :other)))
58 (when (sixth split)
59 (setf (sixth split) (parse-sticky (sixth split))))
60 (push split entries))))))
61
62 (defun same-tag-check (entries &optional directory-sticky-tag)
63 (let ((file-entries (remove-if-not #'(lambda (x) (eq x :file))
64 entries
65 :key #'first)))
66 (let ((first-tag (or directory-sticky-tag (sixth (first file-entries)))))
67 (not (find-if-not #'(lambda (x) (equal x first-tag))
68 file-entries :key #'sixth)))))
69
70 (defun what-are-we-sticky-to ()
71 (with-open-file (f "CVS/Tag" :direction :input :if-does-not-exist nil)
72 (if f
73 (let ((contents (read-line f nil)))
74 (if contents
75 (parse-sticky contents))))))
76
77 (defun what-module-is-this ()
78 (with-open-file (f "CVS/Repository" :direction :input)
79 (read-line f)))
80
81 (defun where-is-the-repository ()
82 (with-open-file (f "CVS/Root" :direction :input)
83 (read-line f)))
84
85 (defun branch-tag-check (tag)
86 (when (some #'(lambda (ch) (char= ch *branch-char*)) tag)
87 (error "tag must not contain ~a character." *branch-char*))
88 (when (string= tag "HEAD")
89 (error "HEAD is a reserved symbol." *branch-char*)))
90
91 (defun mcvs-branch (global-options branch-name)
92 (branch-tag-check branch-name)
93 (in-sandbox-root-dir
94 (let ((branchpoint-tag (format nil "~a~abranch-point"
95 branch-name *branch-char*)))
96 (chdir *mcvs-dir*)
97 (chatter-debug "Invoking CVS.~%")
98 (execute-program `("cvs" ,@(format-opt global-options)
99 "tag" "-b" ,branch-name))
100 (execute-program `("cvs" ,@(format-opt global-options)
101 "tag" ,branchpoint-tag)))))
102
103 (defun mcvs-branch-wrapper (global-options command-options command-args)
104 (declare (ignore command-options))
105 (if (/= (length command-args) 1)
106 (error "specify branch symbol")
107 (mcvs-branch global-options (first command-args))))
108
109 (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
110 (let ((module (what-module-is-this))
111 (repo (where-is-the-repository)))
112 (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
113 "tag" "-d" ,tag ,*mcvs-map-name*)))
114 (not (execute-program `("cvs" ,@(format-opt global-options)
115 "-d" ,repo "rtag" "-F"
116 ,@(if tag-what `("-r" ,tag-what))
117 ,tag ,module))))
118 (error "CVS tagging operation failed."))))
119
120 (defun mcvs-merge (global-options command-options branch-name &key remerge-p)
121 (branch-tag-check branch-name)
122 (in-sandbox-root-dir
123 (chdir *mcvs-dir*)
124 (let ((branchpoint-tag (format nil "~a~abranch-point"
125 branch-name *branch-char*))
126 (current-sticky (what-are-we-sticky-to))
127 this-branch
128 (symbols (with-input-from-program (s `("cvs"
129 ,@(format-opt global-options)
130 "log" "-h" ,*mcvs-map-name*))
131 (tags-from-cvs-log s))))
132
133 (when (not (or (null current-sticky)
134 (eq (first current-sticky) :branch)))
135 (error "working copy is currently updated to a non-branch tag."))
136
137 (setf this-branch (or (second current-sticky) "HEAD"))
138
139 (when (string= this-branch branch-name)
140 (error "cannot merge branch to itself."))
141
142 (let* ((even-merge-tag (format nil "~a~amerged-to-~a-0" branch-name
143 *branch-char* this-branch))
144 (odd-merge-tag (format nil "~a~amerged-to-~a-1" branch-name
145 *branch-char* this-branch))
146 (branch-tag-pos (position branch-name symbols
147 :key #'first :test #'string=))
148 (even-tag-pos (position even-merge-tag symbols
149 :key #'first :test #'string=))
150 (odd-tag-pos (position odd-merge-tag symbols
151 :key #'first :test #'string=))
152 (bp-tag-pos (position branchpoint-tag symbols
153 :key #'first :test #'string=))
154 from-tag to-tag)
155
156 (when (not branch-tag-pos)
157 (error "unable to retrieve branch symbol ~a." branch-name))
158 (when (not bp-tag-pos)
159 (error "this is not a Meta-CVS managed branch."))
160
161 (cond
162 (remerge-p
163 (cond
164 ((and even-tag-pos odd-tag-pos)
165 (if (< even-tag-pos odd-tag-pos)
166 (setf from-tag odd-merge-tag to-tag even-merge-tag)
167 (setf from-tag even-merge-tag to-tag odd-merge-tag)))
168 (odd-tag-pos
169 (setf from-tag branchpoint-tag to-tag odd-merge-tag))
170 (even-tag-pos
171 (setf from-tag branchpoint-tag to-tag even-merge-tag))
172 (t (error "no prior merge was done"))))
173 (t (cond
174 ((and even-tag-pos odd-tag-pos)
175 (if (< even-tag-pos odd-tag-pos)
176 (setf from-tag even-merge-tag to-tag odd-merge-tag)
177 (setf from-tag odd-merge-tag to-tag even-merge-tag)))
178 (even-tag-pos
179 (setf from-tag even-merge-tag to-tag odd-merge-tag))
180 (odd-tag-pos
181 (setf from-tag odd-merge-tag to-tag even-merge-tag))
182 (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
183 (cvs-make-or-advance-tag global-options to-tag branch-name)))
184 (mcvs-update global-options `(("j" ,from-tag) ("j" ,to-tag)
185 ,@command-options))))))
186
187 (defun mcvs-list-branches (global-options)
188 (in-sandbox-root-dir
189 (chdir *mcvs-dir*)
190 (let ((symbols (with-input-from-program (s `("cvs"
191 ,@(format-opt global-options)
192 "log" "-h" ,*mcvs-map-name*))
193 (tags-from-cvs-log s)))
194 (entries (read-cvs-entries))
195 (branchpoint-suffix (format nil "~abranch-point" *branch-char*))
196 (current-sticky (what-are-we-sticky-to)))
197
198 (format t "currently on: ~a (~a)~%"
199 (or (second current-sticky) "main trunk")
200 (case (first current-sticky)
201 ((:branch)
202 (if (find (format nil "~a~abranch-point"
203 (second current-sticky) *branch-char*)
204 symbols :key #'first :test #'string=)
205 "managed branch"
206 "non-managed branch"))
207 ((:tag)
208 "version tag")
209 ((:date)
210 "sticky date")
211 ((nil) "no sticky tag")))
212
213 (when (not (same-tag-check entries current-sticky))
214 (format t "warning: one or more files not on ~a~%"
215 (or (second current-sticky) "main trunk")))
216
217 (format t "branch list: ~%")
218 (dolist (symbol symbols)
219 (let* ((tag (first symbol))
220 (offset (search branchpoint-suffix tag)))
221 (when (and offset
222 (> offset 0)
223 (= offset (- (length tag) (length branchpoint-suffix))))
224 (format t "~a~a~%" #\Tab (substring tag 0 offset))))))))
225
226 (defun mcvs-merge-wrapper (global-options command-options command-args)
227 (when (/= (length command-args) 1)
228 (error "specify source branch symbol."))
229 (mcvs-merge global-options command-options (first command-args)))
230
231 (defun mcvs-remerge-wrapper (global-options command-options command-args)
232 (when (/= (length command-args) 1)
233 (error "specify source branch symbol."))
234 (mcvs-merge global-options command-options (first command-args) :remerge-p t))
235
236 (defun mcvs-list-branches-wrapper (global-options command-options command-args)
237 (declare (ignore command-options))
238 (when (not (zerop (length command-args)))
239 (error "command takes no arguments."))
240 (mcvs-list-branches global-options))
241
242 (defun mcvs-switch-wrapper (global-options command-options command-args)
243 (let ((up-opt (case (length command-args)
244 ((0) `("A"))
245 ((1) `("r" ,(first command-args)))
246 (otherwise
247 (error "specify at most one branch tag.")))))
248 (mcvs-update global-options `(,up-opt ,@command-options))))
249
250 (defconstant *branch-help*
251 "Syntax:
252
253 mcvs branch branch-name
254
255 Options:
256
257 none
258
259 Semantics
260
261 A branch can sprout from any point in the repository history. The branch
262 command makes a branch starting at the closest repository revisions of all
263 files in the sandbox, and associates that branch with the given branch name,
264 which must be unique among branch names and tags.
265
266 A branch is a fork in the revision history of a project. When a project is
267 created, it has one branch which is called the main trunk. Every branch has
268 a tip, which consists of the latest committed revisions of the files.
269 Committing changes advances the tip to include newer revisions, causing
270 the superseded revisions to recede into the branch history. That is how
271 the repository grows to include new material, without losing past versions.
272
273 Branches are needed for two reasons: to isolate changes, and to create
274 changes based on old work.
275
276 Isolating changes from each other is important for managing the risks
277 associated with making changes to software (known as ``change management'').
278 Branches decouple the work of making the changes from the decisions about
279 what version of the software those changes will be integrated into. For
280 example, branching allows developers to put only critical bugfixes into an
281 upcoming software release, while continuing to develop new features for a
282 future version after that release. This is done by creating a branch for the
283 critical bugfixes, and then eventually making the release from that branch,
284 while development takes place on the trunk. The trunk also needs the
285 critical bugfixes that are put into the release. These fixes don't have to
286 be done twice. Rather, the branch is merged to the trunk, which is a mostly
287 automatic process, triggered by the invocation of the merge command.
288 A branch can also be created to isolate risky experimental changes, so
289 that their intergration can be delayed until they are stable, without
290 the need to suspend the actual work of writing the changes.
291
292 Secondly, a branch is needed when a change must be made based on file
293 revisions that are no longer at the tip of their branch. Since commits happen
294 only at the tip, when changes must be based on some historic version rather
295 than the latest version, a branch is used. This mechanism allows developers
296 to fix a bug in some old version of the software, and send that fix to the
297 customer who doesn't want to, or cannot upgrade to the latest version.
298 If that fix is pertinent to the latest version of the software, that branch
299 can be merged to the trunk; even if the fixed version is very old, it's
300 possible that the fix will merge with only a fraction of the effort that
301 would be required to re-do the fix.
302
303 Branches are only an important tool; making effective use of branching
304 requires that the users understand, agree upon and follow an intelligent
305 change management process.")

  ViewVC Help
Powered by ViewVC 1.1.5