ViewVC logotype

Contents of /meta-cvs/F-58F396B2ADF675136DD8552C6FFD5310.lisp

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.22 - (show annotations)
Tue Nov 28 04:12:08 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.21: +14 -14 lines
Getting rid of mcvs- prefixes.

* code/package.lisp (defpackage): shadow the merge symbol.

* code/purge.lisp (mcvs-purge): renamed to purge
(mcvs-purge-wrapper): renamed to purge-wrapper

* code/restore.lisp (mcvs-restore): renamed to restore
(mcvs-restore-wrapper): renamed to restore-wrapper

* code/update.lisp (mcvs-update): renamed to update
(mcvs-update-wrapper): renamed to update-wrapper

* code/main.lisp (mcvs-help): renamed to help
(*mcvs-command-table*): renamed to *command-table*
(mcvs-terminate catch): renamed to terminate.

* code/execute.lisp (mcvs-execute): renamed to execute

* code/move.lisp (mcvs-move): renamed to move
(mcvs-move-wrapper): renamed to move-wrapper

* code/grab.lisp (mcvs-grab): renamed to grab
(mcvs-grab-wrapper): renamed to grab-wrapper

* code/prop.lisp (mcvs-prop): renamed to prop
(mcvs-prop-wrapper): renamed to prop-wrapper

* code/filt.lisp (mcvs-filt-loop): renamed to filt-loop
(mcvs-filt): renamed to filt
(mcvs-remote-filt): renamed to remote-filt
(mcvs-filt-wrapper): renamed to filt-wrapper
(mcvs-remote-filt-wrapper): renamed to remote-filt-wrapper

* code/branch.lisp (mcvs-branch): renamed to branch
(mcvs-branch-wrapper): renamed to branch-wrapper
(mcvs-merge): renamed to merge
(mcvs-list-branches): renamed to list-branches
(mcvs-merge-wrapper): renamed to merge-wrapper
(mcvs-remerge-wrapper): renamed to remerge-wrapper
(mcvs-list-branches-wrapper): renamed to list-branches-wrapper
(mcvs-switch-wrapper): renamed to switch-wrapper

* code/link.lisp (mcvs-link): renamed to ln
(mcvs-link-wrapper): renamed to link-wrapper

* code/watch.lisp (mcvs-watch): renamed to watch
(mcvs-watch-wrapper): renamed to watch-wrapper

* code/add.lisp (mcvs-add): renamed to add
(mcvs-add-wrapper): renamed to add-wrapper

* code/remove.lisp (mcvs-remove): renamed to rm
(mcvs-remove-wrapper): renamed to remove-wrapper

* code/convert.lisp (mcvs-convert): renamed to convert
(mcvs-convert-wrapper): renamed to convert-wrapper

* code/error.lisp (mcvs-terminate): renamed to terminate
(mcvs-error-handler): renamed to error-handler
(*mcvs-error-treatment*): renamed to *error-treatment*
(*mcvs-errors-occured-p*): renamed to *errors-occured-p*

* code/checkout.lisp (mcvs-checkout): renamed to checkout
(mcvs-checkout-wrapper): renamed to checkout-wrapper
(mcvs-export-wrapper): renamed to export-wrapper

* code/generic.lisp (mcvs-generic): renamed to generic
(mcvs-commit-wrapper): renamed to commit-wrapper
(mcvs-diff-wrapper): renamed to diff-wrapper
(mcvs-tag-wrapper): renamed to tag-wrapper
(mcvs-log-wrapper): renamed to log-wrapper
(mcvs-status-wrapper): renamed to status-wrapper
(mcvs-annotate-wrapper): renamed to annotate-wrapper
(mcvs-watchers-wrapper): renamed to watchers-wrapper
(mcvs-edit-wrapper): renamed to edit-wrapper
(mcvs-unedit-wrapper): renamed to unedit-wrapper
(mcvs-editors-wrapper): renamed to editors-wrapper
(mcvs-sync-to-wrapper): renamed to sync-to-wrapper
(mcvs-sync-from-wrapper): renamed to sync-from-wrapper

* code/create.lisp (mcvs-create): renamed to create
(mcvs-create-wrapper): renamed to create-wrapper

* code/remap.lisp (mcvs-remap): renamed to remap
(mcvs-remap-wrapper): renamed to remap-wrapper

