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