lisp/vc-bzr.el

   1 ;;; vc-bzr.el --- VC backend for the bzr revision control system
   2
   3 ;; Copyright (C) 2006, 2007  Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Love <fx@gnu.org>, Riccardo Murri <riccardo.murri@gmail.com>
   6 ;; Keywords: tools
   7 ;; Created: Sept 2006
   8 ;; Version: 2007-08-03
   9 ;; URL: http://launchpad.net/vc-bzr
  10
  11 ;; This file is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; This file is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26
  27 ;;; Commentary:
  28
  29 ;; See <URL:http://bazaar-vcs.org/> concerning bzr.
  30
  31 ;; Load this library to register bzr support in VC.  It covers basic VC
  32 ;; functionality, but was only lightly exercised with a few Emacs/bzr
  33 ;; version combinations, namely those current on the authors' PCs.
  34 ;; See various Fixmes below.
  35
  36
  37 ;; Known bugs
  38 ;; ==========
  39
  40 ;; When edititing a symlink and *both* the symlink and its target
  41 ;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
  42 ;; symlink, thereby not detecting whether the actual contents
  43 ;; (that is, the target contents) are changed.
  44 ;; See https://bugs.launchpad.net/vc-bzr/+bug/116607
  45
  46 ;; For an up-to-date list of bugs, please see:
  47 ;;   https://bugs.launchpad.net/vc-bzr/+bugs
  48
  49
  50 ;;; Code:
  51
  52 (eval-when-compile
  53   (require 'cl)
  54   (require 'vc))                        ; for vc-exec-after
  55
  56 ;; Clear up the cache to force vc-call to check again and discover
  57 ;; new functions when we reload this file.
  58 (put 'Bzr 'vc-functions nil)
  59
  60 (defgroup vc-bzr nil
  61   "VC bzr backend."
  62 ;;   :version "22"
  63   :group 'vc)
  64
  65 (defcustom vc-bzr-program "bzr"
  66   "Name of the bzr command (excluding any arguments)."
  67   :group 'vc-bzr
  68   :type 'string)
  69
  70 ;; Fixme: there's probably no call for this.
  71 (defcustom vc-bzr-program-args nil
  72   "List of global arguments to pass to `vc-bzr-program'."
  73   :group 'vc-bzr
  74   :type '(repeat string))
  75
  76 (defcustom vc-bzr-diff-switches nil
  77   "String/list of strings specifying extra switches for bzr diff 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 ;; since v0.9, bzr supports removing the progress indicators
  84 ;; by setting environment variable BZR_PROGRESS_BAR to "none".
  85 (defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args)
  86   "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
  87 Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment."
  88   (let ((process-environment
  89          (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
  90                 "LC_ALL=C"              ; Force English output
  91                 process-environment)))
  92     (apply 'vc-do-command buffer okstatus vc-bzr-program
  93            file-or-list bzr-command (append vc-bzr-program-args args))))
  94
  95 ;;;###autoload
  96 (defconst vc-bzr-admin-dirname ".bzr"    ; FIXME: "_bzr" on w32?
  97   "Name of the directory containing Bzr repository status files.")
  98 ;;;###autoload
  99 (defconst vc-bzr-admin-checkout-format-file
 100   (concat vc-bzr-admin-dirname "/checkout/format"))
 101 (defconst vc-bzr-admin-dirstate
 102   (concat vc-bzr-admin-dirname "/checkout/dirstate"))
 103 (defconst vc-bzr-admin-branch-format-file
 104   (concat vc-bzr-admin-dirname "/branch/format"))
 105 (defconst vc-bzr-admin-revhistory
 106   (concat vc-bzr-admin-dirname "/branch/revision-history"))
 107
 108 ;;;###autoload (defun vc-bzr-registered (file)
 109 ;;;###autoload   (if (vc-find-root file vc-bzr-admin-checkout-format-file)
 110 ;;;###autoload       (progn
 111 ;;;###autoload         (load "vc-bzr")
 112 ;;;###autoload         (vc-bzr-registered file))))
 113
 114 (defun vc-bzr-root (file)
 115   "Return the root directory of the bzr repository containing FILE."
 116   ;; Cache technique copied from vc-arch.el.
 117   (or (vc-file-getprop file 'bzr-root)
 118       (vc-file-setprop
 119        file 'bzr-root
 120        (vc-find-root file vc-bzr-admin-checkout-format-file))))
 121
 122 (defun vc-bzr-registered (file)
 123   "Return non-nil if FILE is registered with bzr.
 124
 125 For speed, this function tries first to parse Bzr internal file
 126 `checkout/dirstate', but it may fail if Bzr internal file format
 127 has changed.  As a safeguard, the `checkout/dirstate' file is
 128 only parsed if it contains the string `#bazaar dirstate flat
 129 format 3' in the first line.
 130
 131 If the `checkout/dirstate' file cannot be parsed, fall back to
 132 running `vc-bzr-state'."
 133   (condition-case nil
 134       (lexical-let ((root (vc-bzr-root file)))
 135     (and root ; Short cut.
 136          ;; This looks at internal files.  May break if they change
 137          ;; their format.
 138              (lexical-let
 139                  ((dirstate-file (expand-file-name vc-bzr-admin-dirstate root)))
 140                (if (file-exists-p dirstate-file)
 141          (with-temp-buffer
 142                      (insert-file-contents dirstate-file)
 143            (goto-char (point-min))
 144                      (when (looking-at "#bazaar dirstate flat format 3")
 145            (let* ((relfile (file-relative-name file root))
 146                   (reldir (file-name-directory relfile)))
 147              (re-search-forward
 148               (concat "^