;;; vc-bzr.el --- VC backend for the bzr revision control system

;; Copyright (C) 2006, 2007  Free Software Foundation, Inc.

;; Author: Dave Love <fx@gnu.org>
;; Keywords: tools
;; Created: Sept 2006
;; $Revision: 15$
;; URL: http://www.loveshack.ukfsn.org/emacs

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; See <URL:http://bazaar-vcs.org/> concerning bzr.

;; Load this library to register bzr support in VC.  The support is
;; preliminary and incomplete, adapted from my darcs version.  Lightly
;; exercised with bzr 0.8 and 0.15, and Emacs 21.  See various Fixmes
;; below.  See also some fixed-up VC functions in fx-misc.el from the
;; URL above, especially for dealing with plain integer version
;; numbers.

;; Note that Riccardo Murri wrote an earlier vc-bzr.  I started making
;; changes to that, but ended up basically re-writing it, so decided
;; to start again on this version.  Murri says this one is better and
;; has withdrawn his.

;; This should be suitable for direct inclusion in Emacs if someone
;; can persuade rms.

;;; Code:

(eval-when-compile
  (require 'vc))			; for vc-exec-after

(defgroup vc-bzr nil
  "VC bzr backend."
;;   :version "22"
  :group 'vc)

(defcustom vc-bzr-program "bzr"
  "*Name of the bzr command (excluding any arguments)."
  :group 'vc-bzr
  :type 'string)

;; Fixme: there's probably no call for this.
(defcustom vc-bzr-program-args nil
  "*List of global arguments to pass to `vc-bzr-program'."
  :group 'vc-bzr
  :type '(repeat string))

(defcustom vc-bzr-diff-switches nil
  "*String/list of strings specifying extra switches for bzr diff under VC."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List" :value ("") string))
  :group 'vc-bzr)

(defvar vc-bzr-version nil
  "Internal use.")

;; Could be used for compatibility checks if bzr changes.
(defun vc-bzr-version ()
  "Return a three-numeric element list with components of the bzr version.
This is of the form (X Y Z) for revision X.Y.Z.  The elements are zero
if running `vc-bzr-program' doesn't produce the expected output."
  (if vc-bzr-version
      vc-bzr-version
    (let ((s (shell-command-to-string
	      (concat (shell-quote-argument vc-bzr-program) " --version"))))
      (if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" s)
	  (setq vc-bzr-version (list (string-to-number (match-string 1 s))
				     (string-to-number (match-string 2 s))
				     (string-to-number (match-string 3 s))))
	'(0 0 0)))))

(defun vc-bzr-command (command buffer okstatus file &rest args)
  "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND."
  ;; Note:  The ^Ms from the progress-indicator stuff that bzr prints
  ;; on stderr cause auto-detection of a mac coding system on the
  ;; stream for async output.  bzr ought to be fixed to be able to
  ;; suppress this.  See also `vc-bzr-post-command-function'.  (We
  ;; can't sink the stderr output in `vc-do-command' or run under the
  ;; shell to do the job without re-writing `vc-do-command'.)
  (apply 'vc-do-command buffer okstatus vc-bzr-program
	 file command (append vc-bzr-program-args args '("--"))))

;; Fixme: Doubtless this will lose in future as more sorts of messages
;; appear on stderr...
(defun vc-bzr-post-command-function (command file flags)
  "`vc-post-command-functions' function to remove progress messages."
  ;; Note that using this requires that the vc command is run
  ;; synchronously.  Otherwise, the ^Ms in the leading progress
  ;; message on stdout cause the stream to be interpreted as having
  ;; DOS line endings, losing the ^Ms, so the search fails.  I don't
  ;; know how this works under Windows.
  (when (equal command vc-bzr-program)
    (save-excursion
      (goto-char (point-min))
      (if (looking-at "^\\(\r.*\r\\)[^\r]+$")
	  (replace-match "" nil nil nil 1)))
    (save-excursion
      (goto-char (point-min))
      ;; This is inserted by bzr 0.11 `log', at least
      (while (looking-at "read knit.*\n")
	(replace-match "")))
    (save-excursion
      (goto-char (point-min))
      ;; `Working tree format 3...' from bzr 0.15
      (if (looking-at ".* format .* is deprecated and a better format is available.
It is recommended that you upgrade by running the command
  bzr upgrade .*
")
	  (replace-match "")))))

(add-hook 'vc-post-command-functions 'vc-bzr-post-command-function)

;; Fixme:  If we're only interested in status messages, we only need
;; to set LC_MESSAGES, and we might need finer control of this.  This
;; is moot anyhow, since bzr doesn't appear to be localized at all
;; (yet?).
(eval-when-compile
(defmacro vc-bzr-with-c-locale (&rest body)
  "Run BODY with LC_ALL=C in the process environment.
This ensures that messages to be matched come out as expected."
  `(let ((process-environment (cons "LC_ALL=C" process-environment)))
     ,@body)))
(put 'vc-bzr-with-c-locale 'edebug-form-spec t)
(put 'vc-bzr-with-c-locale 'lisp-indent-function 0)

(defun vc-bzr-bzr-dir (file)
  "Return the .bzr directory in the hierarchy above FILE.
Return nil if there isn't one."
  (or (vc-file-getprop file 'bzr-dir)
      (let ((dir (if (file-directory-p (setq file (expand-file-name file)))
		     file
		   (file-name-directory file)))
	    bzr)
	(vc-file-setprop
	 file 'bzr-dir
	 (catch 'found
	   (while t
	     (setq bzr (expand-file-name ".bzr" dir)) ; fixme: "_bzr" on Doze??
	     (if (file-directory-p bzr)
		 (throw 'found (file-name-as-directory bzr)))
	     (if (equal "" (file-name-nondirectory (directory-file-name dir)))
		 (throw 'found nil)
	       (setq dir (file-name-directory (directory-file-name dir))))))))))

(defun vc-bzr-registered (file)
  "Return non-nil if FILE is registered with bzr."
  (if (vc-bzr-bzr-dir file)		; short cut
      (vc-bzr-state file)))		; expensive

(defun vc-bzr-state (file)
  (let (ret state msgs)
    (with-temp-buffer
      (cd (file-name-directory file))
      (setq ret (vc-bzr-with-c-locale (vc-bzr-command "status" t 255 file)))
      (goto-char 1)
      (save-excursion
	(when (re-search-forward "^pending merges:" nil t)
	  (push "pending merges on branch" msgs)))
      ;; We can get random messages like `Working tree format ... is
      ;; deprecated...'  at the head of the output, so try to avoid
      ;; too many assumptions about the format of the buffer.
      ;; Actually, that should now be got by
      ;; `vc-bzr-post-command-function', but...
      (setq state
	    (cond
	     ((not (equal ret 0)) nil)
	     ((save-excursion
		(when (re-search-forward
		       (concat "conflict in "
			       (file-relative-name
				file (file-name-directory
				      (directory-file-name
				       (vc-bzr-bzr-dir file)))))
		       nil t)
		  (push "conflicts" msgs)
		  ;; Should be a specific state -- see comment in
		  ;; recent vc-hooks.el.  Set a special file property
		  ;; anyhow.
		  (vc-file-setprop file 'bzr-state 'conflict)
		  'edited)) )
	     ;; Fixme:  Also get this in a non-registered sub-directory.
	     ((looking-at "^$") 'up-to-date)
	     ((re-search-forward
	       "^\\(?:added\\|renamed\\|modified\\|removed\\|kind changed\\)"
	       nil t)
	      'edited)
	     ((re-search-forward "^unknown\\|^ignored" nil t) nil)
	     ;; We used to raise an error here, but we can't tell what
	     ;; we might have in the buffer, e.g. just the deprecation
	     ;; warning mentioned above for an up-to-date file.
	     ;; Assuming up-to-date is safest.
	     (t 'up-to-date)))
      ;; Fixme:  Maybe the info should be used in the mode-line
      ;; indicator, though it wouldn't necessarily be valid when
      ;; displayed.  Anyhow, kludge it to avoid a message when the
      ;; file isn't explictly found interactively.
      (if (and msgs
	       (symbolp last-command)
	       ;; find-file, find-alternate-file-other-window,
	       ;; dired-find-file, &c:
	       (string-match "\\<\\(?:find-file\\|find-alternate-file\\)\\>"
			     (symbol-name last-command)))
	  (message "Warning: bzr-controlled file with %s "
			(mapconcat 'identity msgs " and ")))
      (when state
	(vc-file-setprop file 'vc-workfile-version
			 (vc-bzr-workfile-version file))
	(vc-file-setprop file 'vc-state state))
      state)))

(defun vc-bzr-workfile-unchanged-p (file)
  (eq 'up-to-date (vc-bzr-state file)))

(defun vc-bzr-workfile-version (file)
  (with-temp-buffer
    (vc-bzr-command "revno" t 0 file)
    (goto-char 1)
    (buffer-substring 1 (line-end-position))))

(defun vc-bzr-checkout-model (file)
  'implicit)

(defun vc-bzr-register (file &optional rev comment)
  "Register FILE under bzr.
Signal an error unless REV is nil.
COMMENT is ignored."
  (if rev (error "Can't register explicit version with bzr"))
  (vc-bzr-command "add" nil 0 file))

;; Could run `bzr status' in the directory and see if it succeeds, but
;; that's relatively expensive.
(defun vc-bzr-responsible-p (file)
  "Return non-nil if FILE is (potentially) controlled by bzr.
The criterion is that there is a `.bzr' directory in the same
or a superior directory."
  (vc-bzr-bzr-dir file))

(defun vc-bzr-could-register (file)
  "Return non-nil if FILE could be registered under bzr."
  (and (vc-bzr-responsible-p file)	; shortcut
       (condition-case ()
	   (with-temp-buffer
	     (vc-bzr-command "add" t 0 file "--dry-run")
	     ;; The command succeeds with no output if file is
	     ;; registered (in bzr 0.8).
	     (goto-char 1)
	     (looking-at "added "))
	 (error))))

(defun vc-bzr-unregister (file)
  "Unregister FILE from bzr."
  (vc-bzr-command "remove" nil 0 file))

(defun vc-bzr-checkin (file rev comment)
  "Check FILE in to bzr with log message COMMENT.
REV non-nil gets an error."
  (if rev (error "Can't check in a specific version with bzr"))
  (vc-bzr-command "commit" nil 0 file "-m" comment))

;; Note that we lose here if there's sonething on stderr that isn't
;; got by `vc-bzr-post-command-function'.

(defun vc-bzr-checkout (file &optional editable rev destfile)
  "Checkout revision REV of FILE from bzr to DESTFILE.
EDITABLE is ignored."
  (unless destfile
    (setq destfile (vc-version-backup-file-name file rev)))
  ;; Fixme:  Should this necessarily be binary?
  (let ((coding-system-for-read 'binary)
	(coding-system-for-write 'binary))
  (with-temp-file destfile
    (if rev
	(vc-bzr-command "cat" t 0 file "-r" rev)
      (vc-bzr-command "cat" t 0 file)))))

(defun vc-bzr-revert (file &optional contents-done)
  (unless contents-done
    (with-temp-buffer (vc-bzr-command "revert" t 'async file))))

(eval-when-compile
  (defvar log-view-message-re)
  (defvar log-view-file-re)
  (defvar log-view-font-lock-keywords)
  (defvar log-view-current-tag-function))

;; Grim hack to account for lack of an extension mechanism for
;; log-view.  Should be fixed in VC...
(defun vc-bzr-log-view-hook (&optional file)
  "To be added to `log-view-mode-hook' to set variables for bzr output.
Removes itself after running."
  (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-hook)
  (require 'add-log)
  ;; We don't have file markers, so use impossible regexp.
  (set (make-local-variable 'log-view-file-re) "\\'\\`")
  ;; Note we don't want to match the indented versions; they may be
  ;; from merges or from changes not made to this file.
  (set (make-local-variable 'log-view-message-re) "^-+\nrevno: [0-9]+")
  (set (make-local-variable 'log-view-font-lock-keywords)
       ;; Let's highlight indented commiters and timestamps, though,
       ;; even if they're not actually relevant.
       `(("^ *committer: \
\\([^<(]+?\\)[ 	]*[(<]\\([A-Za-z0-9_.-]+@[A-Za-z0-9_.-]+\\)[>)]"
	  nil nil
	  (1 'change-log-name-face nil t)
	  (2 'change-log-email-face nil t)
	  (3 'change-log-email-face nil t))
	 ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face))
	 (,log-view-message-re . 'log-view-message-face)
;; 	 ("^  \\(.*\\)$" (1 'log-view-message-face))
	 )))

(defun vc-bzr-print-log (file &optional buffer) ; get buffer arg in Emacs 22
  "Get bzr change log for FILE into specified BUFFER."
  ;; Fixme: VC needs a hook to sort out the mode for the buffer, or at
  ;; least set the regexps right.
  ;; Fixme: This might need the locale fixing up if things like `revno'
  ;; got localized, but certainly it shouldn't use LC_ALL=C.
  ;; NB.  Can't be async -- see `vc-bzr-post-command-function'.
  (vc-bzr-command "log" buffer 0 file)
  (unless (fboundp 'vc-log-view-hook)	; proposed extension
    (add-hook 'log-view-mode-hook 'vc-bzr-log-view-hook)))

(defun vc-bzr-show-log-entry (version)
  "Find entry for patch name VERSION in bzr change log buffer."
  (goto-char (point-min))
  (let (case-fold-search)
    (if (re-search-forward (concat "^-+\nrevno: " version "$") nil t)
	(beginning-of-line 0)
      (goto-char (point-min)))))

;; Fixem: vc-bzr-wash-log

(autoload 'vc-diff-switches-list "vc" nil nil t)

(defun vc-bzr-diff (file &optional rev1 rev2 buffer)
  "VC bzr backend for diff."
  (let ((working (vc-workfile-version file)))
    (if (and (equal rev1 working) (not rev2))
	(setq rev1 nil))
    (if (and (not rev1) rev2)
	(setq rev1 working))
    ;; NB.  Can't be async -- see `vc-bzr-post-command-function'.
    ;; bzr diff produces condition code 1 for some reason.
    (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*") 1 file
	   "--diff-options" (mapconcat 'identity (vc-diff-switches-list bzr)
				       " ")
	   (when rev1
	     (if rev2
		 (list "-r" (format "%s..%s" rev1 rev2))
	       (list "-r" rev1))))))

(defalias 'vc-bzr-diff-tree 'vc-bzr-diff)

(defun vc-bzr-dir-state (dir)
  (with-temp-buffer
    (cd dir)
    ;; First get a list of all the bzr-controlled files and set
    ;; default state up-to-date.
    (vc-bzr-command "inventory" t 0 nil "--kind" "file")
    (goto-char 1)
    (while (not (eobp))
      (vc-file-setprop (expand-file-name
			(buffer-substring (line-beginning-position)
					  (line-end-position)))
		       'vc-state 'up-to-date)
      (forward-line))
    (erase-buffer)
    ;; Now set the status of non-up-to-date files (maybe inluding ones
    ;; from higher-level diretories).
    (vc-bzr-command "status" t 0 nil)
    (goto-char 1)
    (when (re-search-forward "^modified:" nil t)
      (while (and (= 0 (forward-line)) (looking-at " +\\(.+\\)$"))
	(let ((file (expand-file-name (match-string 1))))
	  (vc-file-setprop file 'vc-state 'edited))))
    (dolist (type '("added" "renamed" "kind changed"))
      (goto-char 1)
      (when (re-search-forward (concat "^" type ":") nil t)
	(while (and (= 0 (forward-line)) (looking-at " +\\(.+\\)$"))
	  (let ((file (expand-file-name (match-string 1))))
	    (vc-file-setprop file 'vc-state 'edited)
	    (vc-file-setprop file 'bzr-state (intern type))))))
    (goto-char 1)
    (when (re-search-forward " conflict in \\(.+\\)$" nil t)
      (while (and (= 0 (forward-line)) (looking-at " +\\(.+\\)$"))
	(let ((file (expand-file-name (match-string 1))))
	  (vc-file-setprop file 'vc-state 'edited)
	  (vc-file-setprop file 'bzr-state 'conflict))))))

(defun vc-bzr-dired-state-info (file)
  "VC bzr backend for `dired-state-info'."
  (when (eq 'edited (vc-state file))
    (let ((state (vc-file-getprop file 'bzr-state)))
      (if (memq (vc-file-getprop file 'bzr-state)
		'(added conflict kind\ changed renamed))
	  (format "(%S)" state)
	"(modified)"))))

;; Fixme: vc-{next,previous}-version need fixing in vc.el to deal with
;; straight integer versions.

(defun vc-bzr-delete-file (file)
  "Delete FILE and delete it in the bzr repository."
  (condition-case ()
      (delete-file file)
    (file-error nil))
  (vc-bzr-command "remove" nil 0 file))

(defun vc-bzr-rename-file (old new)
  "Rename file from OLD to NEW using `bzr mv'."
  (vc-bzr-command "mv" nil 0 new old))

(defvar vc-bzr-annotation-table nil
  "Internal use.")
(make-variable-buffer-local 'vc-bzr-annotation-table)

(defun vc-bzr-annotate-command (file buffer &optional version)
  "Prepare BUFFER for `vc-annotate' on FILE.
Each line is tagged with the revision number, which has a `help-echo'
property containing author and date information."
  (apply #'vc-bzr-command "annotate" buffer 0 file "--long" "--all"
	 (if version (list "-r" version)))
  (with-current-buffer buffer
    ;; Store the tags for the annotated source lines in a hash table
    ;; to allow saving space by sharing the text properties.
    (setq vc-bzr-annotation-table (make-hash-table :test 'equal))
    (goto-char (point-min))
    (while (re-search-forward "^\\( *[0-9.]+\\) +\\([^ ].*[^ ]\\) +\\([0-9]\\{8\\}\\) |"
			      nil t)
      (let* ((rev (match-string 1))
	     (author-start (match-beginning 2))
	     (author (match-string 2))
	     (date (match-string 3))
	     (date-end (match-end 3))
	     (key (match-string 0))
	     (props (gethash key vc-bzr-annotation-table)))
	(unless props
	  (save-match-data
	    (if (string-match "\\([^ ].*[^ ]\\) *\\'" author)
		(setq author (match-string 1 author))))
	  (setq props (list 'help-echo (concat "Author: " author
					       ", date: " date)
			    'mouse-face 'highlight))
	  (puthash key props vc-bzr-annotation-table))
	(add-text-properties (line-beginning-position) date-end props)
	(kill-region author-start date-end)))
    (unless window-system
      (add-hook (make-local-hook 'post-command-hook)
		(lambda ()
		  (let ((help-echo (get-text-property (point) 'help-echo)))
		    (if help-echo (message "%s" help-echo))))))))

;; Definition from Emacs 22
(unless (fboundp 'vc-annotate-convert-time)
(defun vc-annotate-convert-time (time)
  "Convert a time value to a floating-point number of days.
The argument TIME is a list as returned by `current-time' or
`encode-time', only the first two elements of that list are considered."
  (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600)))

(defun vc-bzr-annotate-time ()
  (when (re-search-forward "^ *[0-9]+ +|" nil t)
    (let ((prop (get-text-property (line-beginning-position) 'help-echo)))
      (string-match "[0-9]+\\'" prop)
      (vc-annotate-convert-time
       (encode-time 0 0 0
		    (string-to-number (substring (match-string 0 prop) 6 8))
		    (string-to-number (substring (match-string 0 prop) 4 6))
		    (string-to-number (substring (match-string 0 prop) 0 4))
		    )))))

(defun vc-bzr-annotate-extract-revision-at-line ()
  "Return revision for current line of annoation buffer, or nil.
Return nil if current line isn't annotated."
  (save-excursion
    (beginning-of-line)
    (if (looking-at "\\([0-9]+\\) +| ")
	(match-string-no-properties 1))))

;; Not needed for Emacs 22
(defun vc-bzr-annotate-difference (point)
  (let ((next-time (vc-bzr-annotate-time)))
    (if next-time
	(- (vc-annotate-convert-time (current-time)) next-time))))

;; In case of just `(load "vc-bzr")', but that's probably the wrong
;; way to do it.
(add-to-list 'vc-handled-backends 'BZR)

(eval-after-load "vc"
  '(add-to-list 'vc-directory-exclusion-list ".bzr" t))

(defconst vc-bzr-unload-hook
  (lambda ()
    (setq vc-handled-backends (delq 'BZR vc-handled-backends))
    (remove-hook 'vc-post-command-functions 'vc-bzr-post-command-function)))

(provide 'vc-bzr)
;;; vc-bzr.el ends here