/[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.1 - (show annotations)
Tue Apr 2 23:38:20 2002 UTC (12 years ago) by kaz
Branch: MAIN
First cut at implementing more automated branching and merging.

* mcvs-main.lisp (*branch-options*, *merge-options*): New constants.
(*mcvs-command-table*): New entries for branch and merge commands.
(*usage*): New help text.

* branch.lisp: New file.
(*branch-char*): New constant.
(tags-from-cvs-log, what-branch-are-we-on, branch-tag-check,
mcvs-branch, mcvs-branch-wrapper, cvs-make-or-advance-tag, mcvs-merge,
mcvs-merge-wrapper): New functions.
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~aP" branch-name *branch-char*)))
48 (chdir *mcvs-dir*)
49 (chatter-debug "Invoking CVS.~%")
50 (execute-program `("cvs" ,@(format-opt global-options)
51 "tag" "-b" ,branch-name))
52 (execute-program `("cvs" ,@(format-opt global-options)
53 "tag" ,branchpoint-tag)))))
54
55 (defun mcvs-branch-wrapper (global-options command-options command-args)
56 (declare (ignore command-options))
57 (if (/= (length command-args) 1)
58 (error "mcvs-branch: specify branch symbol")
59 (mcvs-branch global-options (first command-args))))
60
61 (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
62 (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
63 "tag" "-d" ,tag ,*mcvs-map-name*)))
64 (not (execute-program `("cvs" ,@(format-opt global-options)
65 "tag" "-F"
66 ,@(if tag-what `("-r" ,tag-what))
67 ,tag))))
68 (error "mcvs-merge: CVS tagging operation failed.")))
69
70 (defun mcvs-merge (global-options branch-name)
71 (branch-tag-check branch-name)
72 (in-sandbox-root-dir
73 (chdir *mcvs-dir*)
74 (let* ((branchpoint-tag (format nil "~a~aP" branch-name *branch-char*))
75 (this-branch (or (what-branch-are-we-on) "HEAD"))
76 (even-merge-tag (format nil "~a~aM~a0" branch-name *branch-char*
77 this-branch))
78 (odd-merge-tag (format nil "~a~aM~a1" branch-name *branch-char*
79 this-branch))
80 (symbols (with-input-from-program (s `("cvs"
81 ,@(format-opt global-options)
82 "log" "-h" ,*mcvs-map-name*))
83 (tags-from-cvs-log s)))
84 (branch-tag-pos (position branch-name symbols
85 :key #'first :test #'string=))
86 (even-tag-pos (position even-merge-tag symbols
87 :key #'first :test #'string=))
88 (odd-tag-pos (position odd-merge-tag symbols
89 :key #'first :test #'string=))
90 (bp-tag-pos (position branchpoint-tag symbols
91 :key #'first :test #'string=))
92 from-tag to-tag)
93 (if (string= this-branch branch-name)
94 (error "mcvs-merge: cannot merge branch to itself."))
95 (if (not branch-tag-pos)
96 (error "mcvs-merge: unable to retrieve branch symbol ~a." branch-name))
97 (if (not bp-tag-pos)
98 (error "mcvs-merge: this is not a Meta-CVS managed branch."))
99
100 (cond
101 ((and even-tag-pos odd-tag-pos)
102 (if (< even-tag-pos odd-tag-pos)
103 (setf from-tag even-merge-tag to-tag odd-merge-tag)
104 (setf from-tag odd-merge-tag to-tag even-merge-tag)))
105 (even-tag-pos
106 (setf from-tag even-merge-tag to-tag odd-merge-tag))
107 (odd-tag-pos
108 (setf from-tag odd-merge-tag to-tag even-merge-tag))
109 (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
110 (cvs-make-or-advance-tag global-options to-tag branch-name)
111 (execute-program `("cvs" ,@(format-opt global-options)
112 "update" "-j" ,from-tag "-j" ,to-tag)))))
113
114 (defun mcvs-merge-wrapper (global-options command-options command-args)
115 (declare (ignore command-options))
116 (if (/= (length command-args) 1)
117 (error "mcvs-merge: specify source branch symbol.")
118 (mcvs-merge global-options (first command-args))))

  ViewVC Help
Powered by ViewVC 1.1.5