/[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.5 - (hide annotations)
Wed Apr 3 21:52:55 2002 UTC (12 years ago) by kaz
Branch: MAIN
Changes since 1.4: +7 -2 lines
* branch.lisp (where-is-the-repository): New function.
(cvs-make-or-advance-tag): Pass down CVSROOT to cvs rtag using
the -d global option.
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     (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 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     (error "mcvs-branch: tag must not contain ~a character." *branch-char*)))
52    
53     (defun mcvs-branch (global-options branch-name)
54     (branch-tag-check branch-name)
55     (in-sandbox-root-dir
56 kaz 1.2 (let ((branchpoint-tag (format nil "~a~abranch-point"
57     branch-name *branch-char*)))
58 kaz 1.1 (chdir *mcvs-dir*)
59     (chatter-debug "Invoking CVS.~%")
60     (execute-program `("cvs" ,@(format-opt global-options)
61     "tag" "-b" ,branch-name))
62     (execute-program `("cvs" ,@(format-opt global-options)
63     "tag" ,branchpoint-tag)))))
64    
65     (defun mcvs-branch-wrapper (global-options command-options command-args)
66     (declare (ignore command-options))
67     (if (/= (length command-args) 1)
68     (error "mcvs-branch: specify branch symbol")
69     (mcvs-branch global-options (first command-args))))
70    
71     (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
72 kaz 1.5 (let ((module (what-module-is-this))
73     (repo (where-is-the-repository)))
74 kaz 1.4 (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
75     "tag" "-d" ,tag ,*mcvs-map-name*)))
76     (not (execute-program `("cvs" ,@(format-opt global-options)
77 kaz 1.5 "-d" ,repo "rtag" "-F"
78 kaz 1.4 ,@(if tag-what `("-r" ,tag-what))
79     ,tag ,module))))
80     (error "mcvs-merge: CVS tagging operation failed."))))
81 kaz 1.1
82 kaz 1.3 (defun mcvs-merge (global-options branch-name &key remerge-p)
83 kaz 1.1 (branch-tag-check branch-name)
84     (in-sandbox-root-dir
85     (chdir *mcvs-dir*)
86 kaz 1.2 (let* ((branchpoint-tag (format nil "~a~abranch-point"
87     branch-name *branch-char*))
88 kaz 1.1 (this-branch (or (what-branch-are-we-on) "HEAD"))
89 kaz 1.2 (even-merge-tag (format nil "~a~amerged-to-~a-0" branch-name
90     *branch-char* this-branch))
91     (odd-merge-tag (format nil "~a~amerged-to-~a-1" branch-name
92     *branch-char* this-branch))
93 kaz 1.1 (symbols (with-input-from-program (s `("cvs"
94     ,@(format-opt global-options)
95     "log" "-h" ,*mcvs-map-name*))
96     (tags-from-cvs-log s)))
97     (branch-tag-pos (position branch-name symbols
98     :key #'first :test #'string=))
99     (even-tag-pos (position even-merge-tag symbols
100     :key #'first :test #'string=))
101     (odd-tag-pos (position odd-merge-tag symbols
102     :key #'first :test #'string=))
103     (bp-tag-pos (position branchpoint-tag symbols
104     :key #'first :test #'string=))
105     from-tag to-tag)
106     (if (string= this-branch branch-name)
107     (error "mcvs-merge: cannot merge branch to itself."))
108     (if (not branch-tag-pos)
109     (error "mcvs-merge: unable to retrieve branch symbol ~a." branch-name))
110     (if (not bp-tag-pos)
111     (error "mcvs-merge: this is not a Meta-CVS managed branch."))
112    
113     (cond
114 kaz 1.3 (remerge-p
115     (cond
116     ((and even-tag-pos odd-tag-pos)
117     (if (< even-tag-pos odd-tag-pos)
118     (setf from-tag odd-merge-tag to-tag even-merge-tag)
119     (setf from-tag even-merge-tag to-tag odd-merge-tag)))
120     (odd-tag-pos
121     (setf from-tag branchpoint-tag to-tag odd-merge-tag))
122     (even-tag-pos
123     (setf from-tag branchpoint-tag to-tag even-merge-tag))
124     (t (error "mcvs-remerge: no prior merge was done"))))
125     (t (cond
126     ((and even-tag-pos odd-tag-pos)
127     (if (< even-tag-pos odd-tag-pos)
128     (setf from-tag even-merge-tag to-tag odd-merge-tag)
129     (setf from-tag odd-merge-tag to-tag even-merge-tag)))
130     (even-tag-pos
131     (setf from-tag even-merge-tag to-tag odd-merge-tag))
132     (odd-tag-pos
133     (setf from-tag odd-merge-tag to-tag even-merge-tag))
134     (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
135     (cvs-make-or-advance-tag global-options to-tag branch-name)))
136 kaz 1.4 (mcvs-update global-options `(("j" ,from-tag) ("j" ,to-tag))))))
137 kaz 1.1
138     (defun mcvs-merge-wrapper (global-options command-options command-args)
139     (declare (ignore command-options))
140     (if (/= (length command-args) 1)
141     (error "mcvs-merge: specify source branch symbol.")
142     (mcvs-merge global-options (first command-args))))
143 kaz 1.3
144     (defun mcvs-remerge-wrapper (global-options command-options command-args)
145     (declare (ignore command-options))
146     (if (/= (length command-args) 1)
147     (error "mcvs-remerge: specify source branch symbol.")
148     (mcvs-merge global-options (first command-args) :remerge-p t)))

  ViewVC Help
Powered by ViewVC 1.1.5