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