/[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 - (show 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 ;;; 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 (let ((branchpoint-tag (format nil "~a~abranch-point"
48 branch-name *branch-char*)))
49 (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 (defun mcvs-merge (global-options branch-name &key remerge-p)
72 (branch-tag-check branch-name)
73 (in-sandbox-root-dir
74 (chdir *mcvs-dir*)
75 (let* ((branchpoint-tag (format nil "~a~abranch-point"
76 branch-name *branch-char*))
77 (this-branch (or (what-branch-are-we-on) "HEAD"))
78 (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 (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 (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 (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
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