/[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.13 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.12: +4 -0 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

* code/install.sh: Generate mcvs script that uses qualified name
of new startup functiont to start the software.
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 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
190 (defun mcvs-list-branches (global-options)
191 (in-sandbox-root-dir
192 (chdir *mcvs-dir*)
193 (let ((symbols (with-input-from-program (s `("cvs"
194 ,@(format-opt global-options)
195 "log" "-h" ,*mcvs-map-name*))
196 (tags-from-cvs-log s)))
197 (entries (read-cvs-entries))
198 (branchpoint-suffix (format nil "~abranch-point" *branch-char*))
199 (current-sticky (what-are-we-sticky-to)))
200
201 (format t "currently on: ~a (~a)~%"
202 (or (second current-sticky) "main trunk")
203 (case (first current-sticky)
204 ((:branch)
205 (if (find (format nil "~a~abranch-point"
206 (second current-sticky) *branch-char*)
207 symbols :key #'first :test #'string=)
208 "managed branch"
209 "non-managed branch"))
210 ((:tag)
211 "version tag")
212 ((:date)
213 "sticky date")
214 ((nil) "no sticky tag")))
215
216 (when (not (same-tag-check entries current-sticky))
217 (format t "warning: one or more files not on ~a~%"
218 (or (second current-sticky) "main trunk")))
219
220 (format t "branch list: ~%")
221 (dolist (symbol symbols)
222 (let* ((tag (first symbol))
223 (offset (search branchpoint-suffix tag)))
224 (when (and offset
225 (> offset 0)
226 (= offset (- (length tag) (length branchpoint-suffix))))
227 (format t "~a~a~%" #\Tab (substring tag 0 offset))))))))
228
229 (defun mcvs-merge-wrapper (global-options command-options command-args)
230 (declare (ignore command-options))
231 (when (/= (length command-args) 1)
232 (error "specify source branch symbol."))
233 (mcvs-merge global-options (first command-args)))
234
235 (defun mcvs-remerge-wrapper (global-options command-options command-args)
236 (declare (ignore command-options))
237 (when (/= (length command-args) 1)
238 (error "specify source branch symbol."))
239 (mcvs-merge global-options (first command-args) :remerge-p t))
240
241 (defun mcvs-list-branches-wrapper (global-options command-options command-args)
242 (declare (ignore command-options))
243 (when (not (zerop (length command-args)))
244 (error "command takes no arguments."))
245 (mcvs-list-branches global-options))
246
247 (defun mcvs-switch-wrapper (global-options command-options command-args)
248 (let ((up-opt (case (length command-args)
249 ((0) `("A"))
250 ((1) `("r" ,(first command-args)))
251 (otherwise
252 (error "specify at most one branch tag.")))))
253 (mcvs-update global-options `(,up-opt ,@command-options))))

  ViewVC Help
Powered by ViewVC 1.1.5