/[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.1 - (show annotations)
Sun Nov 3 20:31:16 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0, mcvs-0-99
Changes since 1.12: +57 -0 lines
* code/branch.lisp (*branch-help*): New string constant.

* code/mcvs-main.lisp (*mcvs-command-table*): *branch-help* hooked in.
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 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
186 (defun mcvs-list-branches (global-options)
187 (in-sandbox-root-dir
188 (chdir *mcvs-dir*)
189 (let ((symbols (with-input-from-program (s `("cvs"
190 ,@(format-opt global-options)
191 "log" "-h" ,*mcvs-map-name*))
192 (tags-from-cvs-log s)))
193 (entries (read-cvs-entries))
194 (branchpoint-suffix (format nil "~abranch-point" *branch-char*))
195 (current-sticky (what-are-we-sticky-to)))
196
197 (format t "currently on: ~a (~a)~%"
198 (or (second current-sticky) "main trunk")
199 (case (first current-sticky)
200 ((:branch)
201 (if (find (format nil "~a~abranch-point"
202 (second current-sticky) *branch-char*)
203 symbols :key #'first :test #'string=)
204 "managed branch"
205 "non-managed branch"))
206 ((:tag)
207 "version tag")
208 ((:date)
209 "sticky date")
210 ((nil) "no sticky tag")))
211
212 (when (not (same-tag-check entries current-sticky))
213 (format t "warning: one or more files not on ~a~%"
214 (or (second current-sticky) "main trunk")))
215
216 (format t "branch list: ~%")
217 (dolist (symbol symbols)
218 (let* ((tag (first symbol))
219 (offset (search branchpoint-suffix tag)))
220 (when (and offset
221 (> offset 0)
222 (= offset (- (length tag) (length branchpoint-suffix))))
223 (format t "~a~a~%" #\Tab (substring tag 0 offset))))))))
224
225 (defun mcvs-merge-wrapper (global-options command-options command-args)
226 (declare (ignore command-options))
227 (when (/= (length command-args) 1)
228 (error "specify source branch symbol."))
229 (mcvs-merge global-options (first command-args)))
230
231 (defun mcvs-remerge-wrapper (global-options command-options command-args)
232 (declare (ignore command-options))
233 (when (/= (length command-args) 1)
234 (error "specify source branch symbol."))
235 (mcvs-merge global-options (first command-args) :remerge-p t))
236
237 (defun mcvs-list-branches-wrapper (global-options command-options command-args)
238 (declare (ignore command-options))
239 (when (not (zerop (length command-args)))
240 (error "command takes no arguments."))
241 (mcvs-list-branches global-options))
242
243 (defun mcvs-switch-wrapper (global-options command-options command-args)
244 (let ((up-opt (case (length command-args)
245 ((0) `("A"))
246 ((1) `("r" ,(first command-args)))
247 (otherwise
248 (error "specify at most one branch tag.")))))
249 (mcvs-update global-options `(,up-opt ,@command-options))))
250
251 (defconstant *branch-help*
252 "Syntax:
253
254 mcvs branch branch-name
255
256 Options:
257
258 none
259
260 Semantics
261
262 A branch can sprout from any point in the repository history. The branch
263 command makes a branch starting at the closest repository revisions of all
264 files in the sandbox, and associates that branch with the given branch name,
265 which must be unique among branch names and tags.
266
267 A branch is a fork in the revision history of a project. When a project is
268 created, it has one branch which is called the main trunk. Every branch has
269 a tip, which consists of the latest committed revisions of the files.
270 Committing changes advances the tip to include newer revisions, causing
271 the superseded revisions to recede into the branch history. That is how
272 the repository grows to include new material, without losing past versions.
273
274 Branches are needed for two reasons: to isolate changes, and to create
275 changes based on old work.
276
277 Isolating changes from each other is important for managing the risks
278 associated with making changes to software (known as ``change management'').
279 Branches decouple the work of making the changes from the decisions about
280 what version of the software those changes will be integrated into. For
281 example, branching allows developers to put only critical bugfixes into an
282 upcoming software release, while continuing to develop new features for a
283 future version after that release. This is done by creating a branch for the
284 critical bugfixes, and then eventually making the release from that branch,
285 while development takes place on the trunk. The trunk also needs the
286 critical bugfixes that are put into the release. These fixes don't have to
287 be done twice. Rather, the branch is merged to the trunk, which is a mostly
288 automatic process, triggered by the invocation of the merge command.
289 A branch can also be created to isolate risky experimental changes, so
290 that their intergration can be delayed until they are stable, without
291 the need to suspend the actual work of writing the changes.
292
293 Secondly, a branch is needed when a change must be made based on file
294 revisions that are no longer at the tip of their branch. Since commits happen
295 only at the tip, when changes must be based on some historic version rather
296 than the latest version, a branch is used. This mechanism allows developers
297 to fix a bug in some old version of the software, and send that fix to the
298 customer who doesn't want to, or cannot upgrade to the latest version.
299 If that fix is pertinent to the latest version of the software, that branch
300 can be merged to the trunk; even if the fixed version is very old, it's
301 possible that the fix will merge with only a fraction of the effort that
302 would be required to re-do the fix.
303
304 Branches are only an important tool; making effective use of branching
305 requires that the users understand, agree upon and follow an intelligent
306 change management process.")

  ViewVC Help
Powered by ViewVC 1.1.5