;;; mercurial.el --- Emacs support for the Mercurial distributed SCM

;; Copyright (C) 2005 Bryan O'Sullivan

;; Author: Bryan O'Sullivan <bos@serpentine.com>

;; $Id$

;; 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

;; (`C-h C-l').  If not, write to the Free Software Foundation, Inc.,

;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;; Commentary:

;; This mode builds upon Emacs's VC mode to provide flexible

;; integration with the Mercurial distributed SCM tool.

;; type `C-c h h'; this runs hg-help-overview, which prints a helpful

;; usage overview.

;; Much of the inspiration for mercurial.el comes from Rajesh

;; Vaidheeswarran's excellent p4.el, which does an admirably thorough

;; job for the commercial Perforce SCM product.  In fact, substantial

;; chunks of code are adapted from p4.el.

;; This code has been developed under XEmacs 21.5, and may will not

;; work as well under GNU Emacs (albeit tested under 21.2).  Patches

;; to enhance the portability of this code, fix bugs, and add features

;; are most welcome.  You can clone a Mercurial repository for this

;; package from http://www.serpentine.com/hg/hg-emacs

;; Please send problem reports and suggestions to bos@serpentine.com.

;;; Code:

(require 'advice)

(require 'cl)

(require 'diff-mode)

(require 'easymenu)

(require 'vc)

;;; XEmacs has view-less, while GNU Emacs has view.  Joy.

(condition-case nil

    (require 'view-less)

  (error nil))

(condition-case nil

    (require 'view)

  (error nil))

;;; Variables accessible through the custom system.

  "Mercurial distributed SCM."

  :group 'tools)

(defcustom hg-binary

  (dolist (path '("~/bin/hg"

		  "/usr/bin/hg"

		  "/usr/local/bin/hg"))

    (when (file-executable-p path)

      (return path)))

  "The path to Mercurial's hg executable."

  :type '(file :must-match t)

(defcustom hg-mode-hook nil

  "Hook run when a buffer enters hg-mode."

  :type 'sexp

(defcustom hg-global-prefix "\C-ch"

  "The global prefix for Mercurial keymap bindings."

  :type 'sexp

;;; Other variables.

(defconst hg-running-xemacs (string-match "XEmacs" emacs-version)

  "Is mercurial.el running under XEmacs?")

(defvar hg-mode nil

  "Is this file managed by Mercurial?")

(defvar hg-output-buffer-name "*Hg*"

  "The name to use for Mercurial output buffers.")

;;; hg-mode keymap.

(defvar hg-prefix-map

  (let ((map (copy-keymap vc-prefix-map)))

    (set-keymap-name map 'hg-prefix-map)

    map)

  "This keymap overrides some default vc-mode bindings.")

(fset 'hg-prefix-map hg-prefix-map)

(define-key hg-prefix-map "c" 'hg-undo)

(define-key hg-prefix-map "g" 'hg-annotate)

;; (define-key hg-prefix-map "r" 'hg-update)

(define-key hg-prefix-map "u" 'hg-revert-file)

(define-key hg-prefix-map "~" 'hg-version-other-window)

(defvar hg-mode-map (make-sparse-keymap))

(define-key hg-mode-map "\C-xv" 'hg-prefix-map)

;;; Global keymap.

(defvar hg-global-map (make-sparse-keymap))

(fset 'hg-global-map hg-global-map)

(global-set-key hg-global-prefix 'hg-global-map)

(define-key hg-global-map "," 'hg-incoming)

(define-key hg-global-map "." 'hg-outgoing)

(define-key hg-global-map "<" 'hg-pull)

(define-key hg-global-map "=" 'hg-diff)

(define-key hg-global-map ">" 'hg-push)

(define-key hg-global-map "?" 'hg-help-overview)

(define-key hg-global-map "A" 'hg-addremove)

(define-key hg-global-map "U" 'hg-revert)

(define-key hg-global-map "a" 'hg-add)

(define-key hg-global-map "c" 'hg-commit)

(define-key hg-global-map "h" 'hg-help-overview)

(define-key hg-global-map "i" 'hg-init)

(define-key hg-global-map "l" 'hg-log)

(define-key hg-global-map "r" 'hg-root)

(define-key hg-global-map "s" 'hg-status)

(define-key hg-global-map "u" 'hg-update)

;;; View mode keymap.

(defvar hg-view-mode-map

  (let ((map (copy-keymap (if (boundp 'view-minor-mode-map)

			      view-minor-mode-map

			    view-mode-map))))

    (set-keymap-name map 'hg-view-mode-map)

    map))

(fset 'hg-view-mode-map hg-view-mode-map)

(define-key hg-view-mode-map

  (if hg-running-xemacs [button2] [mouse-2])

  'hg-buffer-mouse-clicked)

;;; Convenience functions.

(defun hg-binary ()

  (if hg-binary

      hg-binary

    (error "No `hg' executable found!")))

(defun hg-replace-in-string (str regexp newtext &optional literal)

  "Replace all matches in STR for REGEXP with NEWTEXT string.

Return the new string.  Optional LITERAL non-nil means do a literal

replacement.

This function bridges yet another pointless impedance gap between

XEmacs and GNU Emacs."

  (if (fboundp 'replace-in-string)

      (replace-in-string str regexp newtext literal)

    (replace-regexp-in-string regexp newtext str nil literal)))

(defun hg-chomp (str)

  "Strip trailing newlines from a string."

  (hg-replace-in-string str "[\r\n]+$" ""))

(defun hg-run-command (command &rest args)

  "Run the shell command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT).

The list ARGS contains a list of arguments to pass to the command."

  (let* (exit-code

	 (output

	  (with-output-to-string

	    (with-current-buffer

		standard-output

	      (setq exit-code

		    (apply 'call-process command nil t nil args))))))

    (cons exit-code output)))

(defun hg-run (command &rest args)

  "Run the Mercurial command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT)."

  (apply 'hg-run-command (hg-binary) command args))

(defun hg-run0 (command &rest args)

  "Run the Mercurial command COMMAND, returning its output.

If the command does not exit with a zero status code, raise an error."

  (let ((res (apply 'hg-run-command (hg-binary) command args)))

    (if (not (eq (car res) 0))

	(error "Mercurial command failed %s - exit code %s"

	       (cons command args)

	       (car res))

      (cdr res))))

(defun hg-buffer-commands (pnt)

  "Use the properties of a character to do something sensible."

  (interactive "d")

  (let ((rev (get-char-property pnt 'rev))

	(file (get-char-property pnt 'file))

	(date (get-char-property pnt 'date))

	(user (get-char-property pnt 'user))

	(host (get-char-property pnt 'host))

	(prev-buf (current-buffer)))

    (cond

     (file

      (find-file-other-window file))

     (rev

      (hg-diff hg-view-file-name rev rev prev-buf))

     ((message "I don't know how to do that yet")))))

(defun hg-buffer-mouse-clicked (event)

  "Translate the mouse clicks in a HG log buffer to character events.

These are then handed off to `hg-buffer-commands'.

Handle frickin' frackin' gratuitous event-related incompatibilities."

  (interactive "e")

  (if hg-running-xemacs

      (progn

	(select-window (event-window event))

	(hg-buffer-commands (event-point event)))

    (select-window (posn-window (event-end event)))

    (hg-buffer-commands (posn-point (event-start event)))))

(unless (fboundp 'view-minor-mode)

  (defun view-minor-mode (prev-buffer exit-func)

    (view-mode)))

(defun hg-abbrev-file-name (file)

  (if hg-running-xemacs

      (abbreviate-file-name file t)

    (abbreviate-file-name file)))

;;; View mode bits.

(defun hg-exit-view-mode (buf)

  "Exit from hg-view-mode.

We delete the current window if entering hg-view-mode split the

current frame."

  (when (and (eq buf (current-buffer))

	     (> (length (window-list)) 1))

    (delete-window))

  (when (buffer-live-p buf)

    (kill-buffer buf)))

(defun hg-view-mode (prev-buffer &optional file-name)

  (goto-char (point-min))

  (set-buffer-modified-p nil)

  (toggle-read-only t)

  (view-minor-mode prev-buffer 'hg-exit-view-mode)

  (use-local-map hg-view-mode-map)

  (setq truncate-lines t)

  (when file-name

    (set (make-local-variable 'hg-view-file-name)

	 (hg-abbrev-file-name file-name))))

(defmacro hg-view-output (args &rest body)

ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is

the name of the buffer to create, and FILE is the name of the file

being viewed."

  (let ((prev-buf (gensym "prev-buf-"))

	(v-b-name (car args))

	(v-m-rest (cdr args)))

    `(let ((view-buf-name ,v-b-name)

	   (,prev-buf (current-buffer)))

       (get-buffer-create view-buf-name)

       (kill-buffer view-buf-name)

       (save-excursion

	 ,@body)

(put 'hg-view-output 'lisp-indent-function 1)

;;; User interface functions.

(defun hg-help-overview ()

  "This is an overview of the Mercurial SCM mode for Emacs.

You can find the source code, license (GPL v2), and credits for this

code by typing `M-x find-library mercurial RET'.

The Mercurial mode user interface is based on that of the older VC

mode, so if you're already familiar with VC, the same keybindings and

functions will generally work.