/[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.10 - (hide annotations)
Tue Apr 16 20:43:44 2002 UTC (12 years ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-20, symlink-branch~branch-point, mcvs-0-22, mcvs-0-23, partial-sandbox-branch~branch-point, mcvs-0-21, old-convert-hacking-branch~branch-point, partial-sandbox-branch~merged-to-HEAD-0, mcvs-0-16, mcvs-0-15, mcvs-0-14, mcvs-0-17, mcvs-0-13, mcvs-0-12, mcvs-0-19, mcvs-0-18, symlink-branch~merged-to-HEAD-0
Branch point for: symlink-branch, partial-sandbox-branch, old-convert-hacking-branch
Changes since 1.9: +64 -24 lines
* branch.lisp (parse-sticky): New function.
(read-cvs-entries): New function.
(same-tag-check): New function.
(what-tag-are-we-on): Renamed to what-are-we-sticky-to. Calls
parse-sticky to return structured tag.
(mcvs-merge): Make use of structured tags.
(mcvs-list-branches): Make use of structured tags. Indicate
when sandbox is inconsistently sticky.
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    
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 kaz 1.6 (return-from tags-from-cvs-log (nreverse syms)))
22 kaz 1.1 (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 kaz 1.10 (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 kaz 1.4 (with-open-file (f "CVS/Tag" :direction :input :if-does-not-exist nil)
72 kaz 1.1 (if f
73     (let ((contents (read-line f nil)))
74 kaz 1.10 (if contents
75     (parse-sticky contents))))))
76 kaz 1.1
77 kaz 1.4 (defun what-module-is-this ()
78     (with-open-file (f "CVS/Repository" :direction :input)
79     (read-line f)))
80    
81 kaz 1.5 (defun where-is-the-repository ()
82     (with-open-file (f "CVS/Root" :direction :input)
83     (read-line f)))
84    
85 kaz 1.1 (defun branch-tag-check (tag)
86     (when (some #'(lambda (ch) (char= ch *branch-char*)) tag)
87 kaz 1.7 (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 kaz 1.1
91     (defun mcvs-branch (global-options branch-name)
92     (branch-tag-check branch-name)
93     (in-sandbox-root-dir
94 kaz 1.2 (let ((branchpoint-tag (format nil "~a~abranch-point"
95     branch-name *branch-char*)))
96 kaz 1.1 (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 kaz 1.5 (let ((module (what-module-is-this))
111     (repo (where-is-the-repository)))
112 kaz 1.4 (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 kaz 1.5 "-d" ,repo "rtag" "-F"
116 kaz 1.4 ,@(if tag-what `("-r" ,tag-what))
117     ,tag ,module))))
118     (error "mcvs-merge: CVS tagging operation failed."))))
119 kaz 1.1
120 kaz 1.3 (defun mcvs-merge (global-options branch-name &key remerge-p)
121 kaz 1.1 (branch-tag-check branch-name)
122     (in-sandbox-root-dir
123     (chdir *mcvs-dir*)
124 kaz 1.9 (let ((branchpoint-tag (format nil "~a~abranch-point"
125     branch-name *branch-char*))
126 kaz 1.10 (current-sticky (what-are-we-sticky-to))
127     this-branch
128 kaz 1.9 (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 kaz 1.10 (when (not (or (null current-sticky)
134     (eq (first current-sticky) :branch)))
135 kaz 1.9 (t (error "mcvs-merge: working copy is currently updated to a non-branch tag.")))
136    
137 kaz 1.10 (setf this-branch (or (second current-sticky) "HEAD"))
138    
139 kaz 1.9 (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 kaz 1.1 :key #'first :test #'string=))
150 kaz 1.9 (odd-tag-pos (position odd-merge-tag symbols
151     :key #'first :test #'string=))
152     (bp-tag-pos (position branchpoint-tag symbols
153 kaz 1.1 :key #'first :test #'string=))
154 kaz 1.9 from-tag to-tag)
155 kaz 1.1
156 kaz 1.9 (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 kaz 1.1
186 kaz 1.6 (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 kaz 1.10 (entries (read-cvs-entries))
194 kaz 1.8 (branchpoint-suffix (format nil "~abranch-point" *branch-char*))
195 kaz 1.10 (current-sticky (what-are-we-sticky-to)))
196 kaz 1.9
197     (format t "currently on: ~a (~a)~%"
198 kaz 1.10 (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 kaz 1.6
216 kaz 1.8 (format t "branch list: ~%")
217 kaz 1.6 (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 kaz 1.8 (format t "~a~a~%" #\Tab (substring tag 0 offset))))))))
224 kaz 1.6
225 kaz 1.1 (defun mcvs-merge-wrapper (global-options command-options command-args)
226     (declare (ignore command-options))
227 kaz 1.6 (when (/= (length command-args) 1)
228 kaz 1.9 (error "mcvs-merge: specify source branch symbol."))
229     (mcvs-merge global-options (first command-args)))
230 kaz 1.3
231     (defun mcvs-remerge-wrapper (global-options command-options command-args)
232     (declare (ignore command-options))
233 kaz 1.6 (when (/= (length command-args) 1)
234 kaz 1.9 (error "mcvs-remerge: specify source branch symbol."))
235     (mcvs-merge global-options (first command-args) :remerge-p t))
236 kaz 1.6
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 kaz 1.9
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