1 ;;; vc-arch.el --- VC backend for the Arch version-control system
3 ;; Copyright (C) 1995,98,99,2000,01,02,03,2004 Free Software Foundation, Inc.
5 ;; Author: FSF (see vc.el for full credits)
6 ;; Maintainer: Stefan Monnier <monnier@gnu.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; The home page of the Arch version control system is at
29 ;; http://www.gnuarch.org/
31 ;; This is derived from vc-mcvs.el as follows:
32 ;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
34 ;; Then of course started the hacking.
36 ;; What has been partly tested:
38 ;; - C-x v = without any prefix arg
39 ;; - C-x v v to commit a change to a single file
43 ;; - Opening a new file prompts "blabla was lost; check out? (yes or no)".
44 ;; - *VC-log*'s initial content lacks the `Summary:' lines.
45 ;; - All files under the tree are considered as "under Arch's control"
46 ;; without regards to =tagging-method and such.
47 ;; - Files are always considered as `edited'.
48 ;; - C-x v l does not work.
49 ;; - C-x v i does not work.
50 ;; - C-x v ~ does not work.
51 ;; - C-x v u does not work.
52 ;; - C-x v s does not work.
53 ;; - C-x v r does not work.
54 ;; - VC-dired does not work.
59 (eval-when-compile (require 'vc
))
62 ;;; Customization options
65 (defvar vc-arch-command
66 (let ((candidates '("tla")))
67 (while (and candidates
(not (executable-find (car candidates
))))
68 (setq candidates
(cdr candidates
)))
69 (or (car candidates
) "tla")))
71 ;; Clear up the cache to force vc-call to check again and discover
72 ;; new functions when we reload this file.
73 (put 'Arch
'vc-functions nil
)
75 ;;;###autoload (defun vc-arch-registered (file)
76 ;;;###autoload (let ((dir file))
77 ;;;###autoload (while (and (stringp dir)
78 ;;;###autoload (not (equal
79 ;;;###autoload dir (setq dir (file-name-directory dir))))
81 ;;;###autoload (setq dir (if (file-directory-p
82 ;;;###autoload (expand-file-name "{arch}" dir))
83 ;;;###autoload t (directory-file-name dir))))
84 ;;;###autoload (if (eq dir t)
86 ;;;###autoload (load "vc-arch")
87 ;;;###autoload (vc-arch-registered file)))))
89 (defun vc-arch-add-tag ()
90 "Add an `arch-tag' to the end of the current file."
92 (goto-char (point-max))
94 (unless (bolp) (insert "\n"))
97 (call-process "uuidgen" nil t
) ;Also inserts a terminal newline.
98 (comment-region beg
(point))))
100 (defun vc-arch-root (file)
101 "Return the root directory of a Arch project, if any."
102 (or (vc-file-getprop file
'arch-root
)
107 (equal file
(setq file
(file-name-directory file
)))
109 (if (file-directory-p (expand-file-name "{arch}" file
))
111 (setq file
(directory-file-name file
))))
114 (defun vc-arch-registered (file)
115 ;; Don't check whether it's source or not. Checking would require
116 ;; running TLA, so it's better to not do it, so it also works if TLA is
120 (defun vc-arch-default-version (file)
121 (or (vc-file-getprop (vc-arch-root file
) 'arch-default-version
)
122 (let* ((root (vc-arch-root file
))
123 (f (expand-file-name "{arch}/++default-version" root
)))
124 (if (file-readable-p f
)
126 root
'arch-default-version
128 (insert-file-contents f
)
129 ;; Strip the terminating newline.
130 (buffer-substring (point-min) (1- (point-max)))))))))
132 (defun vc-arch-workfile-unchanged-p (file)
133 "Check if FILE is unchanged by diffing against the master version.
134 Return non-nil if FILE is unchanged."
137 (defun vc-arch-state (file)
138 ;; There's no checkout operation and merging is not done from VC
139 ;; so the only operation that's state dependent that VC supports is commit
140 ;; which is only activated if the file is `edited'.
143 (defun vc-arch-workfile-version (file)
144 (let* ((root (expand-file-name "{arch}" (vc-arch-root file
)))
145 (defbranch (vc-arch-default-version file
)))
146 (when (and defbranch
(string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*\\)--.*\\)--.*\\)\\'" defbranch
))
147 (let* ((archive (match-string 1 defbranch
))
148 (category (match-string 4 defbranch
))
149 (branch (match-string 3 defbranch
))
150 (version (match-string 2 defbranch
))
151 (sealed nil
) (rev-nb 0)
154 (setq logdir
(expand-file-name category root
))
155 (setq logdir
(expand-file-name branch logdir
))
156 (setq logdir
(expand-file-name version logdir
))
157 (setq logdir
(expand-file-name archive logdir
))
158 (setq logdir
(expand-file-name "patch-log" logdir
))
159 ;; Revision names go: base-0, patch-N, version-0, versionfix-N.
160 (dolist (file (directory-files logdir
))
161 (when (and (eq (aref file
0) ?v
) (not sealed
))
162 (setq sealed t rev-nb
0))
163 (if (and (string-match "-\\([0-9]+\\)\\'" file
)
164 (setq tmp
(string-to-number (match-string 1 file
)))
165 (or (not sealed
) (eq (aref file
0) ?v
))
167 (setq rev-nb tmp rev file
)))
168 (concat defbranch
"--" rev
)))))
171 (defcustom vc-arch-mode-line-rewrite
172 '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" .
"\\2\\3[\\1]"))
173 "Rewrite rules to shorten Arch's revision names on the mode-line."
174 :type
'(repeat (cons regexp string
)))
176 (defun vc-arch-mode-line-string (file)
177 "Return string for placement in modeline by `vc-mode-line' for FILE."
178 (let ((rev (vc-workfile-version file
)))
179 (dolist (rule vc-arch-mode-line-rewrite
)
180 (if (string-match (car rule
) rev
)
181 (setq rev
(replace-match (cdr rule
) t nil rev
))))
183 (if (memq (vc-state file
) '(up-to-date needs-patch
)) ?- ?
:)
186 (defun vc-arch-diff3-rej-p (rej)
187 (and (eq (nth 7 (file-attributes rej
)) 56)
189 (insert-file-contents rej
)
190 (goto-char (point-min))
191 (looking-at "Conflicts occured, diff3 conflict markers left in file\\.$"))))
193 (defun vc-arch-delete-rej-if-obsolete ()
194 "For use in `write-file-functions'."
195 (let ((rej (concat buffer-file-name
".rej")))
196 (when (and buffer-file-name
(vc-arch-diff3-rej-p rej
))
197 (if (not (re-search-forward "^>>>>>>> " nil t
))
198 ;; The .rej file is obsolete.
199 (condition-case nil
(delete-file rej
) (error nil
)))))
200 ;; This did not save the buffer.
203 (defun vc-arch-find-file-hook ()
204 (let ((rej (concat buffer-file-name
".rej")))
205 (when (and buffer-file-name
(file-exists-p rej
))
206 (if (vc-arch-diff3-rej-p rej
)
208 (goto-char (point-min))
209 (if (not (re-search-forward "^>>>>>>> " nil t
))
210 ;; The .rej file is obsolete.
211 (condition-case nil
(delete-file rej
) (error nil
))
213 (add-hook 'write-file-functions
214 'vc-arch-delete-rej-if-obsolete nil t
)
215 (message "There are unresolved conflicts in this file")))
216 (message "There are unresolved conflicts in %s"
217 (file-name-nondirectory rej
))))))
219 (defun vc-arch-checkout-model (file) 'implicit
)
221 (defun vc-arch-checkin (file rev comment
)
222 (if rev
(error "Committing to a specific revision is unsupported."))
223 (let ((summary (file-relative-name file
(vc-arch-root file
))))
224 ;; Extract a summary from the comment.
225 (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment
)
226 (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment
))
227 (setq summary
(match-string 1 comment
))
228 (setq comment
(substring comment
(match-end 0))))
229 (vc-arch-command nil
0 file
"commit" "-s" summary
"-L" comment
"--"
230 (vc-switches 'Arch
'checkin
))))
232 (defun vc-arch-diff (file &optional oldvers newvers
)
233 "Get a difference report using Arch between two versions of FILE."
235 (error "Diffing specific revisions not implemented.")
236 (let* ((async (fboundp 'start-process
))
237 ;; Run the command from the root dir.
238 (default-directory (vc-arch-root file
))
244 ;; Arch does not support the typical flags.
245 ;; (vc-switches 'Arch 'diff)
246 (file-relative-name file
)
247 (if (equal oldvers
(vc-workfile-version file
))
250 (if async
1 status
)))) ; async diff, pessimistic assumption.
252 (defun vc-arch-delete-file (file)
253 (vc-arch-command nil
0 file
"rm"))
255 (defun vc-arch-rename-file (old new
)
256 (vc-arch-command nil
0 new
"mv" (file-relative-name old
)))
258 (defun vc-arch-command (buffer okstatus file
&rest flags
)
259 "A wrapper around `vc-do-command' for use in vc-arch.el."
260 (apply 'vc-do-command buffer okstatus vc-arch-command file flags
))
264 ;;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
265 ;;; vc-arch.el ends here