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

  ViewVC Help
Powered by ViewVC 1.1.5