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

  ViewVC Help
Powered by ViewVC 1.1.5