/[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.3 - (hide annotations)
Wed Apr 3 00:55:05 2002 UTC (12 years ago) by kaz
Branch: MAIN
Changes since 1.2: +29 -11 lines
Implemented remerge command; redo a merge without moving
around any tags.

* branch.lisp (mcvs-merge): New keyword parameter remerge-p
to indicate that a re-merge should be done, plus logic for
doing so.
(mcvs-remerge-wrapper): New function.

* mcvs-main.lisp (*remerge-options*): New constant.
(*mcvs-command-table*): New entry for remerge command.
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     (require "system")
9    
10     (defconstant *branch-char* #\~)
11    
12     (defun tags-from-cvs-log (stream)
13     "Parse stream which is assumed to be the output of a cvs log -h command
14     for a single file. Return two associative lists, one of version tags
15     and one of branch tags."
16     (let (syms (state :initial))
17     (loop
18     (let ((line (read-line stream nil)))
19     (when (null line)
20     (return-from tags-from-cvs-log (nreverse syms)))
21     (ecase state
22     ((:initial)
23     (if (string= line "symbolic names:")
24     (setf state :syms)))
25     ((:syms)
26     (cond
27     ((and (not (zerop (length line)))
28     (char= (char line 0) #\tab))
29     (push (split-words line #(#\: #\space #\tab)) syms))
30     (t (setf state :final))))
31     ((:final)))))))
32    
33     (defun what-branch-are-we-on ()
34     (with-open-file (f "CVS/Tag" :if-does-not-exist nil)
35     (if f
36     (let ((contents (read-line f nil)))
37     (if (and contents (> (length contents) 1))
38     (substring contents 1))))))
39    
40     (defun branch-tag-check (tag)
41     (when (some #'(lambda (ch) (char= ch *branch-char*)) tag)
42     (error "mcvs-branch: tag must not contain ~a character." *branch-char*)))
43    
44     (defun mcvs-branch (global-options branch-name)
45     (branch-tag-check branch-name)
46     (in-sandbox-root-dir
47 kaz 1.2 (let ((branchpoint-tag (format nil "~a~abranch-point"
48     branch-name *branch-char*)))
49 kaz 1.1 (chdir *mcvs-dir*)
50     (chatter-debug "Invoking CVS.~%")
51     (execute-program `("cvs" ,@(format-opt global-options)
52     "tag" "-b" ,branch-name))
53     (execute-program `("cvs" ,@(format-opt global-options)
54     "tag" ,branchpoint-tag)))))
55    
56     (defun mcvs-branch-wrapper (global-options command-options command-args)
57     (declare (ignore command-options))
58     (if (/= (length command-args) 1)
59     (error "mcvs-branch: specify branch symbol")
60     (mcvs-branch global-options (first command-args))))
61    
62     (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
63     (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
64     "tag" "-d" ,tag ,*mcvs-map-name*)))
65     (not (execute-program `("cvs" ,@(format-opt global-options)
66     "tag" "-F"
67     ,@(if tag-what `("-r" ,tag-what))
68     ,tag))))
69     (error "mcvs-merge: CVS tagging operation failed.")))
70    
71 kaz 1.3 (defun mcvs-merge (global-options branch-name &key remerge-p)
72 kaz 1.1 (branch-tag-check branch-name)
73     (in-sandbox-root-dir
74     (chdir *mcvs-dir*)
75 kaz 1.2 (let* ((branchpoint-tag (format nil "~a~abranch-point"
76     branch-name *branch-char*))
77 kaz 1.1 (this-branch (or (what-branch-are-we-on) "HEAD"))
78 kaz 1.2 (even-merge-tag (format nil "~a~amerged-to-~a-0" branch-name
79     *branch-char* this-branch))
80     (odd-merge-tag (format nil "~a~amerged-to-~a-1" branch-name
81     *branch-char* this-branch))
82 kaz 1.1 (symbols (with-input-from-program (s `("cvs"
83     ,@(format-opt global-options)
84     "log" "-h" ,*mcvs-map-name*))
85     (tags-from-cvs-log s)))
86     (branch-tag-pos (position branch-name symbols
87     :key #'first :test #'string=))
88     (even-tag-pos (position even-merge-tag symbols
89     :key #'first :test #'string=))
90     (odd-tag-pos (position odd-merge-tag symbols
91     :key #'first :test #'string=))
92     (bp-tag-pos (position branchpoint-tag symbols
93     :key #'first :test #'string=))
94     from-tag to-tag)
95     (if (string= this-branch branch-name)
96     (error "mcvs-merge: cannot merge branch to itself."))
97     (if (not branch-tag-pos)
98     (error "mcvs-merge: unable to retrieve branch symbol ~a." branch-name))
99     (if (not bp-tag-pos)
100     (error "mcvs-merge: this is not a Meta-CVS managed branch."))
101    
102     (cond
103 kaz 1.3 (remerge-p
104     (cond
105     ((and even-tag-pos odd-tag-pos)
106     (if (< even-tag-pos odd-tag-pos)
107     (setf from-tag odd-merge-tag to-tag even-merge-tag)
108     (setf from-tag even-merge-tag to-tag odd-merge-tag)))
109     (odd-tag-pos
110     (setf from-tag branchpoint-tag to-tag odd-merge-tag))
111     (even-tag-pos
112     (setf from-tag branchpoint-tag to-tag even-merge-tag))
113     (t (error "mcvs-remerge: no prior merge was done"))))
114     (t (cond
115     ((and even-tag-pos odd-tag-pos)
116     (if (< even-tag-pos odd-tag-pos)
117     (setf from-tag even-merge-tag to-tag odd-merge-tag)
118     (setf from-tag odd-merge-tag to-tag even-merge-tag)))
119     (even-tag-pos
120     (setf from-tag even-merge-tag to-tag odd-merge-tag))
121     (odd-tag-pos
122     (setf from-tag odd-merge-tag to-tag even-merge-tag))
123     (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
124     (cvs-make-or-advance-tag global-options to-tag branch-name)))
125 kaz 1.1 (execute-program `("cvs" ,@(format-opt global-options)
126     "update" "-j" ,from-tag "-j" ,to-tag)))))
127    
128     (defun mcvs-merge-wrapper (global-options command-options command-args)
129     (declare (ignore command-options))
130     (if (/= (length command-args) 1)
131     (error "mcvs-merge: specify source branch symbol.")
132     (mcvs-merge global-options (first command-args))))
133 kaz 1.3
134     (defun mcvs-remerge-wrapper (global-options command-options command-args)
135     (declare (ignore command-options))
136     (if (/= (length command-args) 1)
137     (error "mcvs-remerge: specify source branch symbol.")
138     (mcvs-merge global-options (first command-args) :remerge-p t)))

  ViewVC Help
Powered by ViewVC 1.1.5