Merge from emacs-24; up to 2013-01-02T10:15:31Z!michael.albinus@gmx.de
[emacs.git] / lisp / vc / vc-bzr.el
blobe59a7dc5214f52f53a052d554cc97971133e9a6f
1 ;;; vc-bzr.el --- VC backend for the bzr revision control system -*- lexical-binding: t -*-
3 ;; Copyright (C) 2006-2013 Free Software Foundation, Inc.
5 ;; Author: Dave Love <fx@gnu.org>
6 ;; Riccardo Murri <riccardo.murri@gmail.com>
7 ;; Maintainer: FSF
8 ;; Keywords: vc tools
9 ;; Created: Sept 2006
10 ;; Package: vc
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;;; Commentary:
29 ;; See <URL:http://bazaar.canonical.com/> concerning bzr.
31 ;; This library provides bzr support in VC.
33 ;; Known bugs
34 ;; ==========
36 ;; When editing a symlink and *both* the symlink and its target
37 ;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
38 ;; symlink, thereby not detecting whether the actual contents
39 ;; (that is, the target contents) are changed.
41 ;;; Properties of the backend
43 (defun vc-bzr-revision-granularity () 'repository)
44 (defun vc-bzr-checkout-model (_files) 'implicit)
46 ;;; Code:
48 (eval-when-compile
49 (require 'cl-lib)
50 (require 'vc-dir)) ; vc-dir-at-event
52 ;; Clear up the cache to force vc-call to check again and discover
53 ;; new functions when we reload this file.
54 (put 'Bzr 'vc-functions nil)
56 (defgroup vc-bzr nil
57 "VC Bazaar (bzr) backend."
58 :version "22.2"
59 :group 'vc)
61 (defcustom vc-bzr-program "bzr"
62 "Name of the bzr command (excluding any arguments)."
63 :group 'vc-bzr
64 :type 'string)
66 (defcustom vc-bzr-diff-switches nil
67 "String or list of strings specifying switches for bzr diff under VC.
68 If nil, use the value of `vc-diff-switches'. If t, use no switches."
69 :type '(choice (const :tag "Unspecified" nil)
70 (const :tag "None" t)
71 (string :tag "Argument String")
72 (repeat :tag "Argument List" :value ("") string))
73 :group 'vc-bzr)
75 (defcustom vc-bzr-log-switches nil
76 "String or list of strings specifying switches for bzr log under VC."
77 :type '(choice (const :tag "None" nil)
78 (string :tag "Argument String")
79 (repeat :tag "Argument List" :value ("") string))
80 :group 'vc-bzr)
82 (defcustom vc-bzr-status-switches
83 (ignore-errors
84 (with-temp-buffer
85 (call-process vc-bzr-program nil t nil "help" "status")
86 (if (search-backward "--no-classify" nil t)
87 "--no-classify")))
88 "String or list of strings specifying switches for bzr status under VC.
89 The option \"--no-classify\" should be present if your bzr supports it."
90 :type '(choice (const :tag "None" nil)
91 (string :tag "Argument String")
92 (repeat :tag "Argument List" :value ("") string))
93 :group 'vc-bzr
94 :version "24.1")
96 ;; since v0.9, bzr supports removing the progress indicators
97 ;; by setting environment variable BZR_PROGRESS_BAR to "none".
98 (defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args)
99 "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
100 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
101 `LC_MESSAGES=C' to the environment. If BZR-COMMAND is \"status\",
102 prepends `vc-bzr-status-switches' to ARGS."
103 (let ((process-environment
104 `("BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
105 "LC_MESSAGES=C" ; Force English output
106 ,@process-environment)))
107 (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
108 file-or-list bzr-command
109 (if (and (string-equal "status" bzr-command)
110 vc-bzr-status-switches)
111 (append (if (stringp vc-bzr-status-switches)
112 (list vc-bzr-status-switches)
113 vc-bzr-status-switches)
114 args)
115 args))))
117 (defun vc-bzr-async-command (bzr-command &rest args)
118 "Wrapper round `vc-do-async-command' using `vc-bzr-program' as COMMAND.
119 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
120 `LC_MESSAGES=C' to the environment.
121 Use the current Bzr root directory as the ROOT argument to
122 `vc-do-async-command', and specify an output buffer named
123 \"*vc-bzr : ROOT*\". Return this buffer."
124 (let* ((process-environment
125 `("BZR_PROGRESS_BAR=none" "LC_MESSAGES=C"
126 ,@process-environment))
127 (root (vc-bzr-root default-directory))
128 (buffer (format "*vc-bzr : %s*" (expand-file-name root))))
129 (apply 'vc-do-async-command buffer root
130 vc-bzr-program bzr-command args)
131 buffer))
133 ;;;###autoload
134 (defconst vc-bzr-admin-dirname ".bzr"
135 "Name of the directory containing Bzr repository status files.")
136 ;; Used in the autoloaded vc-bzr-registered; see below.
137 ;;;###autoload
138 (defconst vc-bzr-admin-checkout-format-file
139 (concat vc-bzr-admin-dirname "/checkout/format")
140 "Name of the format file in a .bzr directory.")
141 (defconst vc-bzr-admin-dirstate
142 (concat vc-bzr-admin-dirname "/checkout/dirstate"))
143 (defconst vc-bzr-admin-branch-format-file
144 (concat vc-bzr-admin-dirname "/branch/format"))
145 (defconst vc-bzr-admin-revhistory
146 (concat vc-bzr-admin-dirname "/branch/revision-history"))
147 (defconst vc-bzr-admin-lastrev
148 (concat vc-bzr-admin-dirname "/branch/last-revision"))
149 (defconst vc-bzr-admin-branchconf
150 (concat vc-bzr-admin-dirname "/branch/branch.conf"))
152 (defun vc-bzr-root (file)
153 "Return the root directory of the bzr repository containing FILE."
154 ;; Cache technique copied from vc-arch.el.
155 (or (vc-file-getprop file 'bzr-root)
156 (let ((root (vc-find-root file vc-bzr-admin-checkout-format-file)))
157 (when root (vc-file-setprop file 'bzr-root root)))))
159 (defun vc-bzr-branch-conf (file)
160 "Return the Bazaar branch settings for file FILE, as an alist.
161 Each element of the returned alist has the form (NAME . VALUE),
162 which are the name and value of a Bazaar setting, as strings.
164 The settings are read from the file \".bzr/branch/branch.conf\"
165 in the repository root directory of FILE."
166 (let (settings)
167 (with-temp-buffer
168 (insert-file-contents
169 (expand-file-name vc-bzr-admin-branchconf (vc-bzr-root file)))
170 (while (re-search-forward "^\\([^#=][^=]*?\\) *= *\\(.*\\)$" nil t)
171 (push (cons (match-string 1) (match-string 2)) settings)))
172 settings))
174 (defun vc-bzr-sha1 (file)
175 (with-temp-buffer
176 (set-buffer-multibyte nil)
177 (insert-file-contents-literally file)
178 (sha1 (current-buffer))))
180 (defun vc-bzr-state-heuristic (file)
181 "Like `vc-bzr-state' but hopefully without running Bzr."
182 ;; `bzr status' could be slow with large histories and pending merges,
183 ;; so this tries to avoid calling it if possible. bzr status is
184 ;; faster now, so this is not as important as it was.
186 ;; This function tries first to parse Bzr internal file
187 ;; `checkout/dirstate', but it may fail if Bzr internal file format
188 ;; has changed. As a safeguard, the `checkout/dirstate' file is
189 ;; only parsed if it contains the string `#bazaar dirstate flat
190 ;; format 3' in the first line.
191 ;; If the `checkout/dirstate' file cannot be parsed, fall back to
192 ;; running `vc-bzr-state'."
194 ;; The format of the dirstate file is explained in bzrlib/dirstate.py
195 ;; in the bzr distribution. Basically:
196 ;; header-line giving the version of the file format in use.
197 ;; a few lines of stuff
198 ;; entries, one per line, with null-separated fields. Each line:
199 ;; entry_key = dirname (may be empty), basename, file-id
200 ;; current = common ( = kind, fingerprint, size, executable )
201 ;; + working ( = packed_stat )
202 ;; parent = common ( as above ) + history ( = rev_id )
203 ;; kinds = (r)elocated, (a)bsent, (d)irectory, (f)ile, (l)ink
204 (let* ((root (vc-bzr-root file))
205 (dirstate (expand-file-name vc-bzr-admin-dirstate root)))
206 (when root ; Short cut.
207 (condition-case err
208 (with-temp-buffer
209 (insert-file-contents dirstate)
210 (goto-char (point-min))
211 (if (not (looking-at "#bazaar dirstate flat format 3"))
212 (vc-bzr-state file) ; Some other unknown format?
213 (let* ((relfile (file-relative-name file root))
214 (reldir (file-name-directory relfile)))
215 (cond
216 ((not
217 (re-search-forward
218 (concat "^\0"
219 (if reldir (regexp-quote
220 (directory-file-name reldir)))
221 "\0"
222 (regexp-quote (file-name-nondirectory relfile))
223 "\0"
224 "[^\0]*\0" ;id?
225 "\\([^\0]*\\)\0" ;"a/f/d", a=removed?
226 "\\([^\0]*\\)\0" ;sha1 (empty if conflicted)?
227 "\\([^\0]*\\)\0" ;size?p
228 ;; y/n. Whether or not the current copy
229 ;; was executable the last time bzr checked?
230 "[^\0]*\0"
231 "[^\0]*\0" ;?
232 ;; Parent information. Absent in a new repo.
233 "\\(?:\\([^\0]*\\)\0" ;"a/f/d" a=added?
234 "\\([^\0]*\\)\0" ;sha1 again?
235 "\\([^\0]*\\)\0" ;size again?
236 ;; y/n. Whether or not the repo thinks
237 ;; the file should be executable?
238 "\\([^\0]*\\)\0"
239 "[^\0]*\0\\)?" ;last revid?
240 ;; There are more fields when merges are pending.
242 nil t))
243 'unregistered)
244 ;; Apparently the second sha1 is the one we want: when
245 ;; there's a conflict, the first sha1 is absent (and the
246 ;; first size seems to correspond to the file with
247 ;; conflict markers).
248 ((eq (char-after (match-beginning 1)) ?a) 'removed)
249 ;; If there is no parent, this must be a new repo.
250 ;; If file is in dirstate, can only be added (b#8025).
251 ((or (not (match-beginning 4))
252 (eq (char-after (match-beginning 4)) ?a)) 'added)
253 ((or (and (eq (string-to-number (match-string 3))
254 (nth 7 (file-attributes file)))
255 (equal (match-string 5)
256 (save-match-data (vc-bzr-sha1 file)))
257 ;; For a file, does the executable state match?
258 ;; (Bug#7544)
259 (or (not
260 (eq (char-after (match-beginning 1)) ?f))
261 (let ((exe
262 (memq
264 (mapcar
265 'identity
266 (nth 8 (file-attributes file))))))
267 (if (eq (char-after (match-beginning 7))
270 (not exe)))))
271 (and
272 ;; It looks like for lightweight
273 ;; checkouts \2 is empty and we need to
274 ;; look for size in \6.
275 (eq (match-beginning 2) (match-end 2))
276 (eq (string-to-number (match-string 6))
277 (nth 7 (file-attributes file)))
278 (equal (match-string 5)
279 (vc-bzr-sha1 file))))
280 'up-to-date)
281 (t 'edited)))))
282 ;; The dirstate file can't be read, or some other problem.
283 (error
284 (message "Falling back on \"slow\" status detection (%S)" err)
285 (vc-bzr-state file))))))
287 ;; This is a cheap approximation that is autoloaded. If it finds a
288 ;; possible match it loads this file and runs the real function.
289 ;; It requires vc-bzr-admin-checkout-format-file to be autoloaded too.
290 ;;;###autoload (defun vc-bzr-registered (file)
291 ;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file)
292 ;;;###autoload (progn
293 ;;;###autoload (load "vc-bzr" nil t)
294 ;;;###autoload (vc-bzr-registered file))))
296 (defun vc-bzr-registered (file)
297 "Return non-nil if FILE is registered with bzr."
298 (let ((state (vc-bzr-state-heuristic file)))
299 (not (memq state '(nil unregistered ignored)))))
301 (defconst vc-bzr-state-words
302 "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown"
303 "Regexp matching file status words as reported in `bzr' output.")
305 ;; History of Bzr commands.
306 (defvar vc-bzr-history nil)
308 (defun vc-bzr-file-name-relative (filename)
309 "Return file name FILENAME stripped of the initial Bzr repository path."
310 (let* ((filename* (expand-file-name filename))
311 (rootdir (vc-bzr-root filename*)))
312 (when rootdir
313 (file-relative-name filename* rootdir))))
315 (defvar vc-bzr-error-regexp-alist
316 '(("^\\( M[* ]\\|+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1)
317 ("^C \\(.+\\)" 2)
318 ("^Text conflict in \\(.+\\)" 1 nil nil 2)
319 ("^Using saved parent location: \\(.+\\)" 1 nil nil 0))
320 "Value of `compilation-error-regexp-alist' in *vc-bzr* buffers.")
322 ;; Follows vc-bzr-(async-)command, which uses vc-do-(async-)command
323 ;; from vc-dispatcher.
324 (declare-function vc-exec-after "vc-dispatcher" (code))
325 ;; Follows vc-exec-after.
326 (declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
328 (defun vc-bzr-pull (prompt)
329 "Pull changes into the current Bzr branch.
330 Normally, this runs \"bzr pull\". However, if the branch is a
331 bound branch, run \"bzr update\" instead. If there is no default
332 location from which to pull or update, or if PROMPT is non-nil,
333 prompt for the Bzr command to run."
334 (let* ((vc-bzr-program vc-bzr-program)
335 (branch-conf (vc-bzr-branch-conf default-directory))
336 ;; Check whether the branch is bound.
337 (bound (assoc "bound" branch-conf))
338 (bound (and bound (equal "true" (downcase (cdr bound)))))
339 ;; If we need to do a "bzr pull", check for a parent. If it
340 ;; does not exist, bzr will need a pull location.
341 (has-parent (unless bound
342 (assoc "parent_location" branch-conf)))
343 (command (if bound "update" "pull"))
344 args)
345 ;; If necessary, prompt for the exact command.
346 (when (or prompt (not (or bound has-parent)))
347 (setq args (split-string
348 (read-shell-command
349 "Bzr pull command: "
350 (concat vc-bzr-program " " command)
351 'vc-bzr-history)
352 " " t))
353 (setq vc-bzr-program (car args)
354 command (cadr args)
355 args (cddr args)))
356 (let ((buf (apply 'vc-bzr-async-command command args)))
357 (with-current-buffer buf (vc-exec-after '(vc-compilation-mode 'bzr)))
358 (vc-set-async-update buf))))
360 (defun vc-bzr-merge-branch ()
361 "Merge another Bzr branch into the current one.
362 Prompt for the Bzr command to run, providing a pre-defined merge
363 source (an upstream branch or a previous merge source) as a
364 default if it is available."
365 (let* ((branch-conf (vc-bzr-branch-conf default-directory))
366 ;; "bzr merge" without an argument defaults to submit_branch,
367 ;; then parent_location. Extract the specific location and
368 ;; add it explicitly to the command line.
369 (setting nil)
370 (location
371 (cond
372 ((setq setting (assoc "submit_branch" branch-conf))
373 (cdr setting))
374 ((setq setting (assoc "parent_location" branch-conf))
375 (cdr setting))))
376 (cmd
377 (split-string
378 (read-shell-command
379 "Bzr merge command: "
380 (concat vc-bzr-program " merge --pull"
381 (if location (concat " " location) ""))
382 'vc-bzr-history)
383 " " t))
384 (vc-bzr-program (car cmd))
385 (command (cadr cmd))
386 (args (cddr cmd)))
387 (let ((buf (apply 'vc-bzr-async-command command args)))
388 (with-current-buffer buf (vc-exec-after '(vc-compilation-mode 'bzr)))
389 (vc-set-async-update buf))))
391 (defun vc-bzr-status (file)
392 "Return FILE status according to Bzr.
393 Return value is a cons (STATUS . WARNING), where WARNING is a
394 string or nil, and STATUS is one of the symbols: `added',
395 `ignored', `kindchanged', `modified', `removed', `renamed', `unknown',
396 which directly correspond to `bzr status' output, or 'unchanged
397 for files whose copy in the working tree is identical to the one
398 in the branch repository (or whose status not be determined)."
399 ;; Doc used to also say the following, but AFAICS, it has never been true.
401 ;; ", or nil for files that are not registered with Bzr.
402 ;; If any error occurred in running `bzr status', then return nil."
404 ;; Rather than returning nil in case of an error, it returns
405 ;; (unchanged . WARNING). FIXME unchanged is not the best status to
406 ;; return in case of error.
407 (with-temp-buffer
408 ;; This is with-demoted-errors without the condition-case-unless-debug
409 ;; annoyance, which makes it fail during ert testing.
410 (condition-case err (vc-bzr-command "status" t 0 file)
411 (error (message "Error: %S" err) nil))
412 (let ((status 'unchanged))
413 ;; the only secure status indication in `bzr status' output
414 ;; is a couple of lines following the pattern::
415 ;; | <status>:
416 ;; | <file name>
417 ;; if the file is up-to-date, we get no status report from `bzr',
418 ;; so if the regexp search for the above pattern fails, we consider
419 ;; the file to be up-to-date.
420 (goto-char (point-min))
421 (when (re-search-forward
422 ;; bzr prints paths relative to the repository root.
423 (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+"
424 (regexp-quote (vc-bzr-file-name-relative file))
425 ;; Bzr appends a '/' to directory names and
426 ;; '*' to executable files
427 (if (file-directory-p file) "/?" "\\*?")
428 "[ \t\n]*$")
429 nil t)
430 (let ((statusword (match-string 1)))
431 ;; Erase the status text that matched.
432 (delete-region (match-beginning 0) (match-end 0))
433 (setq status
434 (intern (replace-regexp-in-string " " "" statusword)))))
435 (when status
436 (goto-char (point-min))
437 (skip-chars-forward " \n\t") ;Throw away spaces.
438 (cons status
439 ;; "bzr" will output warnings and informational messages to
440 ;; stderr; due to Emacs's `vc-do-command' (and, it seems,
441 ;; `start-process' itself) limitations, we cannot catch stderr
442 ;; and stdout into different buffers. So, if there's anything
443 ;; left in the buffer after removing the above status
444 ;; keywords, let us just presume that any other message from
445 ;; "bzr" is a user warning, and display it.
446 (unless (eobp) (buffer-substring (point) (point-max))))))))
448 (defun vc-bzr-state (file)
449 (let ((result (vc-bzr-status file)))
450 (when (consp result)
451 (let ((warnings (cdr result)))
452 (when warnings
453 ;; bzr 2.3.0 returns info about shelves, which is not really a warning
454 (when (string-match "[0-9]+ shel\\(f\\|ves\\) exists?\\..*?\n" warnings)
455 (setq warnings (replace-match "" nil nil warnings)))
456 (unless (string= warnings "")
457 (message "Warnings in `bzr' output: %s" warnings))))
458 (cdr (assq (car result)
459 '((added . added)
460 (kindchanged . edited)
461 (renamed . edited)
462 (modified . edited)
463 (removed . removed)
464 (ignored . ignored)
465 (unknown . unregistered)
466 (unchanged . up-to-date)))))))
468 (defun vc-bzr-resolve-when-done ()
469 "Call \"bzr resolve\" if the conflict markers have been removed."
470 (save-excursion
471 (goto-char (point-min))
472 (unless (re-search-forward "^<<<<<<< " nil t)
473 (vc-bzr-command "resolve" nil 0 buffer-file-name)
474 ;; Remove the hook so that it is not called multiple times.
475 (remove-hook 'after-save-hook 'vc-bzr-resolve-when-done t))))
477 (defun vc-bzr-find-file-hook ()
478 (when (and buffer-file-name
479 ;; FIXME: We should check that "bzr status" says "conflict".
480 (file-exists-p (concat buffer-file-name ".BASE"))
481 (file-exists-p (concat buffer-file-name ".OTHER"))
482 (file-exists-p (concat buffer-file-name ".THIS"))
483 ;; If "bzr status" says there's a conflict but there are no
484 ;; conflict markers, it's not clear what we should do.
485 (save-excursion
486 (goto-char (point-min))
487 (re-search-forward "^<<<<<<< " nil t)))
488 ;; TODO: the merge algorithm used in `bzr merge' is nicely configurable,
489 ;; but the one in `bzr pull' isn't, so it would be good to provide an
490 ;; elisp function to remerge from the .BASE/OTHER/THIS files.
491 (smerge-start-session)
492 (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t)
493 (message "There are unresolved conflicts in this file")))
495 (defun vc-bzr-workfile-unchanged-p (file)
496 (eq 'unchanged (car (vc-bzr-status file))))
498 (defun vc-bzr-working-revision (file)
499 ;; Together with the code in vc-state-heuristic, this makes it possible
500 ;; to get the initial VC state of a Bzr file even if Bzr is not installed.
501 (let* ((rootdir (vc-bzr-root file))
502 (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file
503 rootdir))
504 (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir))
505 (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir)))
506 ;; This looks at internal files to avoid forking a bzr process.
507 ;; May break if they change their format.
508 (if (and (file-exists-p branch-format-file)
509 ;; For lightweight checkouts (obtained with bzr co --lightweight)
510 ;; the branch-format-file does not contain the revision
511 ;; information, we need to look up the branch-format-file
512 ;; in the place where the lightweight checkout comes
513 ;; from. We only do that if it's a local file.
514 (let ((location-fname (expand-file-name
515 (concat vc-bzr-admin-dirname
516 "/branch/location") rootdir)))
517 ;; The existence of this file is how we distinguish
518 ;; lightweight checkouts.
519 (if (file-exists-p location-fname)
520 (with-temp-buffer
521 (insert-file-contents location-fname)
522 ;; If the lightweight checkout points to a
523 ;; location in the local file system, then we can
524 ;; look there for the version information.
525 (when (re-search-forward "file://\\(.+\\)" nil t)
526 (let ((l-c-parent-dir (match-string 1)))
527 (when (and (memq system-type '(ms-dos windows-nt))
528 (string-match-p "^/[[:alpha:]]:"
529 l-c-parent-dir))
530 ;;; The non-Windows code takes a shortcut by using
531 ;;; the host/path separator slash as the start of
532 ;;; the absolute path. That does not work on
533 ;;; Windows, so we must remove it (bug#5345)
534 (setq l-c-parent-dir (substring l-c-parent-dir 1)))
535 (setq branch-format-file
536 (expand-file-name vc-bzr-admin-branch-format-file
537 l-c-parent-dir))
538 (setq lastrev-file
539 (expand-file-name vc-bzr-admin-lastrev
540 l-c-parent-dir))
541 ;; FIXME: maybe it's overkill to check if both these
542 ;; files exist.
543 (and (file-exists-p branch-format-file)
544 (file-exists-p lastrev-file)
545 (equal (emacs-bzr-version-dirstate l-c-parent-dir)
546 (emacs-bzr-version-dirstate rootdir))))))
547 t)))
548 (with-temp-buffer
549 (insert-file-contents branch-format-file)
550 (goto-char (point-min))
551 (cond
552 ((or
553 (looking-at "Bazaar-NG branch, format 0.0.4")
554 (looking-at "Bazaar-NG branch format 5"))
555 ;; count lines in .bzr/branch/revision-history
556 (insert-file-contents revhistory-file)
557 (number-to-string (count-lines (line-end-position) (point-max))))
558 ((or
559 (looking-at "Bazaar Branch Format 6 (bzr 0.15)")
560 (looking-at "Bazaar Branch Format 7 (needs bzr 1.6)"))
561 ;; revno is the first number in .bzr/branch/last-revision
562 (insert-file-contents lastrev-file)
563 (when (re-search-forward "[0-9]+" nil t)
564 (buffer-substring (match-beginning 0) (match-end 0))))))
565 ;; Fallback to calling "bzr revno --tree".
566 ;; The "--tree" matters for lightweight checkouts not on the same
567 ;; revision as the parent.
568 (let* ((result (vc-bzr-command-discarding-stderr
569 vc-bzr-program "revno" "--tree"
570 (file-relative-name file)))
571 (exitcode (car result))
572 (output (cdr result)))
573 (cond
574 ((and (eq exitcode 0) (not (zerop (length output))))
575 (substring output 0 -1))
576 (t nil))))))
578 (defun vc-bzr-create-repo ()
579 "Create a new Bzr repository."
580 (vc-bzr-command "init" nil 0 nil))
582 (defun vc-bzr-init-revision (&optional _file)
583 "Always return nil, as Bzr cannot register explicit versions."
584 nil)
586 (defun vc-bzr-previous-revision (_file rev)
587 (if (string-match "\\`[0-9]+\\'" rev)
588 (number-to-string (1- (string-to-number rev)))
589 (concat "before:" rev)))
591 (defun vc-bzr-next-revision (_file rev)
592 (if (string-match "\\`[0-9]+\\'" rev)
593 (number-to-string (1+ (string-to-number rev)))
594 (error "Don't know how to compute the next revision of %s" rev)))
596 (defun vc-bzr-register (files &optional rev _comment)
597 "Register FILES under bzr.
598 Signal an error unless REV is nil.
599 COMMENT is ignored."
600 (if rev (error "Can't register explicit revision with bzr"))
601 (vc-bzr-command "add" nil 0 files))
603 ;; Could run `bzr status' in the directory and see if it succeeds, but
604 ;; that's relatively expensive.
605 (defalias 'vc-bzr-responsible-p 'vc-bzr-root
606 "Return non-nil if FILE is (potentially) controlled by bzr.
607 The criterion is that there is a `.bzr' directory in the same
608 or a superior directory.")
610 (defun vc-bzr-could-register (file)
611 "Return non-nil if FILE could be registered under bzr."
612 (and (vc-bzr-responsible-p file) ; shortcut
613 (condition-case ()
614 (with-temp-buffer
615 (vc-bzr-command "add" t 0 file "--dry-run")
616 ;; The command succeeds with no output if file is
617 ;; registered (in bzr 0.8).
618 (goto-char (point-min))
619 (looking-at "added "))
620 (error))))
622 (defun vc-bzr-unregister (file)
623 "Unregister FILE from bzr."
624 (vc-bzr-command "remove" nil 0 file "--keep"))
626 (declare-function log-edit-extract-headers "log-edit" (headers string))
628 (defun vc-bzr--sanitize-header (arg)
629 ;; Newlines in --fixes (and probably other fields as well) trigger a nasty
630 ;; Bazaar bug; see https://bugs.launchpad.net/bzr/+bug/1094180.
631 (lambda (str) (list arg
632 (replace-regexp-in-string "\\`[ \t]+\\|[ \t]+\\'"
633 "" (replace-regexp-in-string
634 "\n[ \t]?" " " str)))))
636 (defun vc-bzr-checkin (files rev comment)
637 "Check FILES in to bzr with log message COMMENT.
638 REV non-nil gets an error."
639 (if rev (error "Can't check in a specific revision with bzr"))
640 (apply 'vc-bzr-command "commit" nil 0 files
641 (cons "-m" (log-edit-extract-headers
642 `(("Author" . ,(vc-bzr--sanitize-header "--author"))
643 ("Date" . ,(vc-bzr--sanitize-header "--commit-time"))
644 ("Fixes" . ,(vc-bzr--sanitize-header "--fixes")))
645 comment))))
647 (defun vc-bzr-find-revision (file rev buffer)
648 "Fetch revision REV of file FILE and put it into BUFFER."
649 (with-current-buffer buffer
650 (if (and rev (stringp rev) (not (string= rev "")))
651 (vc-bzr-command "cat" t 0 file "-r" rev)
652 (vc-bzr-command "cat" t 0 file))))
654 (defun vc-bzr-ignore (file &optional directory remove)
655 "Ignore FILE under Bazaar.
656 If DIRECTORY is non-nil, the repository to use will be deduced by
657 DIRECTORY; if REMOVE is non-nil, remove FILE from ignored files."
658 (if remove
659 (if directory
660 (vc--remove-regexp file (vc-bzr-find-ignore-file directory))
661 (vc--remove-regexp file
662 (vc-bzr-find-ignore-file default-directory)))
663 (vc-bzr-command "ignore" t 0 file)))
665 (defun vc-bzr-ignore-completion-table (file)
666 "Return the list of ignored files."
667 (vc--read-lines (vc-bzr-find-ignore-file file)))
669 (defun vc-bzr-find-ignore-file (file)
670 "Return the root directory of the repository of FILE."
671 (expand-file-name ".bzrignore"
672 (vc-bzr-root file)))
674 (defun vc-bzr-checkout (_file &optional _editable rev)
675 (if rev (error "Operation not supported")
676 ;; Else, there's nothing to do.
677 nil))
679 (defun vc-bzr-revert (file &optional contents-done)
680 (unless contents-done
681 (with-temp-buffer (vc-bzr-command "revert" t 0 file "--no-backup"))))
683 (defvar log-view-message-re)
684 (defvar log-view-file-re)
685 (defvar log-view-font-lock-keywords)
686 (defvar log-view-current-tag-function)
687 (defvar log-view-per-file-logs)
688 (defvar log-view-expanded-log-entry-function)
690 (define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View"
691 (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack.
692 (require 'add-log)
693 (set (make-local-variable 'log-view-per-file-logs) nil)
694 (set (make-local-variable 'log-view-file-re) "\\`a\\`")
695 (set (make-local-variable 'log-view-message-re)
696 (if (eq vc-log-view-type 'short)
697 "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
698 "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)"))
699 ;; Allow expanding short log entries
700 (when (eq vc-log-view-type 'short)
701 (setq truncate-lines t)
702 (set (make-local-variable 'log-view-expanded-log-entry-function)
703 'vc-bzr-expanded-log-entry))
704 (set (make-local-variable 'log-view-font-lock-keywords)
705 ;; log-view-font-lock-keywords is careful to use the buffer-local
706 ;; value of log-view-message-re only since Emacs-23.
707 (if (eq vc-log-view-type 'short)
708 (append `((,log-view-message-re
709 (1 'log-view-message-face)
710 (2 'change-log-name)
711 (3 'change-log-date)
712 (4 'change-log-list nil lax))))
713 (append `((,log-view-message-re . 'log-view-message-face))
714 ;; log-view-font-lock-keywords
715 '(("^ *\\(?:committer\\|author\\): \
716 \\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]"
717 (1 'change-log-name)
718 (2 'change-log-email))
719 ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face)))))))
721 (autoload 'vc-setup-buffer "vc-dispatcher")
723 (defun vc-bzr-print-log (files buffer &optional shortlog start-revision limit)
724 "Print commit log associated with FILES into specified BUFFER.
725 If SHORTLOG is non-nil, use --line format.
726 If START-REVISION is non-nil, it is the newest revision to show.
727 If LIMIT is non-nil, show no more than this many entries."
728 ;; `vc-do-command' creates the buffer, but we need it before running
729 ;; the command.
730 (vc-setup-buffer buffer)
731 ;; If the buffer exists from a previous invocation it might be
732 ;; read-only.
733 ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so
734 ;; the log display may not what the user wants - but I see no other
735 ;; way of getting the above regexps working.
736 (with-current-buffer buffer
737 (apply 'vc-bzr-command "log" buffer 'async files
738 (append
739 (when shortlog '("--line"))
740 ;; The extra complications here when start-revision and limit
741 ;; are set are due to bzr log's --forward argument, which
742 ;; could be enabled via an alias in bazaar.conf.
743 ;; Svn, for example, does not have this problem, because
744 ;; it doesn't have --forward. Instead, you can use
745 ;; svn --log -r HEAD:0 or -r 0:HEAD as you prefer.
746 ;; Bzr, however, insists in -r X..Y that X come before Y.
747 (if start-revision
748 (list (format
749 (if (and limit (= limit 1))
750 ;; This means we don't have to use --no-aliases.
751 ;; Is -c any different to -r in this case?
752 "-r%s"
753 "-r..%s") start-revision)))
754 (when limit (list "-l" (format "%s" limit)))
755 ;; There is no sensible way to combine --limit and --forward,
756 ;; and it breaks the meaning of START-REVISION as the
757 ;; _newest_ revision. See bug#14168.
758 ;; Eg bzr log --forward -r ..100 --limit 50 prints
759 ;; revisions 1-50 rather than 50-100. There
760 ;; seems no way in general to get bzr to print revisions
761 ;; 50-100 in --forward order in that case.
762 ;; FIXME There may be other alias stuff we want to keep.
763 ;; Is there a way to just suppress --forward?
764 ;; As of 2013/4 the only caller uses limit = 1, so it does
765 ;; not matter much.
766 (and start-revision limit (> limit 1) '("--no-aliases"))
767 (if (stringp vc-bzr-log-switches)
768 (list vc-bzr-log-switches)
769 vc-bzr-log-switches)))))
771 (defun vc-bzr-expanded-log-entry (revision)
772 (with-temp-buffer
773 (apply 'vc-bzr-command "log" t nil nil
774 (list (format "-r%s" revision)))
775 (goto-char (point-min))
776 (when (looking-at "^-+\n")
777 ;; Indent the expanded log entry.
778 (indent-region (match-end 0) (point-max) 2)
779 (buffer-substring (match-end 0) (point-max)))))
781 (defun vc-bzr-log-incoming (buffer remote-location)
782 (apply 'vc-bzr-command "missing" buffer 'async nil
783 (list "--theirs-only" (unless (string= remote-location "") remote-location))))
785 (defun vc-bzr-log-outgoing (buffer remote-location)
786 (apply 'vc-bzr-command "missing" buffer 'async nil
787 (list "--mine-only" (unless (string= remote-location "") remote-location))))
789 (defun vc-bzr-show-log-entry (revision)
790 "Find entry for patch name REVISION in bzr change log buffer."
791 (goto-char (point-min))
792 (when revision
793 (let (case-fold-search
794 found)
795 (if (re-search-forward
796 ;; "revno:" can appear either at the beginning of a line,
797 ;; or indented.
798 (concat "^[ ]*-+\n[ ]*revno: "
799 ;; The revision can contain ".", quote it so that it
800 ;; does not interfere with regexp matching.
801 (regexp-quote revision) "$") nil t)
802 (progn
803 (beginning-of-line 0)
804 (setq found t))
805 (goto-char (point-min)))
806 found)))
808 (autoload 'vc-switches "vc")
810 (defun vc-bzr-diff (files &optional rev1 rev2 buffer)
811 "VC bzr backend for diff."
812 (let* ((switches (vc-switches 'bzr 'diff))
813 (args
814 (append
815 ;; Only add --diff-options if there are any diff switches.
816 (unless (zerop (length switches))
817 (list "--diff-options" (mapconcat 'identity switches " ")))
818 ;; This `when' is just an optimization because bzr-1.2 is *much*
819 ;; faster when the revision argument is not given.
820 (when (or rev1 rev2)
821 (list "-r" (format "%s..%s"
822 (or rev1 "revno:-1")
823 (or rev2 "")))))))
824 ;; `bzr diff' exits with code 1 if diff is non-empty.
825 (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
826 (if vc-disable-async-diff 1 'async) files
827 args)))
830 ;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with
831 ;; straight integer revisions.
833 (defun vc-bzr-delete-file (file)
834 "Delete FILE and delete it in the bzr repository."
835 (condition-case ()
836 (delete-file file)
837 (file-error nil))
838 (vc-bzr-command "remove" nil 0 file))
840 (defun vc-bzr-rename-file (old new)
841 "Rename file from OLD to NEW using `bzr mv'."
842 (setq old (expand-file-name old))
843 (setq new (expand-file-name new))
844 (vc-bzr-command "mv" nil 0 new old)
845 (message "Renamed %s => %s" old new))
847 (defvar vc-bzr-annotation-table nil
848 "Internal use.")
849 (make-variable-buffer-local 'vc-bzr-annotation-table)
851 (defun vc-bzr-annotate-command (file buffer &optional revision)
852 "Prepare BUFFER for `vc-annotate' on FILE.
853 Each line is tagged with the revision number, which has a `help-echo'
854 property containing author and date information."
855 (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all"
856 (if revision (list "-r" revision)))
857 (let ((table (make-hash-table :test 'equal)))
858 (set-process-filter
859 (get-buffer-process buffer)
860 (lambda (proc string)
861 (when (process-buffer proc)
862 (with-current-buffer (process-buffer proc)
863 (setq string (concat (process-get proc :vc-left-over) string))
864 ;; Eg: 102020 Gnus developers 20101020 | regexp."
865 ;; As of bzr 2.2.2, no email address in whoami (which can
866 ;; lead to spaces in the author field) is allowed but discouraged.
867 ;; See bug#7792.
868 (while (string-match "^\\( *[0-9.]+ *\\) \\(.+?\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string)
869 (let* ((rev (match-string 1 string))
870 (author (match-string 2 string))
871 (date (match-string 3 string))
872 (key (substring string (match-beginning 0)
873 (match-beginning 4)))
874 (line (match-string 4 string))
875 (tag (gethash key table))
876 (inhibit-read-only t))
877 (setq string (substring string (match-end 0)))
878 (unless tag
879 (setq tag
880 (propertize
881 (format "%s %-7.7s" rev author)
882 'help-echo (format "Revision: %d, author: %s, date: %s"
883 (string-to-number rev)
884 author date)
885 'mouse-face 'highlight))
886 (puthash key tag table))
887 (goto-char (process-mark proc))
888 (insert tag line)
889 (move-marker (process-mark proc) (point))))
890 (process-put proc :vc-left-over string)))))))
892 (declare-function vc-annotate-convert-time "vc-annotate" (time))
894 (defun vc-bzr-annotate-time ()
895 (when (re-search-forward "^ *[0-9.]+ +.+? +|" nil t)
896 (let ((prop (get-text-property (line-beginning-position) 'help-echo)))
897 (string-match "[0-9]+\\'" prop)
898 (let ((str (match-string-no-properties 0 prop)))
899 (vc-annotate-convert-time
900 (encode-time 0 0 0
901 (string-to-number (substring str 6 8))
902 (string-to-number (substring str 4 6))
903 (string-to-number (substring str 0 4))))))))
905 (defun vc-bzr-annotate-extract-revision-at-line ()
906 "Return revision for current line of annotation buffer, or nil.
907 Return nil if current line isn't annotated."
908 (save-excursion
909 (beginning-of-line)
910 (if (looking-at "^ *\\([0-9.]+\\) +.* +|")
911 (match-string-no-properties 1))))
913 (defun vc-bzr-command-discarding-stderr (command &rest args)
914 "Execute shell command COMMAND (with ARGS); return its output and exitcode.
915 Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is
916 the (numerical) exit code of the process, and OUTPUT is a string
917 containing whatever the process sent to its standard output
918 stream. Standard error output is discarded."
919 (with-temp-buffer
920 (cons
921 (apply #'process-file command nil (list (current-buffer) nil) nil args)
922 (buffer-substring (point-min) (point-max)))))
924 (cl-defstruct (vc-bzr-extra-fileinfo
925 (:copier nil)
926 (:constructor vc-bzr-create-extra-fileinfo (extra-name))
927 (:conc-name vc-bzr-extra-fileinfo->))
928 extra-name) ;; original name for rename targets, new name for
930 (declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
932 (defun vc-bzr-dir-printer (info)
933 "Pretty-printer for the vc-dir-fileinfo structure."
934 (let ((extra (vc-dir-fileinfo->extra info)))
935 (vc-default-dir-printer 'Bzr info)
936 (when extra
937 (insert (propertize
938 (format " (renamed from %s)"
939 (vc-bzr-extra-fileinfo->extra-name extra))
940 'face 'font-lock-comment-face)))))
942 ;; FIXME: this needs testing, it's probably incomplete.
943 (defun vc-bzr-after-dir-status (update-function relative-dir)
944 (let ((status-str nil)
945 (translation '(("+N " . added)
946 ("-D " . removed)
947 (" M " . edited) ;; file text modified
948 (" *" . edited) ;; execute bit changed
949 (" M*" . edited) ;; text modified + execute bit changed
950 ("I " . ignored)
951 (" D " . missing)
952 ;; For conflicts, should we list the .THIS/.BASE/.OTHER?
953 ("C " . conflict)
954 ("? " . unregistered)
955 ;; No such state, but we need to distinguish this case.
956 ("R " . renamed)
957 ("RM " . renamed)
958 ;; For a non existent file FOO, the output is:
959 ;; bzr: ERROR: Path(s) do not exist: FOO
960 ("bzr" . not-found)
961 ;; If the tree is not up to date, bzr will print this warning:
962 ;; working tree is out of date, run 'bzr update'
963 ;; ignore it.
964 ;; FIXME: maybe this warning can be put in the vc-dir header...
965 ("wor" . not-found)
966 ;; Ignore "P " and "P." for pending patches.
967 ("P " . not-found)
968 ("P. " . not-found)
970 (translated nil)
971 (result nil))
972 (goto-char (point-min))
973 (while (not (eobp))
974 ;; Bzr 2.3.0 added this if there are shelves. (Bug#8170)
975 (unless (looking-at "[0-9]+ shel\\(f\\|ves\\) exists?\\.")
976 (setq status-str
977 (buffer-substring-no-properties (point) (+ (point) 3)))
978 (setq translated (cdr (assoc status-str translation)))
979 (cond
980 ((eq translated 'conflict)
981 ;; For conflicts the file appears twice in the listing: once
982 ;; with the M flag and once with the C flag, so take care
983 ;; not to add it twice to `result'. Ugly.
984 (let* ((file
985 (buffer-substring-no-properties
986 ;;For files with conflicts the format is:
987 ;;C Text conflict in FILENAME
988 ;; Bah.
989 (+ (point) 21) (line-end-position)))
990 (entry (assoc file result)))
991 (when entry
992 (setf (nth 1 entry) 'conflict))))
993 ((eq translated 'renamed)
994 (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
995 (let ((new-name (file-relative-name (match-string 2) relative-dir))
996 (old-name (file-relative-name (match-string 1) relative-dir)))
997 (push (list new-name 'edited
998 (vc-bzr-create-extra-fileinfo old-name)) result)))
999 ;; do nothing for non existent files
1000 ((memq translated '(not-found ignored)))
1002 (push (list (file-relative-name
1003 (buffer-substring-no-properties
1004 (+ (point) 4)
1005 (line-end-position)) relative-dir)
1006 translated) result))))
1007 (forward-line))
1008 (funcall update-function result)))
1010 (defun vc-bzr-dir-status (dir update-function)
1011 "Return a list of conses (file . state) for DIR."
1012 (vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S")
1013 (vc-exec-after
1014 `(vc-bzr-after-dir-status (quote ,update-function)
1015 ;; "bzr status" results are relative to
1016 ;; the bzr root directory, NOT to the
1017 ;; directory "bzr status" was invoked in.
1018 ;; Ugh.
1019 ;; We pass the relative directory here so
1020 ;; that `vc-bzr-after-dir-status' can
1021 ;; frob the results accordingly.
1022 (file-relative-name ,dir (vc-bzr-root ,dir)))))
1024 (defun vc-bzr-dir-status-files (dir files _default-state update-function)
1025 "Return a list of conses (file . state) for DIR."
1026 (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
1027 (vc-exec-after
1028 `(vc-bzr-after-dir-status (quote ,update-function)
1029 (file-relative-name ,dir (vc-bzr-root ,dir)))))
1031 (defvar vc-bzr-shelve-map
1032 (let ((map (make-sparse-keymap)))
1033 ;; Turn off vc-dir marking
1034 (define-key map [mouse-2] 'ignore)
1036 (define-key map [down-mouse-3] 'vc-bzr-shelve-menu)
1037 (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point)
1038 (define-key map "=" 'vc-bzr-shelve-show-at-point)
1039 (define-key map "\C-m" 'vc-bzr-shelve-show-at-point)
1040 (define-key map "A" 'vc-bzr-shelve-apply-and-keep-at-point)
1041 (define-key map "P" 'vc-bzr-shelve-apply-at-point)
1042 (define-key map "S" 'vc-bzr-shelve-snapshot)
1043 map))
1045 (defvar vc-bzr-shelve-menu-map
1046 (let ((map (make-sparse-keymap "Bzr Shelve")))
1047 (define-key map [de]
1048 '(menu-item "Delete Shelf" vc-bzr-shelve-delete-at-point
1049 :help "Delete the current shelf"))
1050 (define-key map [ap]
1051 '(menu-item "Apply and Keep Shelf" vc-bzr-shelve-apply-and-keep-at-point
1052 :help "Apply the current shelf and keep it"))
1053 (define-key map [po]
1054 '(menu-item "Apply and Remove Shelf (Pop)" vc-bzr-shelve-apply-at-point
1055 :help "Apply the current shelf and remove it"))
1056 (define-key map [sh]
1057 '(menu-item "Show Shelve" vc-bzr-shelve-show-at-point
1058 :help "Show the contents of the current shelve"))
1059 map))
1061 (defvar vc-bzr-extra-menu-map
1062 (let ((map (make-sparse-keymap)))
1063 (define-key map [bzr-sn]
1064 '(menu-item "Shelve a Snapshot" vc-bzr-shelve-snapshot
1065 :help "Shelve the current state of the tree and keep the current state"))
1066 (define-key map [bzr-sh]
1067 '(menu-item "Shelve..." vc-bzr-shelve
1068 :help "Shelve changes"))
1069 map))
1071 (defun vc-bzr-extra-menu () vc-bzr-extra-menu-map)
1073 (defun vc-bzr-extra-status-menu () vc-bzr-extra-menu-map)
1075 (defun vc-bzr-dir-extra-headers (dir)
1076 (let*
1077 ((str (with-temp-buffer
1078 (vc-bzr-command "info" t 0 dir)
1079 (buffer-string)))
1080 (shelve (vc-bzr-shelve-list))
1081 (shelve-help-echo "Use M-x vc-bzr-shelve to create shelves")
1082 (root-dir (vc-bzr-root dir))
1083 (pending-merge
1084 ;; FIXME: looking for .bzr/checkout/merge-hashes is not a
1085 ;; reliable method to detect pending merges, disable this
1086 ;; until a proper solution is implemented.
1087 (and nil
1088 (file-exists-p
1089 (expand-file-name ".bzr/checkout/merge-hashes" root-dir))))
1090 (pending-merge-help-echo
1091 (format "A merge has been performed.\nA commit from the top-level directory (%s)\nis required before being able to check in anything else" root-dir))
1092 (light-checkout
1093 (when (string-match ".+light checkout root: \\(.+\\)$" str)
1094 (match-string 1 str)))
1095 (light-checkout-branch
1096 (when light-checkout
1097 (when (string-match ".+checkout of branch: \\(.+\\)$" str)
1098 (match-string 1 str)))))
1099 (concat
1100 (propertize "Parent branch : " 'face 'font-lock-type-face)
1101 (propertize
1102 (if (string-match "parent branch: \\(.+\\)$" str)
1103 (match-string 1 str)
1104 "None")
1105 'face 'font-lock-variable-name-face)
1106 "\n"
1107 (when light-checkout
1108 (concat
1109 (propertize "Light checkout root: " 'face 'font-lock-type-face)
1110 (propertize light-checkout 'face 'font-lock-variable-name-face)
1111 "\n"))
1112 (when light-checkout-branch
1113 (concat
1114 (propertize "Checkout of branch : " 'face 'font-lock-type-face)
1115 (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
1116 "\n"))
1117 (when pending-merge
1118 (concat
1119 (propertize "Warning : " 'face 'font-lock-warning-face
1120 'help-echo pending-merge-help-echo)
1121 (propertize "Pending merges, commit recommended before any other action"
1122 'help-echo pending-merge-help-echo
1123 'face 'font-lock-warning-face)
1124 "\n"))
1125 (if shelve
1126 (concat
1127 (propertize "Shelves :\n" 'face 'font-lock-type-face
1128 'help-echo shelve-help-echo)
1129 (mapconcat
1130 (lambda (x)
1131 (propertize x
1132 'face 'font-lock-variable-name-face
1133 'mouse-face 'highlight
1134 'help-echo "mouse-3: Show shelve menu\nA: Apply and keep shelf\nP: Apply and remove shelf (pop)\nS: Snapshot to a shelf\nC-k: Delete shelf"
1135 'keymap vc-bzr-shelve-map))
1136 shelve "\n"))
1137 (concat
1138 (propertize "Shelves : " 'face 'font-lock-type-face
1139 'help-echo shelve-help-echo)
1140 (propertize "No shelved changes"
1141 'help-echo shelve-help-echo
1142 'face 'font-lock-variable-name-face))))))
1144 ;; Follows vc-bzr-command, which uses vc-do-command from vc-dispatcher.
1145 (declare-function vc-resynch-buffer "vc-dispatcher"
1146 (file &optional keep noquery reset-vc-info))
1148 (defun vc-bzr-shelve (name)
1149 "Create a shelve."
1150 (interactive "sShelf name: ")
1151 (let ((root (vc-bzr-root default-directory)))
1152 (when root
1153 (vc-bzr-command "shelve" nil 0 nil "--all" "-m" name)
1154 (vc-resynch-buffer root t t))))
1156 (defun vc-bzr-shelve-show (name)
1157 "Show the contents of shelve NAME."
1158 (interactive "sShelve name: ")
1159 (vc-setup-buffer "*vc-diff*")
1160 ;; FIXME: how can you show the contents of a shelf?
1161 (vc-bzr-command "unshelve" "*vc-diff*" 'async nil "--preview" name)
1162 (set-buffer "*vc-diff*")
1163 (diff-mode)
1164 (setq buffer-read-only t)
1165 (pop-to-buffer (current-buffer)))
1167 (defun vc-bzr-shelve-apply (name)
1168 "Apply shelve NAME and remove it afterwards."
1169 (interactive "sApply (and remove) shelf: ")
1170 (vc-bzr-command "unshelve" nil 0 nil "--apply" name)
1171 (vc-resynch-buffer (vc-bzr-root default-directory) t t))
1173 (defun vc-bzr-shelve-apply-and-keep (name)
1174 "Apply shelve NAME and keep it afterwards."
1175 (interactive "sApply (and keep) shelf: ")
1176 (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep" name)
1177 (vc-resynch-buffer (vc-bzr-root default-directory) t t))
1179 (defun vc-bzr-shelve-snapshot ()
1180 "Create a stash with the current tree state."
1181 (interactive)
1182 (vc-bzr-command "shelve" nil 0 nil "--all" "-m"
1183 (let ((ct (current-time)))
1184 (concat
1185 (format-time-string "Snapshot on %Y-%m-%d" ct)
1186 (format-time-string " at %H:%M" ct))))
1187 (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep")
1188 (vc-resynch-buffer (vc-bzr-root default-directory) t t))
1190 (defun vc-bzr-shelve-list ()
1191 (with-temp-buffer
1192 (vc-bzr-command "shelve" (current-buffer) 1 nil "--list" "-q")
1193 (delete
1195 (split-string
1196 (buffer-substring (point-min) (point-max))
1197 "\n"))))
1199 (defun vc-bzr-shelve-get-at-point (point)
1200 (save-excursion
1201 (goto-char point)
1202 (beginning-of-line)
1203 (if (looking-at "^ +\\([0-9]+\\):")
1204 (match-string 1)
1205 (error "Cannot find shelf at point"))))
1207 ;; vc-bzr-shelve-delete-at-point must be called from a vc-dir buffer.
1208 (declare-function vc-dir-refresh "vc-dir" ())
1210 (defun vc-bzr-shelve-delete-at-point ()
1211 (interactive)
1212 (let ((shelve (vc-bzr-shelve-get-at-point (point))))
1213 (when (y-or-n-p (format "Remove shelf %s ? " shelve))
1214 (vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve)
1215 (vc-dir-refresh))))
1217 (defun vc-bzr-shelve-show-at-point ()
1218 (interactive)
1219 (vc-bzr-shelve-show (vc-bzr-shelve-get-at-point (point))))
1221 (defun vc-bzr-shelve-apply-at-point ()
1222 (interactive)
1223 (vc-bzr-shelve-apply (vc-bzr-shelve-get-at-point (point))))
1225 (defun vc-bzr-shelve-apply-and-keep-at-point ()
1226 (interactive)
1227 (vc-bzr-shelve-apply-and-keep (vc-bzr-shelve-get-at-point (point))))
1229 (defun vc-bzr-shelve-menu (e)
1230 (interactive "e")
1231 (vc-dir-at-event e (popup-menu vc-bzr-shelve-menu-map e)))
1233 (defun vc-bzr-revision-table (files)
1234 (let ((vc-bzr-revisions '())
1235 (default-directory (file-name-directory (car files))))
1236 (with-temp-buffer
1237 (vc-bzr-command "log" t 0 files "--line")
1238 (let ((start (point-min))
1239 (loglines (buffer-substring-no-properties (point-min) (point-max))))
1240 (while (string-match "^\\([0-9]+\\):" loglines)
1241 (push (match-string 1 loglines) vc-bzr-revisions)
1242 (setq start (+ start (match-end 0)))
1243 (setq loglines (buffer-substring-no-properties start (point-max))))))
1244 vc-bzr-revisions))
1246 (defun vc-bzr-conflicted-files (dir)
1247 (let ((default-directory (vc-bzr-root dir))
1248 (files ()))
1249 (with-temp-buffer
1250 (vc-bzr-command "status" t 0 default-directory)
1251 (goto-char (point-min))
1252 (when (re-search-forward "^conflicts:\n" nil t)
1253 (while (looking-at " \\(?:Text conflict in \\(.*\\)\\|.*\\)\n")
1254 (if (match-end 1)
1255 (push (expand-file-name (match-string 1)) files))
1256 (goto-char (match-end 0)))))
1257 files))
1259 ;;; Revision completion
1261 (eval-and-compile
1262 (defconst vc-bzr-revision-keywords
1263 ;; bzr help revisionspec | sed -ne 's/^\([a-z]*\):$/"\1"/p' | sort -u
1264 '("ancestor" "annotate" "before" "branch" "date" "last" "mainline" "revid"
1265 "revno" "submit" "tag")))
1267 (defun vc-bzr-revision-completion-table (files)
1268 ;; What about using `files'?!? --Stef
1269 (lambda (string pred action)
1270 (cond
1271 ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):"
1272 string)
1273 (completion-table-with-context (substring string 0 (match-end 0))
1274 (apply-partially
1275 'completion-table-with-predicate
1276 'completion-file-name-table
1277 'file-directory-p t)
1278 (substring string (match-end 0))
1279 pred
1280 action))
1281 ((string-match "\\`\\(before\\):" string)
1282 (completion-table-with-context (substring string 0 (match-end 0))
1283 (vc-bzr-revision-completion-table files)
1284 (substring string (match-end 0))
1285 pred
1286 action))
1287 ((string-match "\\`\\(tag\\):" string)
1288 (let ((prefix (substring string 0 (match-end 0)))
1289 (tag (substring string (match-end 0)))
1290 (table nil)
1291 process-file-side-effects)
1292 (with-temp-buffer
1293 ;; "bzr-1.2 tags" is much faster with --show-ids.
1294 (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids")
1295 ;; The output is ambiguous, unless we assume that revids do not
1296 ;; contain spaces.
1297 (goto-char (point-min))
1298 (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t)
1299 (push (match-string-no-properties 1) table)))
1300 (completion-table-with-context prefix table tag pred action)))
1302 ((string-match "\\`annotate:" string)
1303 (completion-table-with-context
1304 (substring string 0 (match-end 0))
1305 (apply-partially #'completion-table-with-terminator '(":" . "\\`a\\`")
1306 #'completion-file-name-table)
1307 (substring string (match-end 0)) pred action))
1309 ((string-match "\\`date:" string)
1310 (completion-table-with-context
1311 (substring string 0 (match-end 0))
1312 '("yesterday" "today" "tomorrow")
1313 (substring string (match-end 0)) pred action))
1315 ((string-match "\\`\\([a-z]+\\):" string)
1316 ;; no actual completion for the remaining keywords.
1317 (completion-table-with-context (substring string 0 (match-end 0))
1318 (if (member (match-string 1 string)
1319 vc-bzr-revision-keywords)
1320 ;; If it's a valid keyword,
1321 ;; use a non-empty table to
1322 ;; indicate it.
1323 '("") nil)
1324 (substring string (match-end 0))
1325 pred
1326 action))
1328 ;; Could use completion-table-with-terminator, except that it
1329 ;; currently doesn't work right w.r.t pcm and doesn't give
1330 ;; the *Completions* output we want.
1331 (complete-with-action action (eval-when-compile
1332 (mapcar (lambda (s) (concat s ":"))
1333 vc-bzr-revision-keywords))
1334 string pred)))))
1336 (provide 'vc-bzr)
1338 ;;; vc-bzr.el ends here