/[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.7 - (hide annotations)
Thu Apr 4 16:58:50 2002 UTC (12 years ago) by kaz
Branch: MAIN
Changes since 1.6: +3 -1 lines
* branch.lisp (branch-tag-check): Check reserved symbol HEAD.
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     (defun what-branch-are-we-on ()
35 kaz 1.4 (with-open-file (f "CVS/Tag" :direction :input :if-does-not-exist nil)
36 kaz 1.1 (if f
37     (let ((contents (read-line f nil)))
38     (if (and contents (> (length contents) 1))
39     (substring contents 1))))))
40    
41 kaz 1.4 (defun what-module-is-this ()
42     (with-open-file (f "CVS/Repository" :direction :input)
43     (read-line f)))
44    
45 kaz 1.5 (defun where-is-the-repository ()
46     (with-open-file (f "CVS/Root" :direction :input)
47     (read-line f)))
48    
49 kaz 1.1 (defun branch-tag-check (tag)
50     (when (some #'(lambda (ch) (char= ch *branch-char*)) tag)
51 kaz 1.7 (error "mcvs-branch: tag must not contain ~a character." *branch-char*))
52     (when (string= tag "HEAD")
53     (error "mcvs-branch: HEAD is a reserved symbol." *branch-char*)))
54 kaz 1.1
55     (defun mcvs-branch (global-options branch-name)
56     (branch-tag-check branch-name)
57     (in-sandbox-root-dir
58 kaz 1.2 (let ((branchpoint-tag (format nil "~a~abranch-point"
59     branch-name *branch-char*)))
60 kaz 1.1 (chdir *mcvs-dir*)
61     (chatter-debug "Invoking CVS.~%")
62     (execute-program `("cvs" ,@(format-opt global-options)
63     "tag" "-b" ,branch-name))
64     (execute-program `("cvs" ,@(format-opt global-options)
65     "tag" ,branchpoint-tag)))))
66    
67     (defun mcvs-branch-wrapper (global-options command-options command-args)
68     (declare (ignore command-options))
69     (if (/= (length command-args) 1)
70     (error "mcvs-branch: specify branch symbol")
71     (mcvs-branch global-options (first command-args))))
72    
73     (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
74 kaz 1.5 (let ((module (what-module-is-this))
75     (repo (where-is-the-repository)))
76 kaz 1.4 (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
77     "tag" "-d" ,tag ,*mcvs-map-name*)))
78     (not (execute-program `("cvs" ,@(format-opt global-options)
79 kaz 1.5 "-d" ,repo "rtag" "-F"
80 kaz 1.4 ,@(if tag-what `("-r" ,tag-what))
81     ,tag ,module))))
82     (error "mcvs-merge: CVS tagging operation failed."))))
83 kaz 1.1
84 kaz 1.3 (defun mcvs-merge (global-options branch-name &key remerge-p)
85 kaz 1.1 (branch-tag-check branch-name)
86     (in-sandbox-root-dir
87     (chdir *mcvs-dir*)
88 kaz 1.2 (let* ((branchpoint-tag (format nil "~a~abranch-point"
89     branch-name *branch-char*))
90 kaz 1.1 (this-branch (or (what-branch-are-we-on) "HEAD"))
91 kaz 1.2 (even-merge-tag (format nil "~a~amerged-to-~a-0" branch-name
92     *branch-char* this-branch))
93     (odd-merge-tag (format nil "~a~amerged-to-~a-1" branch-name
94     *branch-char* this-branch))
95 kaz 1.1 (symbols (with-input-from-program (s `("cvs"
96     ,@(format-opt global-options)
97     "log" "-h" ,*mcvs-map-name*))
98     (tags-from-cvs-log s)))
99     (branch-tag-pos (position branch-name symbols
100     :key #'first :test #'string=))
101     (even-tag-pos (position even-merge-tag symbols
102     :key #'first :test #'string=))
103     (odd-tag-pos (position odd-merge-tag symbols
104     :key #'first :test #'string=))
105     (bp-tag-pos (position branchpoint-tag symbols
106     :key #'first :test #'string=))
107     from-tag to-tag)
108     (if (string= this-branch branch-name)
109     (error "mcvs-merge: cannot merge branch to itself."))
110     (if (not branch-tag-pos)
111     (error "mcvs-merge: unable to retrieve branch symbol ~a." branch-name))
112     (if (not bp-tag-pos)
113     (error "mcvs-merge: this is not a Meta-CVS managed branch."))
114    
115     (cond
116 kaz 1.3 (remerge-p
117     (cond
118     ((and even-tag-pos odd-tag-pos)
119     (if (< even-tag-pos odd-tag-pos)
120     (setf from-tag odd-merge-tag to-tag even-merge-tag)
121     (setf from-tag even-merge-tag to-tag odd-merge-tag)))
122     (odd-tag-pos
123     (setf from-tag branchpoint-tag to-tag odd-merge-tag))
124     (even-tag-pos
125     (setf from-tag branchpoint-tag to-tag even-merge-tag))
126     (t (error "mcvs-remerge: no prior merge was done"))))
127     (t (cond
128     ((and even-tag-pos odd-tag-pos)
129     (if (< even-tag-pos odd-tag-pos)
130     (setf from-tag even-merge-tag to-tag odd-merge-tag)
131     (setf from-tag odd-merge-tag to-tag even-merge-tag)))
132     (even-tag-pos
133     (setf from-tag even-merge-tag to-tag odd-merge-tag))
134     (odd-tag-pos
135     (setf from-tag odd-merge-tag to-tag even-merge-tag))
136     (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
137     (cvs-make-or-advance-tag global-options to-tag branch-name)))
138 kaz 1.4 (mcvs-update global-options `(("j" ,from-tag) ("j" ,to-tag))))))
139 kaz 1.1
140 kaz 1.6 (defun mcvs-list-branches (global-options)
141     (in-sandbox-root-dir
142     (chdir *mcvs-dir*)
143     (let ((symbols (with-input-from-program (s `("cvs"
144     ,@(format-opt global-options)
145     "log" "-h" ,*mcvs-map-name*))
146     (tags-from-cvs-log s)))
147     (branchpoint-suffix (format nil "~abranch-point" *branch-char*)))
148    
149     (dolist (symbol symbols)
150     (let* ((tag (first symbol))
151     (offset (search branchpoint-suffix tag)))
152     (when (and offset
153     (> offset 0)
154     (= offset (- (length tag) (length branchpoint-suffix))))
155     (format t "~a~%" (substring tag 0 offset))))))))
156    
157 kaz 1.1 (defun mcvs-merge-wrapper (global-options command-options command-args)
158     (declare (ignore command-options))
159 kaz 1.6 (when (/= (length command-args) 1)
160 kaz 1.1 (error "mcvs-merge: specify source branch symbol.")
161     (mcvs-merge global-options (first command-args))))
162 kaz 1.3
163     (defun mcvs-remerge-wrapper (global-options command-options command-args)
164     (declare (ignore command-options))
165 kaz 1.6 (when (/= (length command-args) 1)
166 kaz 1.3 (error "mcvs-remerge: specify source branch symbol.")
167     (mcvs-merge global-options (first command-args) :remerge-p t)))
168 kaz 1.6
169     (defun mcvs-list-branches-wrapper (global-options command-options command-args)
170     (declare (ignore command-options))
171     (when (not (zerop (length command-args)))
172     (error "mcvs-list-branches: command takes no arguments."))
173     (mcvs-list-branches global-options))

  ViewVC Help
Powered by ViewVC 1.1.5