code.delx.au - gnu-emacs/blob - lisp/vc/vc-bzr.el

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