* code/mapping.lisp (mcvs-locate): renamed to locate
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
5 (in-package :meta-cvs)
7 (defconstant *branch-char* #\~)
9 (defun tags-from-cvs-log (stream)
10 "Parse stream which is assumed to be the output of a cvs log -h command
11 for a single file. Return two associative lists, one of version tags
12 and one of branch tags."
13 (let (syms (state :initial))
14 (loop
15 (let ((line (read-line stream nil)))
16 (when (null line)
17 (return-from tags-from-cvs-log (nreverse syms)))
18 (ecase state
19 ((:initial)
20 (if (string= line "symbolic names:")
21 (setf state :syms)))
22 ((:syms)
23 (cond
24 ((and (not (zerop (length line)))
25 (char= (char line 0) #\tab))
26 (push (split-words line #(#\: #\space #\tab)) syms))
27 (t (setf state :final))))
28 ((:final)))))))
30 (defun parse-dir-sticky (sticky)
31 (if (string= "" sticky)
32 nil
33 (let ((first-char (char sticky 0))
34 (rest-string (subseq sticky 1)))
35 (case first-char
36 (#\T (list :branch rest-string))
37 (#\D (list :date rest-string))
38 (#\N (list :version rest-string))
39 (otherwise (list :other sticky))))))
41 (defun parse-entries-sticky (sticky)
42 (if (string= "" sticky)
43 nil
44 (let ((first-char (char sticky 0))
45 (rest-string (subseq sticky 1)))
46 (case first-char
47 (#\T (list :tag rest-string))
48 (#\D (list :date rest-string))
49 (otherwise (list :other sticky))))))
51 (defun equal-sticky (left right)
52 (cond
53 ((eq left right) t)
54 ((null left) nil)
55 ((null right) nil)
56 (t (destructuring-bind (type-left text-left) left
57 (destructuring-bind (type-right text-right) right
58 (and (equal text-left text-right)
59 (or (eq type-left type-right)
60 (and (eq type-left :tag)
61 (member type-right '(:version :branch)))
62 (and (eq type-right :tag)
63 (member type-left '(:version :branch))))))))))
65 (defun read-cvs-entries ()
66 (with-open-file (f "CVS/Entries" :direction :input :if-does-not-exist nil)
67 (when (not f)
68 (error "cannot read CVS/Entries"))
69 (let (entries)
70 (do ((line (read-line f nil) (read-line f nil)))
71 ((null line) (nreverse entries))
72 (let ((split (split-fields line #(#\/))))
73 (setf (first split)
74 (cond
75 ((string= "" (first split)) :file)
76 ((string= "D" (first split)) :directory)
77 (t :other)))
78 (when (sixth split)
79 (setf (sixth split) (parse-entries-sticky (sixth split))))
80 (push split entries))))))
82 (defun same-tag-check (entries &optional directory-sticky-tag)
83 (let ((file-entries (remove-if-not #'(lambda (x) (eq x :file))
84 entries
85 :key #'first)))
86 (let ((first-tag (or directory-sticky-tag (sixth (first file-entries)))))
87 (not (find-if-not #'(lambda (x) (equal-sticky x first-tag))
88 file-entries :key #'sixth)))))
90 (defun what-are-we-sticky-to ()
91 (with-open-file (f "CVS/Tag" :direction :input :if-does-not-exist nil)
92 (if f
93 (let ((contents (read-line f nil)))
94 (if contents
95 (parse-dir-sticky contents))))))
97 (defun what-module-is-this ()
98 (with-open-file (f "CVS/Repository" :direction :input)
99 (read-line f)))
101 (defun where-is-the-repository ()
102 (with-open-file (f "CVS/Root" :direction :input)
103 (read-line f)))
105 (defun branch-tag-check (tag)
106 (when (some #'(lambda (ch) (char= ch *branch-char*)) tag)
107 (error "tag must not contain ~a character." *branch-char*))
108 (when (string= tag "HEAD")
109 (error "HEAD is a reserved symbol." *branch-char*)))
111 (defun branch (global-options branch-name)
112 (branch-tag-check branch-name)
113 (in-sandbox-root-dir
114 (let ((branchpoint-tag (format nil "~a~abranch-point"
115 branch-name *branch-char*)))
116 (chdir *mcvs-dir*)
117 (chatter-debug "Invoking CVS.~%")
118 (execute-program `("cvs" ,@(format-opt global-options)
119 "tag" "-b" ,branch-name))
120 (execute-program `("cvs" ,@(format-opt global-options)
121 "tag" ,branchpoint-tag)))))
123 (defun branch-wrapper (global-options command-options command-args)
124 (declare (ignore command-options))
125 (if (/= (length command-args) 1)
126 (error "specify branch symbol")
127 (branch global-options (first command-args))))
129 (defun cvs-make-or-advance-tag (global-options tag &optional tag-what)
130 (let ((module (what-module-is-this))
131 (repo (where-is-the-repository)))
132 (if (or (not (execute-program `("cvs" ,@(format-opt global-options)
133 "tag" "-d" ,tag ,*mcvs-map-name*)))
134 (not (execute-program `("cvs" ,@(format-opt global-options)
135 "-d" ,repo "rtag" "-F"
136 ,@(if tag-what `("-r" ,tag-what))
137 ,tag ,module))))
138 (error "CVS tagging operation failed."))))
140 (defun merge (global-options command-options branch-name &key remerge-p)
141 (branch-tag-check branch-name)
142 (in-sandbox-root-dir
143 (chdir *mcvs-dir*)
144 (let ((branchpoint-tag (format nil "~a~abranch-point"
145 branch-name *branch-char*))
146 (current-sticky (what-are-we-sticky-to))
147 this-branch
148 (symbols (with-input-from-program (s `("cvs"
149 ,@(format-opt global-options)
150 "log" "-h" ,*mcvs-map-name*))
151 (tags-from-cvs-log s))))
153 (when (not (or (null current-sticky)
154 (eq (first current-sticky) :branch)))
155 (error "working copy is currently updated to a non-branch tag."))
157 (setf this-branch (or (second current-sticky) "HEAD"))
159 (when (string= this-branch branch-name)
160 (error "cannot merge branch to itself."))
162 (let* ((even-merge-tag (format nil "~a~amerged-to-~a-0" branch-name
163 *branch-char* this-branch))
164 (odd-merge-tag (format nil "~a~amerged-to-~a-1" branch-name
165 *branch-char* this-branch))
166 (branch-tag-pos (position branch-name symbols
167 :key #'first :test #'string=))
168 (even-tag-pos (position even-merge-tag symbols
169 :key #'first :test #'string=))
170 (odd-tag-pos (position odd-merge-tag symbols
171 :key #'first :test #'string=))
172 (bp-tag-pos (position branchpoint-tag symbols
173 :key #'first :test #'string=))
174 from-tag to-tag)
176 (when (not branch-tag-pos)
177 (error "unable to retrieve branch symbol ~a." branch-name))
178 (when (not bp-tag-pos)
179 (error "this is not a Meta-CVS managed branch."))
181 (cond
182 (remerge-p
183 (cond
184 ((and even-tag-pos odd-tag-pos)
185 (if (< even-tag-pos odd-tag-pos)
186 (setf from-tag odd-merge-tag to-tag even-merge-tag)
187 (setf from-tag even-merge-tag to-tag odd-merge-tag)))
188 (odd-tag-pos
189 (setf from-tag branchpoint-tag to-tag odd-merge-tag))
190 (even-tag-pos
191 (setf from-tag branchpoint-tag to-tag even-merge-tag))
192 (t (error "no prior merge was done"))))
193 (t (cond
194 ((and even-tag-pos odd-tag-pos)
195 (if (< even-tag-pos odd-tag-pos)
196 (setf from-tag even-merge-tag to-tag odd-merge-tag)
197 (setf from-tag odd-merge-tag to-tag even-merge-tag)))
198 (even-tag-pos
199 (setf from-tag even-merge-tag to-tag odd-merge-tag))
200 (odd-tag-pos
201 (setf from-tag odd-merge-tag to-tag even-merge-tag))
202 (t (setf from-tag branchpoint-tag to-tag even-merge-tag)))
203 (cvs-make-or-advance-tag global-options to-tag branch-name)))
204 (update global-options `(("j" ,from-tag) ("j" ,to-tag)
205 ,@command-options))))))
207 (defun list-branches (global-options)
208 (in-sandbox-root-dir
209 (chdir *mcvs-dir*)
210 (let ((symbols (with-input-from-program (s `("cvs"
211 ,@(format-opt global-options)
212 "log" "-h" ,*mcvs-map-name*))
213 (tags-from-cvs-log s)))
214 (entries (read-cvs-entries))
215 (branchpoint-suffix (format nil "~abranch-point" *branch-char*))
216 (current-sticky (what-are-we-sticky-to)))
218 (format t "currently on: ~a (~a)~%"
219 (or (second current-sticky) "main trunk")
220 (case (first current-sticky)
221 ((:branch)
222 (if (find (format nil "~a~abranch-point"
223 (second current-sticky) *branch-char*)
224 symbols :key #'first :test #'string=)
225 "managed branch"
226 "non-managed branch"))
227 ((:version)
228 "version tag")
229 ((:date)
230 "sticky date")
231 ((nil) "no sticky tag")))
233 (when (not (same-tag-check entries current-sticky))
234 (format t "warning: one or more files not on ~a~%"
235 (or (second current-sticky) "main trunk")))
237 (format t "branch list: ~%")
238 (dolist (symbol symbols)
239 (let* ((tag (first symbol))
240 (offset (search branchpoint-suffix tag)))
241 (when (and offset
242 (> offset 0)
243 (= offset (- (length tag) (length branchpoint-suffix))))
244 (format t "~a~a~%" #\Tab (subseq tag 0 offset))))))))
246 (defun merge-wrapper (global-options command-options command-args)
247 (when (/= (length command-args) 1)
248 (error "specify source branch symbol."))
249 (merge global-options command-options (first command-args)))
251 (defun remerge-wrapper (global-options command-options command-args)
252 (when (/= (length command-args) 1)
253 (error "specify source branch symbol."))
254 (merge global-options command-options (first command-args) :remerge-p t))
256 (defun list-branches-wrapper (global-options command-options command-args)
257 (declare (ignore command-options))
258 (when (not (zerop (length command-args)))
259 (error "command takes no arguments."))
260 (list-branches global-options))
262 (defun switch-wrapper (global-options command-options command-args)
263 (let ((up-opt (case (length command-args)
264 ((0) `("A"))
265 ((1) `("r" ,(first command-args)))
266 (otherwise
267 (error "specify at most one branch tag.")))))
268 (update global-options `(,up-opt ,@command-options))))
270 (defconstant *branch-help*
271 "Syntax:
273 mcvs branch branch-name
275 Options:
277 none
279 Semantics
281 A branch can sprout from any point in the repository history. The branch
282 command makes a branch starting at the closest repository revisions of all
283 files in the sandbox, and associates that branch with the given branch name,
284 which must be unique among branch names and tags.
286 A branch is a fork in the revision history of a project. When a project is
287 created, it has one branch which is called the main trunk. Every branch has
288 a tip, which consists of the latest committed revisions of the files.
289 Committing changes advances the tip to include newer revisions, causing
290 the superseded revisions to recede into the branch history. That is how
291 the repository grows to include new material, without losing past versions.
293 Branches are needed for two reasons: to isolate changes, and to create
294 changes based on old work.
296 Isolating changes from each other is important for managing the risks
297 associated with making changes to software (known as ``change management'').
298 Branches decouple the work of making the changes from the decisions about
299 what version of the software those changes will be integrated into. For
300 example, branching allows developers to put only critical bugfixes into an
301 upcoming software release, while continuing to develop new features for a
302 future version after that release. This is done by creating a branch for the
303 critical bugfixes, and then eventually making the release from that branch,
304 while development takes place on the trunk. The trunk also needs the
305 critical bugfixes that are put into the release. These fixes don't have to
306 be done twice. Rather, the branch is merged to the trunk, which is a mostly
307 automatic process, triggered by the invocation of the merge command.
308 A branch can also be created to isolate risky experimental changes, so
309 that their intergration can be delayed until they are stable, without
310 the need to suspend the actual work of writing the changes.
312 Secondly, a branch is needed when a change must be made based on file
313 revisions that are no longer at the tip of their branch. Since commits happen
314 only at the tip, when changes must be based on some historic version rather
315 than the latest version, a branch is used. This mechanism allows developers
316 to fix a bug in some old version of the software, and send that fix to the
317 customer who doesn't want to, or cannot upgrade to the latest version.
318 If that fix is pertinent to the latest version of the software, that branch
319 can be merged to the trunk; even if the fixed version is very old, it's
320 possible that the fix will merge with only a fraction of the effort that
321 would be required to re-do the fix.
323 Branches are only an important tool; making effective use of branching
324 requires that the users understand, agree upon and follow an intelligent
325 change management process.")

  ViewVC Help
Powered by ViewVC 1.1.5