1 ;;; vc-bzr.el --- VC backend for the bzr revision control system
3 ;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
5 ;; NOTE: THIS IS A MODIFIED VERSION OF Dave Love's vc-bzr.el,
6 ;; which you can find at: http://www.loveshack.ukfsn.org/emacs/vc-bzr.el
7 ;; I could not get in touch with Dave Love by email, so
8 ;; I am releasing my changes separately. -- Riccardo
10 ;; Author: Dave Love <fx@gnu.org>, Riccardo Murri <riccardo.murri@gmail.com>
13 ;; Version: 2007-01-17
14 ;; URL: http://launchpad.net/vc-bzr
16 ;; This file is free software; you can redistribute it and/or modify
17 ;; it under the terms of the GNU General Public License as published by
18 ;; the Free Software Foundation; either version 2, or (at your option)
21 ;; This file is distributed in the hope that it will be useful,
22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 ;; GNU General Public License for more details.
26 ;; You should have received a copy of the GNU General Public License
27 ;; along with GNU Emacs; see the file COPYING. If not, write to the
28 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 ;; Boston, MA 02110-1301, USA.
34 ;; NOTE: THIS IS A MODIFIED VERSION OF Dave Love's vc-bzr.el,
35 ;; which you can find at: http://www.loveshack.ukfsn.org/emacs/vc-bzr.el
37 ;; See <URL:http://bazaar-vcs.org/> concerning bzr.
39 ;; Load this library to register bzr support in VC. The support is
40 ;; preliminary and incomplete, adapted from my darcs version. Lightly
41 ;; exercised with bzr 0.8 and Emacs 21, and bzr 0.11 on Emacs 22. See
42 ;; various Fixmes below.
44 ;; This should be suitable for direct inclusion in Emacs if someone
51 (require 'vc
)) ; for vc-exec-after
58 (defcustom vc-bzr-program
"bzr"
59 "*Name of the bzr command (excluding any arguments)."
63 ;; Fixme: there's probably no call for this.
64 (defcustom vc-bzr-program-args nil
65 "*List of global arguments to pass to `vc-bzr-program'."
67 :type
'(repeat string
))
69 (defcustom vc-bzr-diff-switches nil
70 "*String/list of strings specifying extra switches for bzr diff under VC."
71 :type
'(choice (const :tag
"None" nil
)
72 (string :tag
"Argument String")
73 (repeat :tag
"Argument List" :value
("") string
))
76 (defvar vc-bzr-version nil
79 ;; Could be used for compatibility checks if bzr changes.
80 (defun vc-bzr-version ()
81 "Return a three-numeric element list with components of the bzr version.
82 This is of the form (X Y Z) for revision X.Y.Z. The elements are zero
83 if running `vc-bzr-program' doesn't produce the expected output."
86 (let ((s (shell-command-to-string
87 (concat (shell-quote-argument vc-bzr-program
) " --version"))))
88 (if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" s
)
89 (setq vc-bzr-version
(list (string-to-number (match-string 1 s
))
90 (string-to-number (match-string 2 s
))
91 (string-to-number (match-string 3 s
))))
94 (defun vc-bzr-at-least-version (vers)
95 "Return t if the bzr command reports being a least version VERS.
96 First argument VERS is a list of the form (X Y Z), as returned by `vc-bzr-version'."
97 (version-list-<= vers
(vc-bzr-version)))
99 ;; XXX: vc-do-command is tailored for RCS and assumes that command-line
100 ;; options precede the file name (ci -something file); with bzr, we need
101 ; to pass options *after* the subcommand, e.g. bzr ls --versioned.
102 (defun vc-bzr-do-command* (buffer okstatus command
&rest args
)
103 "Execute bzr COMMAND, notifying user and checking for errors.
104 This is a wrapper around `vc-do-command', which see for detailed
105 explanation of arguments BUFFER, OKSTATUS and COMMAND.
107 If the optional list of ARGS is present, its elements are
108 appended to the command line, in the order given.
110 Unlike `vc-do-command', this has no way of telling which elements
111 in ARGS are file names and which are command-line options, so be
112 sure to pass absolute file names if needed. On the other hand,
113 you can mix options and file names in any order."
114 (apply 'vc-do-command buffer okstatus command nil args
))
117 ((vc-bzr-at-least-version '(0 9))
118 ;; since v0.9, bzr supports removing the progress indicators
119 ;; by setting environment variable BZR_PROGRESS_BAR to "none".
120 (defun vc-bzr-command (bzr-command buffer okstatus file
&rest args
)
121 "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
122 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment."
123 (let ((process-environment (cons "BZR_PROGRESS_BAR=none" process-environment
)))
124 (apply 'vc-do-command buffer okstatus vc-bzr-program
125 file bzr-command
(append vc-bzr-program-args args
))))
127 (defun vc-bzr-command* (bzr-command buffer okstatus file
&rest args
)
128 "Wrapper round `vc-bzr-do-command*' using `vc-bzr-program' as COMMAND.
129 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment.
130 First argument BZR-COMMAND is passed as the first optional argument to
131 `vc-bzr-do-command*'."
132 (let ((process-environment (cons "BZR_PROGRESS_BAR=none" process-environment
)))
133 (apply 'vc-bzr-do-command
* buffer okstatus vc-bzr-program
134 bzr-command
(append vc-bzr-program-args args
)))))
137 ;; for older versions, we fall back to washing the log buffer
138 ;; when all output has been gathered.
139 (defun vc-bzr-command (command buffer okstatus file
&rest args
)
140 "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND."
141 ;; Note: The ^Ms from the progress-indicator stuff that bzr prints
142 ;; on stderr cause auto-detection of a mac coding system on the
143 ;; stream for async output. bzr ought to be fixed to be able to
144 ;; suppress this. See also `vc-bzr-post-command-function'. (We
145 ;; can't sink the stderr output in `vc-do-command'.)
146 (apply 'vc-do-command buffer okstatus vc-bzr-program
147 file command
(append vc-bzr-program-args args
)))
149 (defun vc-bzr-command* (command buffer okstatus
&rest args
)
150 "Wrapper round `vc-bzr-do-command*' using `vc-bzr-program' as COMMAND."
151 (apply 'vc-bzr-do-command
* buffer okstatus vc-bzr-program
152 command file
(append vc-bzr-program-args args
)))
154 (defun vc-bzr-post-command-function (command file flags
)
155 "`vc-post-command-functions' function to remove progress messages."
156 ;; Note that using this requires that the vc command is run
157 ;; synchronously. Otherwise, the ^Ms in the leading progress
158 ;; message on stdout cause the stream to be interpreted as having
159 ;; DOS line endings, losing the ^Ms, so the search fails. I don't
160 ;; know how this works under Windows.
161 (when (equal command vc-bzr-program
)
163 (goto-char (point-min))
164 (if (looking-at "^\\(\r.*\r\\)[^\r]+$")
165 (replace-match "" nil nil nil
1)))
167 (goto-char (point-min))
168 ;; This is inserted by bzr 0.11 `log', at least
169 (while (looking-at "read knit.*\n")
170 (replace-match "")))))
172 (add-hook 'vc-post-command-functions
'vc-bzr-post-command-function
)))
174 ;; Fixme: If we're only interested in status messages, we only need
175 ;; to set LC_MESSAGES, and we might need finer control of this. This
176 ;; is moot anyhow, since bzr doesn't appear to be localized at all
179 (defmacro vc-bzr-with-c-locale
(&rest body
)
180 "Run BODY with LC_ALL=C in the process environment.
181 This ensures that messages to be matched come out as expected."
182 `(let ((process-environment (cons "LC_ALL=C" process-environment
)))
184 (put 'vc-bzr-with-c-locale
'edebug-form-spec t
)
185 (put 'vc-bzr-with-c-locale
'lisp-indent-function
0)
187 (defun vc-bzr-bzr-dir (file)
188 "Return the .bzr directory in the hierarchy above FILE.
189 Return nil if there isn't one."
190 (setq file
(expand-file-name file
))
191 (let ((dir (if (file-directory-p file
)
193 (file-name-directory file
)))
197 (setq bzr
(expand-file-name ".bzr" dir
)) ; fixme: "_bzr" on Doze??
198 (if (file-directory-p bzr
)
199 (throw 'found
(file-name-as-directory bzr
)))
200 (if (equal "" (file-name-nondirectory (directory-file-name dir
)))
202 (setq dir
(file-name-directory (directory-file-name dir
))))))))
204 (defun vc-bzr-registered (file)
205 "Return non-nil if FILE is registered with bzr."
206 (if (vc-bzr-bzr-dir file
) ; short cut
207 (vc-bzr-state file
))) ; expensive
209 (defun vc-bzr-state (file)
210 (let (ret state conflicts pending-merges
)
212 (cd (file-name-directory file
))
213 (setq ret
(vc-bzr-with-c-locale (vc-bzr-command "status" t
255 file
)))
216 (when (re-search-forward "^conflicts:" nil t
)
217 (message "Warning -- conflicts in bzr branch")))
219 (when (re-search-forward "^pending merges:" nil t
)
220 (message "Warning -- pending merges in bzr branch")))
222 (cond ((not (equal ret
0)) nil
)
223 ((looking-at "added\\|renamed\\|modified\\|removed") 'edited
)
224 ;; Fixme: Also get this in a non-registered sub-directory.
225 ((looking-at "^$") 'up-to-date
)
226 ;; if we're seeing this as first line of text,
227 ;; then the status is up-to-date,
228 ;; but bzr output only gives the warning to users.
229 ((looking-at "conflicts\\|pending") 'up-to-date
)
230 ((looking-at "unknown\\|ignored") nil
)
231 (t (error "Unrecognized output from `bzr status'"))))
232 (when (or conflicts pending-merges
)
234 (concat "Warning -- "
235 (if conflicts
"conflicts ")
236 (if (and conflicts pending-merges
) "and ")
237 (if pending-merges
"pending merges ")
240 (vc-file-setprop file
'vc-workfile-version
241 (vc-bzr-workfile-version file
))
242 (vc-file-setprop file
'vc-state state
))
245 (defun vc-bzr-workfile-unchanged-p (file)
246 (eq 'up-to-date
(vc-bzr-state file
)))
248 (defun vc-bzr-workfile-version (file)
250 (vc-bzr-command "revno" t
0 file
)
252 (buffer-substring 1 (line-end-position))))
254 (defun vc-bzr-checkout-model (file)
257 (defun vc-bzr-register (file &optional rev comment
)
258 "Register FILE under bzr.
259 Signal an error unless REV is nil.
261 (if rev
(error "Can't register explicit version with bzr"))
262 (vc-bzr-command "add" nil
0 file
))
264 ;; Could run `bzr status' in the directory and see if it succeeds, but
265 ;; that's relatively expensive.
266 (defun vc-bzr-responsible-p (file)
267 "Return non-nil if FILE is (potentially) controlled by bzr.
268 The criterion is that there is a `.bzr' directory in the same
269 or a superior directory."
270 (vc-bzr-bzr-dir file
))
272 (defun vc-bzr-could-register (file)
273 "Return non-nil if FILE could be registered under bzr."
274 (and (vc-bzr-responsible-p file
) ; shortcut
277 (vc-bzr-command "add" t
0 file
"--dry-run")
278 ;; The command succeeds with no output if file is
279 ;; registered (in bzr 0.8).
281 (looking-at "added "))
284 (defun vc-bzr-unregister (file)
285 "Unregister FILE from bzr."
286 (vc-bzr-command "remove" nil
0 file
))
288 (defun vc-bzr-checkin (file rev comment
)
289 "Check FILE in to bzr with log message COMMENT.
290 REV non-nil gets an error."
291 (if rev
(error "Can't check in a specific version with bzr"))
292 (vc-bzr-command "commit" nil
0 file
"-m" comment
))
294 (defun vc-bzr-checkout (file &optional editable rev destfile
)
295 "Checkout revision REV of FILE from bzr to DESTFILE.
296 EDITABLE is ignored."
298 (setq destfile
(vc-version-backup-file-name file rev
)))
299 (let ((coding-system-for-read 'binary
)
300 (coding-system-for-write 'binary
))
301 (with-temp-file destfile
303 (vc-bzr-command "cat" t
0 file
"-r" rev
)
304 (vc-bzr-command "cat" t
0 file
)))))
306 (defun vc-bzr-revert (file &optional contents-done
)
307 (unless contents-done
308 (with-temp-buffer (vc-bzr-command "revert" t
'async file
))))
311 (defvar log-view-message-re
)
312 (defvar log-view-file-re
)
313 (defvar log-view-font-lock-keywords
)
314 (defvar log-view-current-tag-function
))
316 ;; Grim hack to account for lack of an extension mechanism for
317 ;; log-view. Should be fixed in VC...
318 (defun vc-bzr-view-log-function ()
319 "To be added to `log-view-mode-hook' to set variables for bzr output.
320 Removes itself after running."
321 (remove-hook 'log-view-mode-hook
'vc-bzr-view-log-function
)
323 ;; Don't have file markers, so use impossible regexp.
324 (set (make-local-variable 'log-view-file-re
) "\\'\\`")
325 (set (make-local-variable 'log-view-message-re
) "^ *-+\n *\\(revno: [0-9]+\\|merged: .+\\)")
326 (set (make-local-variable 'log-view-font-lock-keywords
)
328 \\([^<(]+?\\)[ ]*[(<]\\([A-Za-z0-9_.-]+@[A-Za-z0-9_.-]+\\)[>)]"
330 (1 'change-log-name-face nil t
)
331 (2 'change-log-email-face nil t
)
332 (3 'change-log-email-face nil t
))
333 ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face
))
334 (,log-view-message-re .
'log-view-message-face
)
335 ;; ("^ \\(.*\\)$" (1 'log-view-message-face))
338 (defun vc-bzr-print-log (file &optional buffer
) ; get buffer arg in Emacs 22
339 "Get bzr change log for FILE into specified BUFFER."
340 ;; Fixme: VC needs a hook to sort out the mode for the buffer, or at
341 ;; least set the regexps right.
342 ;; Fixme: This might need the locale fixing up if things like `revno'
343 ;; got localized, but certainly it shouldn't use LC_ALL=C.
344 ;; NB. Can't be async -- see `vc-bzr-post-command-function'.
345 (vc-bzr-command "log" buffer
0 file
)
346 (add-hook 'log-view-mode-hook
'vc-bzr-view-log-function
))
348 (defun vc-bzr-show-log-entry (version)
349 "Find entry for patch name VERSION in bzr change log buffer."
350 (goto-char (point-min))
351 (let (case-fold-search)
352 (if (re-search-forward (concat "^-+\nrevno: " version
"$") nil t
)
353 (beginning-of-line 0)
354 (goto-char (point-min)))))
356 ;; Fixem: vc-bzr-wash-log
358 (autoload 'vc-diff-switches-list
"vc" nil nil t
)
360 (defun vc-bzr-diff (file &optional rev1 rev2 buffer
)
361 "VC bzr backend for diff."
362 (let ((working (vc-workfile-version file
)))
363 (if (and (equal rev1 working
) (not rev2
))
365 (if (and (not rev1
) rev2
)
367 ;; NB. Can't be async -- see `vc-bzr-post-command-function'.
368 ;; bzr diff produces condition code 1 for some reason.
369 (apply #'vc-bzr-command
"diff" (or buffer
"*vc-diff*") 1 file
370 "--diff-options" (mapconcat 'identity
(vc-diff-switches-list bzr
)
374 (list "-r" (format "%s..%s" rev1 rev2
))
375 (list "-r" rev1
))))))
377 (defalias 'vc-bzr-diff-tree
'vc-bzr-diff
)
379 ;; Fixme: implement vc-bzr-dir-state, vc-bzr-dired-state-info
381 ;; Fixme: vc-{next,previous}-version need fixing in vc.el to deal with
382 ;; straight integer versions.
384 (defun vc-bzr-delete-file (file)
385 "Delete FILE and delete it in the bzr repository."
389 (vc-bzr-command "remove" nil
0 file
))
391 (defun vc-bzr-rename-file (old new
)
392 "Rename file from OLD to NEW using `bzr mv'."
393 (vc-bzr-command "mv" nil
0 new old
))
395 (defvar vc-bzr-annotation-table nil
397 (make-variable-buffer-local 'vc-bzr-annotation-table
)
399 (defun vc-bzr-annotate-command (file buffer
&optional version
)
400 "Prepare BUFFER for `vc-annotate' on FILE.
401 Each line is tagged with the revision number, which has a `help-echo'
402 property containing author and date information."
403 (apply #'vc-bzr-command
"annotate" buffer
0 file
"-l" "--all"
404 (if version
(list "-r" version
)))
405 (with-current-buffer buffer
406 ;; Store the tags for the annotated source lines in a hash table
407 ;; to allow saving space by sharing the text properties.
408 (setq vc-bzr-annotation-table
(make-hash-table :test
'equal
))
409 (goto-char (point-min))
410 (while (re-search-forward "^\\( *[0-9]+\\) \\(.+\\) +\\([0-9]\\{8\\}\\) |"
412 (let* ((rev (match-string 1))
413 (author (match-string 2))
414 (date (match-string 3))
415 (key (match-string 0))
416 (tag (gethash key vc-bzr-annotation-table
)))
419 (string-match " +\\'" author
)
420 (setq author
(substring author
0 (match-beginning 0))))
421 (setq tag
(propertize rev
'help-echo
(concat "Author: " author
423 'mouse-face
'highlight
))
424 (puthash key tag vc-bzr-annotation-table
))
426 (insert tag
" |")))))
428 ;; Definition from Emacs 22
429 (unless (fboundp 'vc-annotate-convert-time
)
430 (defun vc-annotate-convert-time (time)
431 "Convert a time value to a floating-point number of days.
432 The argument TIME is a list as returned by `current-time' or
433 `encode-time', only the first two elements of that list are considered."
434 (/ (+ (* (float (car time
)) (lsh 1 16)) (cadr time
)) 24 3600)))
436 (defun vc-bzr-annotate-time ()
437 (when (re-search-forward "^ *[0-9]+ |" nil t
)
438 (let ((prop (get-text-property (line-beginning-position) 'help-echo
)))
439 (string-match "[0-9]+\\'" prop
)
440 (vc-annotate-convert-time
442 (string-to-number (substring (match-string 0 prop
) 6 8))
443 (string-to-number (substring (match-string 0 prop
) 4 6))
444 (string-to-number (substring (match-string 0 prop
) 0 4))
447 (defun vc-bzr-annotate-extract-revision-at-line ()
448 "Return revision for current line of annoation buffer, or nil.
449 Return nil if current line isn't annotated."
452 (if (looking-at " *\\([0-9]+\\) | ")
453 (match-string-no-properties 1))))
455 ;; Not needed for Emacs 22
456 (defun vc-bzr-annotate-difference (point)
457 (let ((next-time (vc-bzr-annotate-time)))
459 (- (vc-annotate-convert-time (current-time)) next-time
))))
461 ;; FIXME: `bzr root' will return the real path to the repository root,
462 ;; that is, it can differ from the buffer's current directory name
463 ;; if there are any symbolic links.
464 (defun vc-bzr-root (dir)
465 "Return the root directory of the bzr repository containing DIR."
467 (shell-command-to-string (concat vc-bzr-program
" root " dir
)) 0 -
1))
469 ;; TODO: it would be nice to mark the conflicted files in VC Dired,
470 ;; and implement a command to run ediff and `bzr resolve' once the
471 ;; changes have been merged.
472 (defun vc-bzr-dir-state (dir &optional localp
)
473 "Find the VC state of all files in DIR.
474 Optional argument LOCALP is always ignored."
475 (let (at-start bzr-root-directory current-bzr-state current-vc-state
)
476 ;; check that DIR is a bzr repository
477 (set 'bzr-root-directory
(vc-bzr-root dir
))
478 (unless (string-match "^/" bzr-root-directory
)
479 (error "Cannot find bzr repository for directory `%s'" dir
))
480 ;; `bzr ls --versioned' lists all versioned files;
481 ;; assume they are up-to-date, unless we are given
482 ;; evidence of the contrary.
485 (vc-bzr-command* "ls" t
0 "--versioned" "--non-recursive")
486 (goto-char (point-min))
488 (eq 0 (forward-line)))
490 (let ((file (expand-file-name
491 (buffer-substring-no-properties
492 (line-beginning-position) (line-end-position))
493 bzr-root-directory
)))
494 (vc-file-setprop file
'vc-state
'up-to-date
)
495 ;; XXX: is this correct? what happens if one
496 ;; mixes different SCMs in the same dir?
497 (vc-file-setprop file
'vc-backend
'BZR
))))
498 ;; `bzr status' reports on added/modified/renamed and unknown/ignored files
501 (vc-bzr-with-c-locale (vc-bzr-command "status" t
0 nil
))
502 (goto-char (point-min))
504 (eq 0 (forward-line)))
507 ((looking-at "^added")
508 (set 'current-vc-state
'edited
)
509 (set 'current-bzr-state
'added
))
510 ((looking-at "^modified")
511 (set 'current-vc-state
'edited
)
512 (set 'current-bzr-state
'modified
))
513 ((looking-at "^renamed")
514 (set 'current-vc-state
'edited
)
515 (set 'current-bzr-state
'renamed
))
516 ((looking-at "^\\(unknown\\|ignored\\)")
517 (set 'current-vc-state nil
)
518 (set 'current-bzr-state
'not-versioned
))
520 ;; file names are indented by two spaces
521 (when current-vc-state
522 (let ((file (expand-file-name
523 (buffer-substring-no-properties
524 (match-end 0) (line-end-position))
525 bzr-root-directory
)))
526 (vc-file-setprop file
'vc-state current-vc-state
)
527 (vc-file-setprop file
'vc-bzr-state current-bzr-state
)
528 (when (eq 'added current-bzr-state
)
529 (vc-file-setprop file
'vc-workfile-version
"0"))))
530 (when (eq 'not-versioned current-bzr-state
)
531 (let ((file (expand-file-name
532 (buffer-substring-no-properties
533 (match-end 0) (line-end-position))
534 bzr-root-directory
)))
535 (vc-file-setprop file
'vc-backend
'none
)
536 (vc-file-setprop file
'vc-state nil
))))
538 ;; skip this part of `bzr status' output
539 (set 'current-vc-state nil
)
540 (set 'current-bzr-state nil
)))))))
542 (defun vc-bzr-dired-state-info (file)
543 "Bzr-specific version of `vc-dired-state-info'."
544 (if (eq 'edited
(vc-state file
))
545 (let ((bzr-state (vc-file-getprop file
'vc-bzr-state
)))
547 (concat "(" (symbol-name bzr-state
) ")")
548 ;; else fall back to default vc representation
549 (vc-default-dired-state-info 'BZR file
)))))
551 ;; In case of just `(load "vc-bzr")', but that's probably the wrong
553 (add-to-list 'vc-handled-backends
'BZR
)
555 (eval-after-load "vc"
556 '(add-to-list 'vc-directory-exclusion-list
".bzr" t
))
558 (defconst vc-bzr-unload-hook
560 (setq vc-handled-backends
(delq 'BZR vc-handled-backends
))
561 (remove-hook 'vc-post-command-functions
'vc-bzr-post-command-function
)))
564 ;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06
565 ;;; vc-bzr.el ends here