/[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.3 - (show annotations)
Fri Jan 9 05:09:20 2004 UTC (10 years, 3 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-10
Changes since 1.12.2.2: +26 -6 lines
Parsing directory sticky tag from CVS/Tag requires
slightly different logic from the sticky tags in CVS/Entries.
CVS/Entries doesn't distinguish branch and version
sticky tags.

This change gets rid of the incorrect warning about
not all files being on the same tag when the working
copy is sticky to a version tag.

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

  ViewVC Help
Powered by ViewVC 1.1.5