* lisp/emacs-lisp/bytecomp.el: Silence obsolete warnings more reliably.
[emacs.git] / lisp / vc / vc-mtn.el
blob0fc7ba96fb70de524823ed748372a29052156810
1 ;;; vc-mtn.el --- VC backend for Monotone
3 ;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords: vc
7 ;; Package: vc
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Commentary:
28 ;;; TODO:
30 ;; - The `previous-version' VC method needs to be supported, 'D' in
31 ;; log-view-mode uses it.
33 ;;; Code:
35 (eval-when-compile (require 'cl) (require 'vc))
37 (defcustom vc-mtn-diff-switches t
38 "String or list of strings specifying switches for monotone diff under VC.
39 If nil, use the value of `vc-diff-switches'. If t, use no switches."
40 :type '(choice (const :tag "Unspecified" nil)
41 (const :tag "None" t)
42 (string :tag "Argument String")
43 (repeat :tag "Argument List" :value ("") string))
44 :version "23.1"
45 :group 'vc)
47 (define-obsolete-variable-alias 'vc-mtn-command 'vc-mtn-program "23.1")
48 (defcustom vc-mtn-program "mtn"
49 "Name of the monotone executable."
50 :type 'string
51 :group 'vc)
53 ;; Clear up the cache to force vc-call to check again and discover
54 ;; new functions when we reload this file.
55 (put 'Mtn 'vc-functions nil)
57 (unless (executable-find vc-mtn-program)
58 ;; vc-mtn.el is 100% non-functional without the `mtn' executable.
59 (setq vc-handled-backends (delq 'Mtn vc-handled-backends)))
61 ;;;###autoload
62 (defconst vc-mtn-admin-dir "_MTN")
63 ;;;###autoload
64 (defconst vc-mtn-admin-format (concat vc-mtn-admin-dir "/format"))
66 ;;;###autoload (defun vc-mtn-registered (file)
67 ;;;###autoload (if (vc-find-root file vc-mtn-admin-format)
68 ;;;###autoload (progn
69 ;;;###autoload (load "vc-mtn")
70 ;;;###autoload (vc-mtn-registered file))))
72 (defun vc-mtn-revision-granularity () 'repository)
73 (defun vc-mtn-checkout-model (files) 'implicit)
75 (defun vc-mtn-root (file)
76 (setq file (if (file-directory-p file)
77 (file-name-as-directory file)
78 (file-name-directory file)))
79 (or (vc-file-getprop file 'vc-mtn-root)
80 (vc-file-setprop file 'vc-mtn-root
81 (vc-find-root file vc-mtn-admin-format))))
84 (defun vc-mtn-registered (file)
85 (let ((root (vc-mtn-root file)))
86 (when root
87 (vc-mtn-state file))))
89 (defun vc-mtn-command (buffer okstatus files &rest flags)
90 "A wrapper around `vc-do-command' for use in vc-mtn.el."
91 (let ((process-environment
92 ;; Avoid localization of messages so we can parse the output.
93 (cons "LC_MESSAGES=C" process-environment)))
94 (apply 'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
95 files flags)))
97 (defun vc-mtn-state (file)
98 ;; If `mtn' fails or returns status>0, or if the search files, just
99 ;; return nil.
100 (ignore-errors
101 (with-temp-buffer
102 (vc-mtn-command t 0 file "status")
103 (goto-char (point-min))
104 (re-search-forward
105 "^ \\(?:\\(patched\\)\\|\\(added\\) \\(?:.*\\)\\)\\|no changes$")
106 (cond ((match-end 1) 'edited)
107 ((match-end 2) 'added)
108 (t 'up-to-date)))))
110 (defun vc-mtn-after-dir-status (update-function)
111 (let (result)
112 (goto-char (point-min))
113 (re-search-forward "\\(?:Current b\\|B\\)ranch: *\\(.*\\)\n?\nChanges against parent \\(.*\\)" nil t)
114 (while (re-search-forward
115 "^ \\(?:\\(patched \\)\\|\\(added \\)\\)\\(.*\\)$" nil t)
116 (cond ((match-end 1) (push (list (match-string 3) 'edited) result))
117 ((match-end 2) (push (list (match-string 3) 'added) result))))
118 (funcall update-function result)))
120 (defun vc-mtn-dir-status (dir update-function)
121 (vc-mtn-command (current-buffer) 'async dir "status")
122 (vc-exec-after
123 `(vc-mtn-after-dir-status (quote ,update-function))))
125 (defun vc-mtn-working-revision (file)
126 ;; If `mtn' fails or returns status>0, or if the search fails, just
127 ;; return nil.
128 (ignore-errors
129 (with-temp-buffer
130 (vc-mtn-command t 0 file "status")
131 (goto-char (point-min))
132 (re-search-forward "\\(?:Current b\\|B\\)ranch: *\\(.*\\)\n?\nChanges against parent \\(.*\\)")
133 (match-string 2))))
135 (defun vc-mtn-workfile-branch (file)
136 ;; If `mtn' fails or returns status>0, or if the search files, just
137 ;; return nil.
138 (ignore-errors
139 (with-temp-buffer
140 (vc-mtn-command t 0 file "status")
141 (goto-char (point-min))
142 (re-search-forward "\\(?:Current b\\|B\\)ranch: *\\(.*\\)\n?\nChanges against parent \\(.*\\)")
143 (match-string 1))))
145 (defun vc-mtn-workfile-unchanged-p (file)
146 (not (eq (vc-mtn-state file) 'edited)))
148 ;; Mode-line rewrite code copied from vc-arch.el.
150 (defcustom vc-mtn-mode-line-rewrite
151 '(("\\`[^:/#]*[:/#]" . "")) ;Drop the host part.
152 "Rewrite rules to shorten Mtn's revision names on the mode-line."
153 :type '(repeat (cons regexp string))
154 :version "22.2"
155 :group 'vc)
157 (defun vc-mtn-mode-line-string (file)
158 "Return string for placement in modeline by `vc-mode-line' for FILE."
159 (let ((branch (vc-mtn-workfile-branch file)))
160 (dolist (rule vc-mtn-mode-line-rewrite)
161 (if (string-match (car rule) branch)
162 (setq branch (replace-match (cdr rule) t nil branch))))
163 (format "Mtn%c%s"
164 (case (vc-state file)
165 ((up-to-date needs-update) ?-)
166 (added ?@)
167 (t ?:))
168 branch)))
170 (defun vc-mtn-register (files &optional rev comment)
171 (vc-mtn-command nil 0 files "add"))
173 (defun vc-mtn-responsible-p (file) (vc-mtn-root file))
174 (defun vc-mtn-could-register (file) (vc-mtn-root file))
176 (declare-function log-edit-extract-headers "log-edit" (headers string))
178 (defun vc-mtn-checkin (files rev comment)
179 (apply 'vc-mtn-command nil 0 files
180 (nconc (list "commit" "-m")
181 (log-edit-extract-headers '(("Author" . "--author")
182 ("Date" . "--date"))
183 comment))))
185 (defun vc-mtn-find-revision (file rev buffer)
186 (vc-mtn-command buffer 0 file "cat" "-r" rev))
188 ;; (defun vc-mtn-checkout (file &optional editable rev)
189 ;; )
191 (defun vc-mtn-revert (file &optional contents-done)
192 (unless contents-done
193 (vc-mtn-command nil 0 file "revert")))
195 ;; (defun vc-mtn-roolback (files)
196 ;; )
198 (defun vc-mtn-print-log (files buffer &optional shortlog start-revision limit)
199 (apply 'vc-mtn-command buffer 0 files "log"
200 (append
201 (when start-revision (list "--from" (format "%s" start-revision)))
202 (when limit (list "--last" (format "%s" limit))))))
204 (defvar log-view-message-re)
205 (defvar log-view-file-re)
206 (defvar log-view-font-lock-keywords)
207 (defvar log-view-per-file-logs)
209 (define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View"
210 ;; Don't match anything.
211 (set (make-local-variable 'log-view-file-re) "\\`a\\`")
212 (set (make-local-variable 'log-view-per-file-logs) nil)
213 ;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives
214 ;; in the ChangeLog text.
215 (set (make-local-variable 'log-view-message-re)
216 "^[ |/]+Revision: \\([0-9a-f]+\\)")
217 (require 'add-log) ;For change-log faces.
218 (set (make-local-variable 'log-view-font-lock-keywords)
219 (append log-view-font-lock-keywords
220 '(("^[ |]+Author: \\(.*\\)" (1 'change-log-email))
221 ("^[ |]+Date: \\(.*\\)" (1 'change-log-date-face))))))
223 ;; (defun vc-mtn-show-log-entry (revision)
224 ;; )
226 (defun vc-mtn-diff (files &optional rev1 rev2 buffer)
227 "Get a difference report using monotone between two revisions of FILES."
228 (apply 'vc-mtn-command (or buffer "*vc-diff*") 1 files "diff"
229 (append
230 (vc-switches 'mtn 'diff)
231 (if rev1 (list "-r" rev1)) (if rev2 (list "-r" rev2)))))
233 (defun vc-mtn-annotate-command (file buf &optional rev)
234 (apply 'vc-mtn-command buf 'async file "annotate"
235 (if rev (list "-r" rev))))
237 (declare-function vc-annotate-convert-time "vc-annotate" (time))
239 (defconst vc-mtn-annotate-full-re
240 "^ *\\([0-9a-f]+\\)\\.* by [^ ]+ \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\): ")
241 (defconst vc-mtn-annotate-any-re
242 (concat "^\\(?: +: \\|" vc-mtn-annotate-full-re "\\)"))
244 (defun vc-mtn-annotate-time ()
245 (when (looking-at vc-mtn-annotate-any-re)
246 (goto-char (match-end 0))
247 (let ((year (match-string 2)))
248 (if (not year)
249 ;; Look for the date on a previous line.
250 (save-excursion
251 (get-text-property (1- (previous-single-property-change
252 (point) 'vc-mtn-time nil (point-min)))
253 'vc-mtn-time))
254 (let ((time (vc-annotate-convert-time
255 (encode-time 0 0 0
256 (string-to-number (match-string 4))
257 (string-to-number (match-string 3))
258 (string-to-number year)
259 t))))
260 (let ((inhibit-read-only t)
261 (inhibit-modification-hooks t))
262 (put-text-property (match-beginning 0) (match-end 0)
263 'vc-mtn-time time))
264 time)))))
266 (defun vc-mtn-annotate-extract-revision-at-line ()
267 (save-excursion
268 (when (or (looking-at vc-mtn-annotate-full-re)
269 (re-search-backward vc-mtn-annotate-full-re nil t))
270 (match-string 1))))
272 ;;; Revision completion.
274 (defun vc-mtn-list-tags ()
275 (with-temp-buffer
276 (vc-mtn-command t 0 nil "list" "tags")
277 (goto-char (point-min))
278 (let ((tags ()))
279 (while (re-search-forward "^[^ ]+" nil t)
280 (push (match-string 0) tags))
281 tags)))
283 (defun vc-mtn-list-branches ()
284 (with-temp-buffer
285 (vc-mtn-command t 0 nil "list" "branches")
286 (goto-char (point-min))
287 (let ((branches ()))
288 (while (re-search-forward "^.+" nil t)
289 (push (match-string 0) branches))
290 branches)))
292 (defun vc-mtn-list-revision-ids (prefix)
293 (with-temp-buffer
294 (vc-mtn-command t 0 nil "complete" "revision" prefix)
295 (goto-char (point-min))
296 (let ((ids ()))
297 (while (re-search-forward "^.+" nil t)
298 (push (match-string 0) ids))
299 ids)))
301 (defun vc-mtn-revision-completion-table (files)
302 ;; TODO: Implement completion for selectors
303 ;; TODO: Implement completion for composite selectors.
304 (lexical-let ((files files))
305 ;; What about using `files'?!? --Stef
306 (lambda (string pred action)
307 (cond
308 ;; "Tag" selectors.
309 ((string-match "\\`t:" string)
310 (complete-with-action action
311 (mapcar (lambda (tag) (concat "t:" tag))
312 (vc-mtn-list-tags))
313 string pred))
314 ;; "Branch" selectors.
315 ((string-match "\\`b:" string)
316 (complete-with-action action
317 (mapcar (lambda (tag) (concat "b:" tag))
318 (vc-mtn-list-branches))
319 string pred))
320 ;; "Head" selectors. Not sure how they differ from "branch" selectors.
321 ((string-match "\\`h:" string)
322 (complete-with-action action
323 (mapcar (lambda (tag) (concat "h:" tag))
324 (vc-mtn-list-branches))
325 string pred))
326 ;; "ID" selectors.
327 ((string-match "\\`i:" string)
328 (complete-with-action action
329 (mapcar (lambda (tag) (concat "i:" tag))
330 (vc-mtn-list-revision-ids
331 (substring string (match-end 0))))
332 string pred))
334 (complete-with-action action
335 '("t:" "b:" "h:" "i:"
336 ;; Completion not implemented for these.
337 "a:" "c:" "d:" "e:" "l:")
338 string pred))))))
342 (provide 'vc-mtn)
344 ;;; vc-mtn.el ends here