/[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.11 - (show annotations)
Sun Sep 8 20:34:51 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-95, mcvs-0-96
Changes since 1.10: +1 -1 lines
Fix mistake dating back to April.

* code/branch.lisp (mcvs-merge): Symbol T was being invoked
as function in the case that merge is invoked on a sandbox
that is sticky to a non-branch tag.
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 "mcvs-branch: tag must not contain ~a character." *branch-char*))
88 (when (string= tag "HEAD")
89 (error "mcvs-branch: 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 "mcvs-branch: 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 "mcvs-merge: 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 "mcvs-merge: 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 "mcvs-merge: 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 "mcvs-merge: unable to retrieve branch symbol ~a." branch-name))
158 (when (not bp-tag-pos)
159 (error "mcvs-merge: 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 "mcvs-remerge: 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 "mcvs-merge: 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 "mcvs-remerge: 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 "mcvs-list-branches: 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 "mcvs-switch: specify at most one branch tag.")))))
249 (mcvs-update global-options `(,up-opt ,@command-options))))

  ViewVC Help
Powered by ViewVC 1.1.5