/[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.2 - (hide annotations)
Tue Apr 2 23:45:46 2002 UTC (12 years ago) by kaz
Branch: MAIN
Changes since 1.1: +8 -6 lines
Use more human readable symbols for tracking merges.
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     (defun mcvs-merge (global-options branch-name)
72     (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     ((and even-tag-pos odd-tag-pos)
104     (if (< even-tag-pos odd-tag-pos)
105     (setf from-tag even-merge-tag to-tag odd-merge-tag)
106     (setf from-tag odd-merge-tag to-tag even-merge-tag)))
107     (even-tag-pos
108     (setf from-tag even-merge-tag to-tag odd-merge-tag))
109     (odd-tag-pos
110     (setf from-tag odd-merge-tag to-tag even-merge-tag))
111     (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
112     (cvs-make-or-advance-tag global-options to-tag branch-name)
113     (execute-program `("cvs" ,@(format-opt global-options)
114     "update" "-j" ,from-tag "-j" ,to-tag)))))
115    
116     (defun mcvs-merge-wrapper (global-options command-options command-args)
117     (declare (ignore command-options))
118     (if (/= (length command-args) 1)
119     (error "mcvs-merge: specify source branch symbol.")
120     (mcvs-merge global-options (first command-args))))

  ViewVC Help
Powered by ViewVC 1.1.5