Mercurial > emacs
comparison lisp/vc/vc-bzr.el @ 109404:e93288477c43
Merge from mainline.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Sun, 13 Jun 2010 22:57:55 +0000 |
parents | lisp/vc-bzr.el@c05344a913c8 lisp/vc-bzr.el@d928a6a7c3f2 |
children | 1b626601d32d |
comparison
equal
deleted
inserted
replaced
109403:681cd08dc0f7 | 109404:e93288477c43 |
---|---|
1 ;;; vc-bzr.el --- VC backend for the bzr revision control system | |
2 | |
3 ;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Dave Love <fx@gnu.org> | |
6 ;; Riccardo Murri <riccardo.murri@gmail.com> | |
7 ;; Keywords: vc tools | |
8 ;; Created: Sept 2006 | |
9 ;; Version: 2008-01-04 (Bzr revno 25) | |
10 ;; URL: http://launchpad.net/vc-bzr | |
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-vcs.org/> concerning bzr. See | |
30 ;; <URL:http://launchpad.net/vc-bzr> for alternate development | |
31 ;; branches of `vc-bzr'. | |
32 | |
33 ;; Load this library to register bzr support in VC. | |
34 | |
35 ;; Known bugs | |
36 ;; ========== | |
37 | |
38 ;; When editing a symlink and *both* the symlink and its target | |
39 ;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the | |
40 ;; symlink, thereby not detecting whether the actual contents | |
41 ;; (that is, the target contents) are changed. | |
42 ;; See https://bugs.launchpad.net/vc-bzr/+bug/116607 | |
43 | |
44 ;; For an up-to-date list of bugs, please see: | |
45 ;; https://bugs.launchpad.net/vc-bzr/+bugs | |
46 | |
47 ;;; Properties of the backend | |
48 | |
49 (defun vc-bzr-revision-granularity () 'repository) | |
50 (defun vc-bzr-checkout-model (files) 'implicit) | |
51 | |
52 ;;; Code: | |
53 | |
54 (eval-when-compile | |
55 (require 'cl) | |
56 (require 'vc) ;; for vc-exec-after | |
57 (require 'vc-dir)) | |
58 | |
59 ;; Clear up the cache to force vc-call to check again and discover | |
60 ;; new functions when we reload this file. | |
61 (put 'Bzr 'vc-functions nil) | |
62 | |
63 (defgroup vc-bzr nil | |
64 "VC bzr backend." | |
65 :version "22.2" | |
66 :group 'vc) | |
67 | |
68 (defcustom vc-bzr-program "bzr" | |
69 "Name of the bzr command (excluding any arguments)." | |
70 :group 'vc-bzr | |
71 :type 'string) | |
72 | |
73 (defcustom vc-bzr-diff-switches nil | |
74 "String or list of strings specifying switches for bzr diff under VC. | |
75 If nil, use the value of `vc-diff-switches'. If t, use no switches." | |
76 :type '(choice (const :tag "Unspecified" nil) | |
77 (const :tag "None" t) | |
78 (string :tag "Argument String") | |
79 (repeat :tag "Argument List" :value ("") string)) | |
80 :group 'vc-bzr) | |
81 | |
82 (defcustom vc-bzr-log-switches nil | |
83 "String or list of strings specifying switches for bzr log under VC." | |
84 :type '(choice (const :tag "None" nil) | |
85 (string :tag "Argument String") | |
86 (repeat :tag "Argument List" :value ("") string)) | |
87 :group 'vc-bzr) | |
88 | |
89 ;; since v0.9, bzr supports removing the progress indicators | |
90 ;; by setting environment variable BZR_PROGRESS_BAR to "none". | |
91 (defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args) | |
92 "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND. | |
93 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and | |
94 `LC_MESSAGES=C' to the environment." | |
95 (let ((process-environment | |
96 (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) | |
97 "LC_MESSAGES=C" ; Force English output | |
98 process-environment))) | |
99 (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program | |
100 file-or-list bzr-command args))) | |
101 | |
102 | |
103 ;;;###autoload | |
104 (defconst vc-bzr-admin-dirname ".bzr" | |
105 "Name of the directory containing Bzr repository status files.") | |
106 ;;;###autoload | |
107 (defconst vc-bzr-admin-checkout-format-file | |
108 (concat vc-bzr-admin-dirname "/checkout/format")) | |
109 (defconst vc-bzr-admin-dirstate | |
110 (concat vc-bzr-admin-dirname "/checkout/dirstate")) | |
111 (defconst vc-bzr-admin-branch-format-file | |
112 (concat vc-bzr-admin-dirname "/branch/format")) | |
113 (defconst vc-bzr-admin-revhistory | |
114 (concat vc-bzr-admin-dirname "/branch/revision-history")) | |
115 (defconst vc-bzr-admin-lastrev | |
116 (concat vc-bzr-admin-dirname "/branch/last-revision")) | |
117 | |
118 ;;;###autoload (defun vc-bzr-registered (file) | |
119 ;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file) | |
120 ;;;###autoload (progn | |
121 ;;;###autoload (load "vc-bzr") | |
122 ;;;###autoload (vc-bzr-registered file)))) | |
123 | |
124 (defun vc-bzr-root (file) | |
125 "Return the root directory of the bzr repository containing FILE." | |
126 ;; Cache technique copied from vc-arch.el. | |
127 (or (vc-file-getprop file 'bzr-root) | |
128 (let ((root (vc-find-root file vc-bzr-admin-checkout-format-file))) | |
129 (when root (vc-file-setprop file 'bzr-root root))))) | |
130 | |
131 (require 'sha1) ;For sha1-program | |
132 | |
133 (defun vc-bzr-sha1 (file) | |
134 (with-temp-buffer | |
135 (set-buffer-multibyte nil) | |
136 (let ((prog sha1-program) | |
137 (args nil) | |
138 process-file-side-effects) | |
139 (when (consp prog) | |
140 (setq args (cdr prog)) | |
141 (setq prog (car prog))) | |
142 (apply 'process-file prog (file-relative-name file) t nil args) | |
143 (buffer-substring (point-min) (+ (point-min) 40))))) | |
144 | |
145 (defun vc-bzr-state-heuristic (file) | |
146 "Like `vc-bzr-state' but hopefully without running Bzr." | |
147 ;; `bzr status' was excrutiatingly slow with large histories and | |
148 ;; pending merges, so try to avoid using it until they fix their | |
149 ;; performance problems. | |
150 ;; This function tries first to parse Bzr internal file | |
151 ;; `checkout/dirstate', but it may fail if Bzr internal file format | |
152 ;; has changed. As a safeguard, the `checkout/dirstate' file is | |
153 ;; only parsed if it contains the string `#bazaar dirstate flat | |
154 ;; format 3' in the first line. | |
155 ;; If the `checkout/dirstate' file cannot be parsed, fall back to | |
156 ;; running `vc-bzr-state'." | |
157 (lexical-let ((root (vc-bzr-root file))) | |
158 (when root ; Short cut. | |
159 ;; This looks at internal files. May break if they change | |
160 ;; their format. | |
161 (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) | |
162 (condition-case nil | |
163 (with-temp-buffer | |
164 (insert-file-contents dirstate) | |
165 (goto-char (point-min)) | |
166 (if (not (looking-at "#bazaar dirstate flat format 3")) | |
167 (vc-bzr-state file) ; Some other unknown format? | |
168 (let* ((relfile (file-relative-name file root)) | |
169 (reldir (file-name-directory relfile))) | |
170 (if (re-search-forward | |
171 (concat "^\0" | |
172 (if reldir (regexp-quote | |
173 (directory-file-name reldir))) | |
174 "\0" | |
175 (regexp-quote (file-name-nondirectory relfile)) | |
176 "\0" | |
177 "[^\0]*\0" ;id? | |
178 "\\([^\0]*\\)\0" ;"a/f/d", a=removed? | |
179 "\\([^\0]*\\)\0" ;sha1 (empty if conflicted)? | |
180 "\\([^\0]*\\)\0" ;size?p | |
181 "[^\0]*\0" ;"y/n", executable? | |
182 "[^\0]*\0" ;? | |
183 "\\([^\0]*\\)\0" ;"a/f/d" a=added? | |
184 "\\([^\0]*\\)\0" ;sha1 again? | |
185 "\\([^\0]*\\)\0" ;size again? | |
186 "[^\0]*\0" ;"y/n", executable again? | |
187 "[^\0]*\0" ;last revid? | |
188 ;; There are more fields when merges are pending. | |
189 ) | |
190 nil t) | |
191 ;; Apparently the second sha1 is the one we want: when | |
192 ;; there's a conflict, the first sha1 is absent (and the | |
193 ;; first size seems to correspond to the file with | |
194 ;; conflict markers). | |
195 (cond | |
196 ((eq (char-after (match-beginning 1)) ?a) 'removed) | |
197 ((eq (char-after (match-beginning 4)) ?a) 'added) | |
198 ((or (and (eq (string-to-number (match-string 3)) | |
199 (nth 7 (file-attributes file))) | |
200 (equal (match-string 5) | |
201 (vc-bzr-sha1 file))) | |
202 (and | |
203 ;; It looks like for lightweight | |
204 ;; checkouts \2 is empty and we need to | |
205 ;; look for size in \6. | |
206 (eq (match-beginning 2) (match-end 2)) | |
207 (eq (string-to-number (match-string 6)) | |
208 (nth 7 (file-attributes file))) | |
209 (equal (match-string 5) | |
210 (vc-bzr-sha1 file)))) | |
211 'up-to-date) | |
212 (t 'edited)) | |
213 'unregistered)))) | |
214 ;; Either the dirstate file can't be read, or the sha1 | |
215 ;; executable is missing, or ... | |
216 ;; In either case, recent versions of Bzr aren't that slow | |
217 ;; any more. | |
218 (error (vc-bzr-state file))))))) | |
219 | |
220 | |
221 (defun vc-bzr-registered (file) | |
222 "Return non-nil if FILE is registered with bzr." | |
223 (let ((state (vc-bzr-state-heuristic file))) | |
224 (not (memq state '(nil unregistered ignored))))) | |
225 | |
226 (defconst vc-bzr-state-words | |
227 "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown" | |
228 "Regexp matching file status words as reported in `bzr' output.") | |
229 | |
230 (defun vc-bzr-file-name-relative (filename) | |
231 "Return file name FILENAME stripped of the initial Bzr repository path." | |
232 (lexical-let* | |
233 ((filename* (expand-file-name filename)) | |
234 (rootdir (vc-bzr-root filename*))) | |
235 (when rootdir | |
236 (file-relative-name filename* rootdir)))) | |
237 | |
238 (defun vc-bzr-status (file) | |
239 "Return FILE status according to Bzr. | |
240 Return value is a cons (STATUS . WARNING), where WARNING is a | |
241 string or nil, and STATUS is one of the symbols: `added', | |
242 `ignored', `kindchanged', `modified', `removed', `renamed', `unknown', | |
243 which directly correspond to `bzr status' output, or 'unchanged | |
244 for files whose copy in the working tree is identical to the one | |
245 in the branch repository, or nil for files that are not | |
246 registered with Bzr. | |
247 | |
248 If any error occurred in running `bzr status', then return nil." | |
249 (with-temp-buffer | |
250 (let ((ret (condition-case nil | |
251 (vc-bzr-command "status" t 0 file) | |
252 (file-error nil))) ; vc-bzr-program not found. | |
253 (status 'unchanged)) | |
254 ;; the only secure status indication in `bzr status' output | |
255 ;; is a couple of lines following the pattern:: | |
256 ;; | <status>: | |
257 ;; | <file name> | |
258 ;; if the file is up-to-date, we get no status report from `bzr', | |
259 ;; so if the regexp search for the above pattern fails, we consider | |
260 ;; the file to be up-to-date. | |
261 (goto-char (point-min)) | |
262 (when (re-search-forward | |
263 ;; bzr prints paths relative to the repository root. | |
264 (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+" | |
265 (regexp-quote (vc-bzr-file-name-relative file)) | |
266 ;; Bzr appends a '/' to directory names and | |
267 ;; '*' to executable files | |
268 (if (file-directory-p file) "/?" "\\*?") | |
269 "[ \t\n]*$") | |
270 nil t) | |
271 (lexical-let ((statusword (match-string 1))) | |
272 ;; Erase the status text that matched. | |
273 (delete-region (match-beginning 0) (match-end 0)) | |
274 (setq status | |
275 (intern (replace-regexp-in-string " " "" statusword))))) | |
276 (when status | |
277 (goto-char (point-min)) | |
278 (skip-chars-forward " \n\t") ;Throw away spaces. | |
279 (cons status | |
280 ;; "bzr" will output warnings and informational messages to | |
281 ;; stderr; due to Emacs' `vc-do-command' (and, it seems, | |
282 ;; `start-process' itself) limitations, we cannot catch stderr | |
283 ;; and stdout into different buffers. So, if there's anything | |
284 ;; left in the buffer after removing the above status | |
285 ;; keywords, let us just presume that any other message from | |
286 ;; "bzr" is a user warning, and display it. | |
287 (unless (eobp) (buffer-substring (point) (point-max)))))))) | |
288 | |
289 (defun vc-bzr-state (file) | |
290 (lexical-let ((result (vc-bzr-status file))) | |
291 (when (consp result) | |
292 (when (cdr result) | |
293 (message "Warnings in `bzr' output: %s" (cdr result))) | |
294 (cdr (assq (car result) | |
295 '((added . added) | |
296 (kindchanged . edited) | |
297 (renamed . edited) | |
298 (modified . edited) | |
299 (removed . removed) | |
300 (ignored . ignored) | |
301 (unknown . unregistered) | |
302 (unchanged . up-to-date))))))) | |
303 | |
304 (defun vc-bzr-resolve-when-done () | |
305 "Call \"bzr resolve\" if the conflict markers have been removed." | |
306 (save-excursion | |
307 (goto-char (point-min)) | |
308 (unless (re-search-forward "^<<<<<<< " nil t) | |
309 (vc-bzr-command "resolve" nil 0 buffer-file-name) | |
310 ;; Remove the hook so that it is not called multiple times. | |
311 (remove-hook 'after-save-hook 'vc-bzr-resolve-when-done t)))) | |
312 | |
313 (defun vc-bzr-find-file-hook () | |
314 (when (and buffer-file-name | |
315 ;; FIXME: We should check that "bzr status" says "conflict". | |
316 (file-exists-p (concat buffer-file-name ".BASE")) | |
317 (file-exists-p (concat buffer-file-name ".OTHER")) | |
318 (file-exists-p (concat buffer-file-name ".THIS")) | |
319 ;; If "bzr status" says there's a conflict but there are no | |
320 ;; conflict markers, it's not clear what we should do. | |
321 (save-excursion | |
322 (goto-char (point-min)) | |
323 (re-search-forward "^<<<<<<< " nil t))) | |
324 ;; TODO: the merge algorithm used in `bzr merge' is nicely configurable, | |
325 ;; but the one in `bzr pull' isn't, so it would be good to provide an | |
326 ;; elisp function to remerge from the .BASE/OTHER/THIS files. | |
327 (smerge-start-session) | |
328 (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t) | |
329 (message "There are unresolved conflicts in this file"))) | |
330 | |
331 (defun vc-bzr-workfile-unchanged-p (file) | |
332 (eq 'unchanged (car (vc-bzr-status file)))) | |
333 | |
334 (defun vc-bzr-working-revision (file) | |
335 ;; Together with the code in vc-state-heuristic, this makes it possible | |
336 ;; to get the initial VC state of a Bzr file even if Bzr is not installed. | |
337 (lexical-let* | |
338 ((rootdir (vc-bzr-root file)) | |
339 (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file | |
340 rootdir)) | |
341 (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir)) | |
342 (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir))) | |
343 ;; This looks at internal files to avoid forking a bzr process. | |
344 ;; May break if they change their format. | |
345 (if (and (file-exists-p branch-format-file) | |
346 ;; For lightweight checkouts (obtained with bzr checkout --lightweight) | |
347 ;; the branch-format-file does not contain the revision | |
348 ;; information, we need to look up the branch-format-file | |
349 ;; in the place where the lightweight checkout comes | |
350 ;; from. We only do that if it's a local file. | |
351 (let ((location-fname (expand-file-name | |
352 (concat vc-bzr-admin-dirname | |
353 "/branch/location") rootdir))) | |
354 ;; The existence of this file is how we distinguish | |
355 ;; lightweight checkouts. | |
356 (if (file-exists-p location-fname) | |
357 (with-temp-buffer | |
358 (insert-file-contents location-fname) | |
359 ;; If the lightweight checkout points to a | |
360 ;; location in the local file system, then we can | |
361 ;; look there for the version information. | |
362 (when (re-search-forward "file://\\(.+\\)" nil t) | |
363 (let ((l-c-parent-dir (match-string 1))) | |
364 (when (and (memq system-type '(ms-dos windows-nt)) | |
365 (string-match-p "^/[[:alpha:]]:" l-c-parent-dir)) | |
366 ;;; The non-Windows code takes a shortcut by using the host/path | |
367 ;;; separator slash as the start of the absolute path. That | |
368 ;;; does not work on Windows, so we must remove it (bug#5345) | |
369 (setq l-c-parent-dir (substring l-c-parent-dir 1))) | |
370 (setq branch-format-file | |
371 (expand-file-name vc-bzr-admin-branch-format-file | |
372 l-c-parent-dir)) | |
373 (setq lastrev-file | |
374 (expand-file-name vc-bzr-admin-lastrev l-c-parent-dir)) | |
375 ;; FIXME: maybe it's overkill to check if both these files exist. | |
376 (and (file-exists-p branch-format-file) | |
377 (file-exists-p lastrev-file))))) | |
378 t))) | |
379 (with-temp-buffer | |
380 (insert-file-contents branch-format-file) | |
381 (goto-char (point-min)) | |
382 (cond | |
383 ((or | |
384 (looking-at "Bazaar-NG branch, format 0.0.4") | |
385 (looking-at "Bazaar-NG branch format 5")) | |
386 ;; count lines in .bzr/branch/revision-history | |
387 (insert-file-contents revhistory-file) | |
388 (number-to-string (count-lines (line-end-position) (point-max)))) | |
389 ((or | |
390 (looking-at "Bazaar Branch Format 6 (bzr 0.15)") | |
391 (looking-at "Bazaar Branch Format 7 (needs bzr 1.6)")) | |
392 ;; revno is the first number in .bzr/branch/last-revision | |
393 (insert-file-contents lastrev-file) | |
394 (when (re-search-forward "[0-9]+" nil t) | |
395 (buffer-substring (match-beginning 0) (match-end 0)))))) | |
396 ;; fallback to calling "bzr revno" | |
397 (lexical-let* | |
398 ((result (vc-bzr-command-discarding-stderr | |
399 vc-bzr-program "revno" (file-relative-name file))) | |
400 (exitcode (car result)) | |
401 (output (cdr result))) | |
402 (cond | |
403 ((eq exitcode 0) (substring output 0 -1)) | |
404 (t nil)))))) | |
405 | |
406 (defun vc-bzr-create-repo () | |
407 "Create a new Bzr repository." | |
408 (vc-bzr-command "init" nil 0 nil)) | |
409 | |
410 (defun vc-bzr-init-revision (&optional file) | |
411 "Always return nil, as Bzr cannot register explicit versions." | |
412 nil) | |
413 | |
414 (defun vc-bzr-previous-revision (file rev) | |
415 (if (string-match "\\`[0-9]+\\'" rev) | |
416 (number-to-string (1- (string-to-number rev))) | |
417 (concat "before:" rev))) | |
418 | |
419 (defun vc-bzr-next-revision (file rev) | |
420 (if (string-match "\\`[0-9]+\\'" rev) | |
421 (number-to-string (1+ (string-to-number rev))) | |
422 (error "Don't know how to compute the next revision of %s" rev))) | |
423 | |
424 (defun vc-bzr-register (files &optional rev comment) | |
425 "Register FILE under bzr. | |
426 Signal an error unless REV is nil. | |
427 COMMENT is ignored." | |
428 (if rev (error "Can't register explicit revision with bzr")) | |
429 (vc-bzr-command "add" nil 0 files)) | |
430 | |
431 ;; Could run `bzr status' in the directory and see if it succeeds, but | |
432 ;; that's relatively expensive. | |
433 (defalias 'vc-bzr-responsible-p 'vc-bzr-root | |
434 "Return non-nil if FILE is (potentially) controlled by bzr. | |
435 The criterion is that there is a `.bzr' directory in the same | |
436 or a superior directory.") | |
437 | |
438 (defun vc-bzr-could-register (file) | |
439 "Return non-nil if FILE could be registered under bzr." | |
440 (and (vc-bzr-responsible-p file) ; shortcut | |
441 (condition-case () | |
442 (with-temp-buffer | |
443 (vc-bzr-command "add" t 0 file "--dry-run") | |
444 ;; The command succeeds with no output if file is | |
445 ;; registered (in bzr 0.8). | |
446 (goto-char (point-min)) | |
447 (looking-at "added ")) | |
448 (error)))) | |
449 | |
450 (defun vc-bzr-unregister (file) | |
451 "Unregister FILE from bzr." | |
452 (vc-bzr-command "remove" nil 0 file "--keep")) | |
453 | |
454 (declare-function log-edit-extract-headers "log-edit" (headers string)) | |
455 | |
456 (defun vc-bzr-checkin (files rev comment) | |
457 "Check FILE in to bzr with log message COMMENT. | |
458 REV non-nil gets an error." | |
459 (if rev (error "Can't check in a specific revision with bzr")) | |
460 (apply 'vc-bzr-command "commit" nil 0 | |
461 files (cons "-m" (log-edit-extract-headers '(("Author" . "--author") | |
462 ("Date" . "--commit-time") | |
463 ("Fixes" . "--fixes")) | |
464 comment)))) | |
465 | |
466 (defun vc-bzr-find-revision (file rev buffer) | |
467 "Fetch revision REV of file FILE and put it into BUFFER." | |
468 (with-current-buffer buffer | |
469 (if (and rev (stringp rev) (not (string= rev ""))) | |
470 (vc-bzr-command "cat" t 0 file "-r" rev) | |
471 (vc-bzr-command "cat" t 0 file)))) | |
472 | |
473 (defun vc-bzr-checkout (file &optional editable rev) | |
474 (if rev (error "Operation not supported") | |
475 ;; Else, there's nothing to do. | |
476 nil)) | |
477 | |
478 (defun vc-bzr-revert (file &optional contents-done) | |
479 (unless contents-done | |
480 (with-temp-buffer (vc-bzr-command "revert" t 0 file)))) | |
481 | |
482 (defvar log-view-message-re) | |
483 (defvar log-view-file-re) | |
484 (defvar log-view-font-lock-keywords) | |
485 (defvar log-view-current-tag-function) | |
486 (defvar log-view-per-file-logs) | |
487 | |
488 (define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View" | |
489 (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack. | |
490 (require 'add-log) | |
491 (set (make-local-variable 'log-view-per-file-logs) nil) | |
492 (set (make-local-variable 'log-view-file-re) "\\`a\\`") | |
493 (set (make-local-variable 'log-view-message-re) | |
494 (if (eq vc-log-view-type 'short) | |
495 "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?" | |
496 "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)")) | |
497 (set (make-local-variable 'log-view-font-lock-keywords) | |
498 ;; log-view-font-lock-keywords is careful to use the buffer-local | |
499 ;; value of log-view-message-re only since Emacs-23. | |
500 (if (eq vc-log-view-type 'short) | |
501 (append `((,log-view-message-re | |
502 (1 'log-view-message-face) | |
503 (2 'change-log-name) | |
504 (3 'change-log-date) | |
505 (4 'change-log-list nil lax)))) | |
506 (append `((,log-view-message-re . 'log-view-message-face)) | |
507 ;; log-view-font-lock-keywords | |
508 '(("^ *\\(?:committer\\|author\\): \ | |
509 \\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]" | |
510 (1 'change-log-name) | |
511 (2 'change-log-email)) | |
512 ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face))))))) | |
513 | |
514 (defun vc-bzr-print-log (files buffer &optional shortlog start-revision limit) | |
515 "Get bzr change log for FILES into specified BUFFER." | |
516 ;; `vc-do-command' creates the buffer, but we need it before running | |
517 ;; the command. | |
518 (vc-setup-buffer buffer) | |
519 ;; If the buffer exists from a previous invocation it might be | |
520 ;; read-only. | |
521 ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so | |
522 ;; the log display may not what the user wants - but I see no other | |
523 ;; way of getting the above regexps working. | |
524 (with-current-buffer buffer | |
525 (apply 'vc-bzr-command "log" buffer 'async files | |
526 (append | |
527 (when shortlog '("--line")) | |
528 (when start-revision (list (format "-r..%s" start-revision))) | |
529 (when limit (list "-l" (format "%s" limit))) | |
530 (if (stringp vc-bzr-log-switches) | |
531 (list vc-bzr-log-switches) | |
532 vc-bzr-log-switches))))) | |
533 | |
534 (defun vc-bzr-log-incoming (buffer remote-location) | |
535 (apply 'vc-bzr-command "missing" buffer 'async nil | |
536 (list "--theirs-only" (unless (string= remote-location "") remote-location)))) | |
537 | |
538 (defun vc-bzr-log-outgoing (buffer remote-location) | |
539 (apply 'vc-bzr-command "missing" buffer 'async nil | |
540 (list "--mine-only" (unless (string= remote-location "") remote-location)))) | |
541 | |
542 (defun vc-bzr-show-log-entry (revision) | |
543 "Find entry for patch name REVISION in bzr change log buffer." | |
544 (goto-char (point-min)) | |
545 (when revision | |
546 (let (case-fold-search | |
547 found) | |
548 (if (re-search-forward | |
549 ;; "revno:" can appear either at the beginning of a line, | |
550 ;; or indented. | |
551 (concat "^[ ]*-+\n[ ]*revno: " | |
552 ;; The revision can contain ".", quote it so that it | |
553 ;; does not interfere with regexp matching. | |
554 (regexp-quote revision) "$") nil t) | |
555 (progn | |
556 (beginning-of-line 0) | |
557 (setq found t)) | |
558 (goto-char (point-min))) | |
559 found))) | |
560 | |
561 (defun vc-bzr-diff (files &optional rev1 rev2 buffer) | |
562 "VC bzr backend for diff." | |
563 ;; `bzr diff' exits with code 1 if diff is non-empty. | |
564 (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*") | |
565 (if vc-disable-async-diff 1 'async) files | |
566 "--diff-options" (mapconcat 'identity | |
567 (vc-switches 'bzr 'diff) | |
568 " ") | |
569 ;; This `when' is just an optimization because bzr-1.2 is *much* | |
570 ;; faster when the revision argument is not given. | |
571 (when (or rev1 rev2) | |
572 (list "-r" (format "%s..%s" | |
573 (or rev1 "revno:-1") | |
574 (or rev2 "")))))) | |
575 | |
576 | |
577 ;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with | |
578 ;; straight integer revisions. | |
579 | |
580 (defun vc-bzr-delete-file (file) | |
581 "Delete FILE and delete it in the bzr repository." | |
582 (condition-case () | |
583 (delete-file file) | |
584 (file-error nil)) | |
585 (vc-bzr-command "remove" nil 0 file)) | |
586 | |
587 (defun vc-bzr-rename-file (old new) | |
588 "Rename file from OLD to NEW using `bzr mv'." | |
589 (vc-bzr-command "mv" nil 0 new old)) | |
590 | |
591 (defvar vc-bzr-annotation-table nil | |
592 "Internal use.") | |
593 (make-variable-buffer-local 'vc-bzr-annotation-table) | |
594 | |
595 (defun vc-bzr-annotate-command (file buffer &optional revision) | |
596 "Prepare BUFFER for `vc-annotate' on FILE. | |
597 Each line is tagged with the revision number, which has a `help-echo' | |
598 property containing author and date information." | |
599 (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all" | |
600 (if revision (list "-r" revision))) | |
601 (lexical-let ((table (make-hash-table :test 'equal))) | |
602 (set-process-filter | |
603 (get-buffer-process buffer) | |
604 (lambda (proc string) | |
605 (when (process-buffer proc) | |
606 (with-current-buffer (process-buffer proc) | |
607 (setq string (concat (process-get proc :vc-left-over) string)) | |
608 (while (string-match "^\\( *[0-9.]+ *\\) \\([^\n ]+\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string) | |
609 (let* ((rev (match-string 1 string)) | |
610 (author (match-string 2 string)) | |
611 (date (match-string 3 string)) | |
612 (key (substring string (match-beginning 0) | |
613 (match-beginning 4))) | |
614 (line (match-string 4 string)) | |
615 (tag (gethash key table)) | |
616 (inhibit-read-only t)) | |
617 (setq string (substring string (match-end 0))) | |
618 (unless tag | |
619 (setq tag | |
620 (propertize | |
621 (format "%s %-7.7s" rev author) | |
622 'help-echo (format "Revision: %d, author: %s, date: %s" | |
623 (string-to-number rev) | |
624 author date) | |
625 'mouse-face 'highlight)) | |
626 (puthash key tag table)) | |
627 (goto-char (process-mark proc)) | |
628 (insert tag line) | |
629 (move-marker (process-mark proc) (point)))) | |
630 (process-put proc :vc-left-over string))))))) | |
631 | |
632 (declare-function vc-annotate-convert-time "vc-annotate" (time)) | |
633 | |
634 (defun vc-bzr-annotate-time () | |
635 (when (re-search-forward "^ *[0-9.]+ +[^\n ]* +|" nil t) | |
636 (let ((prop (get-text-property (line-beginning-position) 'help-echo))) | |
637 (string-match "[0-9]+\\'" prop) | |
638 (let ((str (match-string-no-properties 0 prop))) | |
639 (vc-annotate-convert-time | |
640 (encode-time 0 0 0 | |
641 (string-to-number (substring str 6 8)) | |
642 (string-to-number (substring str 4 6)) | |
643 (string-to-number (substring str 0 4)))))))) | |
644 | |
645 (defun vc-bzr-annotate-extract-revision-at-line () | |
646 "Return revision for current line of annoation buffer, or nil. | |
647 Return nil if current line isn't annotated." | |
648 (save-excursion | |
649 (beginning-of-line) | |
650 (if (looking-at "^ *\\([0-9.]+\\) +[^\n ]* +|") | |
651 (match-string-no-properties 1)))) | |
652 | |
653 (defun vc-bzr-command-discarding-stderr (command &rest args) | |
654 "Execute shell command COMMAND (with ARGS); return its output and exitcode. | |
655 Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is | |
656 the (numerical) exit code of the process, and OUTPUT is a string | |
657 containing whatever the process sent to its standard output | |
658 stream. Standard error output is discarded." | |
659 (with-temp-buffer | |
660 (cons | |
661 (apply #'process-file command nil (list (current-buffer) nil) nil args) | |
662 (buffer-substring (point-min) (point-max))))) | |
663 | |
664 (defstruct (vc-bzr-extra-fileinfo | |
665 (:copier nil) | |
666 (:constructor vc-bzr-create-extra-fileinfo (extra-name)) | |
667 (:conc-name vc-bzr-extra-fileinfo->)) | |
668 extra-name) ;; original name for rename targets, new name for | |
669 | |
670 (defun vc-bzr-dir-printer (info) | |
671 "Pretty-printer for the vc-dir-fileinfo structure." | |
672 (let ((extra (vc-dir-fileinfo->extra info))) | |
673 (vc-default-dir-printer 'Bzr info) | |
674 (when extra | |
675 (insert (propertize | |
676 (format " (renamed from %s)" | |
677 (vc-bzr-extra-fileinfo->extra-name extra)) | |
678 'face 'font-lock-comment-face))))) | |
679 | |
680 ;; FIXME: this needs testing, it's probably incomplete. | |
681 (defun vc-bzr-after-dir-status (update-function relative-dir) | |
682 (let ((status-str nil) | |
683 (translation '(("+N " . added) | |
684 ("-D " . removed) | |
685 (" M " . edited) ;; file text modified | |
686 (" *" . edited) ;; execute bit changed | |
687 (" M*" . edited) ;; text modified + execute bit changed | |
688 ;; FIXME: what about ignored files? | |
689 (" D " . missing) | |
690 ;; For conflicts, should we list the .THIS/.BASE/.OTHER? | |
691 ("C " . conflict) | |
692 ("? " . unregistered) | |
693 ;; No such state, but we need to distinguish this case. | |
694 ("R " . renamed) | |
695 ("RM " . renamed) | |
696 ;; For a non existent file FOO, the output is: | |
697 ;; bzr: ERROR: Path(s) do not exist: FOO | |
698 ("bzr" . not-found) | |
699 ;; If the tree is not up to date, bzr will print this warning: | |
700 ;; working tree is out of date, run 'bzr update' | |
701 ;; ignore it. | |
702 ;; FIXME: maybe this warning can be put in the vc-dir header... | |
703 ("wor" . not-found) | |
704 ;; Ignore "P " and "P." for pending patches. | |
705 ("P " . not-found) | |
706 ("P. " . not-found) | |
707 )) | |
708 (translated nil) | |
709 (result nil)) | |
710 (goto-char (point-min)) | |
711 (while (not (eobp)) | |
712 (setq status-str | |
713 (buffer-substring-no-properties (point) (+ (point) 3))) | |
714 (setq translated (cdr (assoc status-str translation))) | |
715 (cond | |
716 ((eq translated 'conflict) | |
717 ;; For conflicts the file appears twice in the listing: once | |
718 ;; with the M flag and once with the C flag, so take care | |
719 ;; not to add it twice to `result'. Ugly. | |
720 (let* ((file | |
721 (buffer-substring-no-properties | |
722 ;;For files with conflicts the format is: | |
723 ;;C Text conflict in FILENAME | |
724 ;; Bah. | |
725 (+ (point) 21) (line-end-position))) | |
726 (entry (assoc file result))) | |
727 (when entry | |
728 (setf (nth 1 entry) 'conflict)))) | |
729 ((eq translated 'renamed) | |
730 (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t) | |
731 (let ((new-name (file-relative-name (match-string 2) relative-dir)) | |
732 (old-name (file-relative-name (match-string 1) relative-dir))) | |
733 (push (list new-name 'edited | |
734 (vc-bzr-create-extra-fileinfo old-name)) result))) | |
735 ;; do nothing for non existent files | |
736 ((eq translated 'not-found)) | |
737 (t | |
738 (push (list (file-relative-name | |
739 (buffer-substring-no-properties | |
740 (+ (point) 4) | |
741 (line-end-position)) relative-dir) | |
742 translated) result))) | |
743 (forward-line)) | |
744 (funcall update-function result))) | |
745 | |
746 (defun vc-bzr-dir-status (dir update-function) | |
747 "Return a list of conses (file . state) for DIR." | |
748 (vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S") | |
749 (vc-exec-after | |
750 `(vc-bzr-after-dir-status (quote ,update-function) | |
751 ;; "bzr status" results are relative to | |
752 ;; the bzr root directory, NOT to the | |
753 ;; directory "bzr status" was invoked in. | |
754 ;; Ugh. | |
755 ;; We pass the relative directory here so | |
756 ;; that `vc-bzr-after-dir-status' can | |
757 ;; frob the results accordingly. | |
758 (file-relative-name ,dir (vc-bzr-root ,dir))))) | |
759 | |
760 (defun vc-bzr-dir-status-files (dir files default-state update-function) | |
761 "Return a list of conses (file . state) for DIR." | |
762 (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files) | |
763 (vc-exec-after | |
764 `(vc-bzr-after-dir-status (quote ,update-function) | |
765 (file-relative-name ,dir (vc-bzr-root ,dir))))) | |
766 | |
767 (defvar vc-bzr-shelve-map | |
768 (let ((map (make-sparse-keymap))) | |
769 ;; Turn off vc-dir marking | |
770 (define-key map [mouse-2] 'ignore) | |
771 | |
772 (define-key map [down-mouse-3] 'vc-bzr-shelve-menu) | |
773 (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point) | |
774 (define-key map "=" 'vc-bzr-shelve-show-at-point) | |
775 (define-key map "\C-m" 'vc-bzr-shelve-show-at-point) | |
776 (define-key map "A" 'vc-bzr-shelve-apply-and-keep-at-point) | |
777 (define-key map "P" 'vc-bzr-shelve-apply-at-point) | |
778 (define-key map "S" 'vc-bzr-shelve-snapshot) | |
779 map)) | |
780 | |
781 (defvar vc-bzr-shelve-menu-map | |
782 (let ((map (make-sparse-keymap "Bzr Shelve"))) | |
783 (define-key map [de] | |
784 '(menu-item "Delete shelf" vc-bzr-shelve-delete-at-point | |
785 :help "Delete the current shelf")) | |
786 (define-key map [ap] | |
787 '(menu-item "Apply and keep shelf" vc-bzr-shelve-apply-and-keep-at-point | |
788 :help "Apply the current shelf and keep it")) | |
789 (define-key map [po] | |
790 '(menu-item "Apply and remove shelf (pop)" vc-bzr-shelve-apply-at-point | |
791 :help "Apply the current shelf and remove it")) | |
792 (define-key map [sh] | |
793 '(menu-item "Show shelve" vc-bzr-shelve-show-at-point | |
794 :help "Show the contents of the current shelve")) | |
795 map)) | |
796 | |
797 (defvar vc-bzr-extra-menu-map | |
798 (let ((map (make-sparse-keymap))) | |
799 (define-key map [bzr-sn] | |
800 '(menu-item "Shelve a snapshot" vc-bzr-shelve-snapshot | |
801 :help "Shelve the current state of the tree and keep the current state")) | |
802 (define-key map [bzr-sh] | |
803 '(menu-item "Shelve..." vc-bzr-shelve | |
804 :help "Shelve changes")) | |
805 map)) | |
806 | |
807 (defun vc-bzr-extra-menu () vc-bzr-extra-menu-map) | |
808 | |
809 (defun vc-bzr-extra-status-menu () vc-bzr-extra-menu-map) | |
810 | |
811 (defun vc-bzr-dir-extra-headers (dir) | |
812 (let* | |
813 ((str (with-temp-buffer | |
814 (vc-bzr-command "info" t 0 dir) | |
815 (buffer-string))) | |
816 (shelve (vc-bzr-shelve-list)) | |
817 (shelve-help-echo "Use M-x vc-bzr-shelve to create shelves") | |
818 (root-dir (vc-bzr-root dir)) | |
819 (pending-merge | |
820 ;; FIXME: looking for .bzr/checkout/merge-hashes is not a | |
821 ;; reliable method to detect pending merges, disable this | |
822 ;; until a proper solution is implemented. | |
823 (and nil | |
824 (file-exists-p | |
825 (expand-file-name ".bzr/checkout/merge-hashes" root-dir)))) | |
826 (pending-merge-help-echo | |
827 (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)) | |
828 (light-checkout | |
829 (when (string-match ".+light checkout root: \\(.+\\)$" str) | |
830 (match-string 1 str))) | |
831 (light-checkout-branch | |
832 (when light-checkout | |
833 (when (string-match ".+checkout of branch: \\(.+\\)$" str) | |
834 (match-string 1 str))))) | |
835 (concat | |
836 (propertize "Parent branch : " 'face 'font-lock-type-face) | |
837 (propertize | |
838 (if (string-match "parent branch: \\(.+\\)$" str) | |
839 (match-string 1 str) | |
840 "None") | |
841 'face 'font-lock-variable-name-face) | |
842 "\n" | |
843 (when light-checkout | |
844 (concat | |
845 (propertize "Light checkout root: " 'face 'font-lock-type-face) | |
846 (propertize light-checkout 'face 'font-lock-variable-name-face) | |
847 "\n")) | |
848 (when light-checkout-branch | |
849 (concat | |
850 (propertize "Checkout of branch : " 'face 'font-lock-type-face) | |
851 (propertize light-checkout-branch 'face 'font-lock-variable-name-face) | |
852 "\n")) | |
853 (when pending-merge | |
854 (concat | |
855 (propertize "Warning : " 'face 'font-lock-warning-face | |
856 'help-echo pending-merge-help-echo) | |
857 (propertize "Pending merges, commit recommended before any other action" | |
858 'help-echo pending-merge-help-echo | |
859 'face 'font-lock-warning-face) | |
860 "\n")) | |
861 (if shelve | |
862 (concat | |
863 (propertize "Shelves :\n" 'face 'font-lock-type-face | |
864 'help-echo shelve-help-echo) | |
865 (mapconcat | |
866 (lambda (x) | |
867 (propertize x | |
868 'face 'font-lock-variable-name-face | |
869 'mouse-face 'highlight | |
870 '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" | |
871 'keymap vc-bzr-shelve-map)) | |
872 shelve "\n")) | |
873 (concat | |
874 (propertize "Shelves : " 'face 'font-lock-type-face | |
875 'help-echo shelve-help-echo) | |
876 (propertize "No shelved changes" | |
877 'help-echo shelve-help-echo | |
878 'face 'font-lock-variable-name-face)))))) | |
879 | |
880 (defun vc-bzr-shelve (name) | |
881 "Create a shelve." | |
882 (interactive "sShelf name: ") | |
883 (let ((root (vc-bzr-root default-directory))) | |
884 (when root | |
885 (vc-bzr-command "shelve" nil 0 nil "--all" "-m" name) | |
886 (vc-resynch-buffer root t t)))) | |
887 | |
888 (defun vc-bzr-shelve-show (name) | |
889 "Show the contents of shelve NAME." | |
890 (interactive "sShelve name: ") | |
891 (vc-setup-buffer "*vc-diff*") | |
892 ;; FIXME: how can you show the contents of a shelf? | |
893 (vc-bzr-command "unshelve" "*vc-diff*" 'async nil "--preview" name) | |
894 (set-buffer "*vc-diff*") | |
895 (diff-mode) | |
896 (setq buffer-read-only t) | |
897 (pop-to-buffer (current-buffer))) | |
898 | |
899 (defun vc-bzr-shelve-apply (name) | |
900 "Apply shelve NAME and remove it afterwards." | |
901 (interactive "sApply (and remove) shelf: ") | |
902 (vc-bzr-command "unshelve" nil 0 nil "--apply" name) | |
903 (vc-resynch-buffer (vc-bzr-root default-directory) t t)) | |
904 | |
905 (defun vc-bzr-shelve-apply-and-keep (name) | |
906 "Apply shelve NAME and keep it afterwards." | |
907 (interactive "sApply (and keep) shelf: ") | |
908 (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep" name) | |
909 (vc-resynch-buffer (vc-bzr-root default-directory) t t)) | |
910 | |
911 (defun vc-bzr-shelve-snapshot () | |
912 "Create a stash with the current tree state." | |
913 (interactive) | |
914 (vc-bzr-command "shelve" nil 0 nil "--all" "-m" | |
915 (let ((ct (current-time))) | |
916 (concat | |
917 (format-time-string "Snapshot on %Y-%m-%d" ct) | |
918 (format-time-string " at %H:%M" ct)))) | |
919 (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep") | |
920 (vc-resynch-buffer (vc-bzr-root default-directory) t t)) | |
921 | |
922 (defun vc-bzr-shelve-list () | |
923 (with-temp-buffer | |
924 (vc-bzr-command "shelve" (current-buffer) 1 nil "--list" "-q") | |
925 (delete | |
926 "" | |
927 (split-string | |
928 (buffer-substring (point-min) (point-max)) | |
929 "\n")))) | |
930 | |
931 (defun vc-bzr-shelve-get-at-point (point) | |
932 (save-excursion | |
933 (goto-char point) | |
934 (beginning-of-line) | |
935 (if (looking-at "^ +\\([0-9]+\\):") | |
936 (match-string 1) | |
937 (error "Cannot find shelf at point")))) | |
938 | |
939 (defun vc-bzr-shelve-delete-at-point () | |
940 (interactive) | |
941 (let ((shelve (vc-bzr-shelve-get-at-point (point)))) | |
942 (when (y-or-n-p (format "Remove shelf %s ?" shelve)) | |
943 (vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve) | |
944 (vc-dir-refresh)))) | |
945 | |
946 (defun vc-bzr-shelve-show-at-point () | |
947 (interactive) | |
948 (vc-bzr-shelve-show (vc-bzr-shelve-get-at-point (point)))) | |
949 | |
950 (defun vc-bzr-shelve-apply-at-point () | |
951 (interactive) | |
952 (vc-bzr-shelve-apply (vc-bzr-shelve-get-at-point (point)))) | |
953 | |
954 (defun vc-bzr-shelve-apply-and-keep-at-point () | |
955 (interactive) | |
956 (vc-bzr-shelve-apply-and-keep (vc-bzr-shelve-get-at-point (point)))) | |
957 | |
958 (defun vc-bzr-shelve-menu (e) | |
959 (interactive "e") | |
960 (vc-dir-at-event e (popup-menu vc-bzr-shelve-menu-map e))) | |
961 | |
962 (defun vc-bzr-revision-table (files) | |
963 (let ((vc-bzr-revisions '()) | |
964 (default-directory (file-name-directory (car files)))) | |
965 (with-temp-buffer | |
966 (vc-bzr-command "log" t 0 files "--line") | |
967 (let ((start (point-min)) | |
968 (loglines (buffer-substring-no-properties (point-min) (point-max)))) | |
969 (while (string-match "^\\([0-9]+\\):" loglines) | |
970 (push (match-string 1 loglines) vc-bzr-revisions) | |
971 (setq start (+ start (match-end 0))) | |
972 (setq loglines (buffer-substring-no-properties start (point-max)))))) | |
973 vc-bzr-revisions)) | |
974 | |
975 (defun vc-bzr-conflicted-files (dir) | |
976 (let ((default-directory (vc-bzr-root dir)) | |
977 (files ())) | |
978 (with-temp-buffer | |
979 (vc-bzr-command "status" t 0 default-directory) | |
980 (goto-char (point-min)) | |
981 (when (re-search-forward "^conflicts:\n" nil t) | |
982 (while (looking-at " \\(?:Text conflict in \\(.*\\)\\|.*\\)\n") | |
983 (if (match-end 1) | |
984 (push (expand-file-name (match-string 1)) files)) | |
985 (goto-char (match-end 0))))) | |
986 files)) | |
987 | |
988 ;;; Revision completion | |
989 | |
990 (eval-and-compile | |
991 (defconst vc-bzr-revision-keywords | |
992 '("revno" "revid" "last" "before" | |
993 "tag" "date" "ancestor" "branch" "submit"))) | |
994 | |
995 (defun vc-bzr-revision-completion-table (files) | |
996 (lexical-let ((files files)) | |
997 ;; What about using `files'?!? --Stef | |
998 (lambda (string pred action) | |
999 (cond | |
1000 ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):" | |
1001 string) | |
1002 (completion-table-with-context (substring string 0 (match-end 0)) | |
1003 (apply-partially | |
1004 'completion-table-with-predicate | |
1005 'completion-file-name-table | |
1006 'file-directory-p t) | |
1007 (substring string (match-end 0)) | |
1008 pred | |
1009 action)) | |
1010 ((string-match "\\`\\(before\\):" string) | |
1011 (completion-table-with-context (substring string 0 (match-end 0)) | |
1012 (vc-bzr-revision-completion-table files) | |
1013 (substring string (match-end 0)) | |
1014 pred | |
1015 action)) | |
1016 ((string-match "\\`\\(tag\\):" string) | |
1017 (let ((prefix (substring string 0 (match-end 0))) | |
1018 (tag (substring string (match-end 0))) | |
1019 (table nil) | |
1020 process-file-side-effects) | |
1021 (with-temp-buffer | |
1022 ;; "bzr-1.2 tags" is much faster with --show-ids. | |
1023 (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids") | |
1024 ;; The output is ambiguous, unless we assume that revids do not | |
1025 ;; contain spaces. | |
1026 (goto-char (point-min)) | |
1027 (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t) | |
1028 (push (match-string-no-properties 1) table))) | |
1029 (completion-table-with-context prefix table tag pred action))) | |
1030 | |
1031 ((string-match "\\`\\([a-z]+\\):" string) | |
1032 ;; no actual completion for the remaining keywords. | |
1033 (completion-table-with-context (substring string 0 (match-end 0)) | |
1034 (if (member (match-string 1 string) | |
1035 vc-bzr-revision-keywords) | |
1036 ;; If it's a valid keyword, | |
1037 ;; use a non-empty table to | |
1038 ;; indicate it. | |
1039 '("") nil) | |
1040 (substring string (match-end 0)) | |
1041 pred | |
1042 action)) | |
1043 (t | |
1044 ;; Could use completion-table-with-terminator, except that it | |
1045 ;; currently doesn't work right w.r.t pcm and doesn't give | |
1046 ;; the *Completions* output we want. | |
1047 (complete-with-action action (eval-when-compile | |
1048 (mapcar (lambda (s) (concat s ":")) | |
1049 vc-bzr-revision-keywords)) | |
1050 string pred)))))) | |
1051 | |
1052 (eval-after-load "vc" | |
1053 '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t)) | |
1054 | |
1055 (provide 'vc-bzr) | |
1056 ;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06 | |
1057 ;;; vc-bzr.el ends here |