/[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.15 - (show annotations)
Tue Jan 14 05:53:00 2003 UTC (11 years, 3 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-3
Changes since 1.14: +5 -6 lines
Merging from mcvs-1-0-branch.

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

  ViewVC Help
Powered by ViewVC 1.1.5