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

;; Copyright (C) 2005 Bryan O'Sullivan

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

;; mercurial.el is free software; you can redistribute it and/or

;; modify it under the terms of version 2 of the GNU General Public

;; License as published by the Free Software Foundation.

;; mercurial.el 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 mercurial.el, GNU Emacs, or XEmacs; see the file COPYING

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

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

;;; Commentary:

;; mercurial.el builds upon Emacs's VC mode to provide flexible

;; integration with the Mercurial distributed SCM tool.

;; To get going as quickly as possible, load mercurial.el into Emacs and

;; 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 not work as

;; well under GNU Emacs (albeit tested under 21.4).  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 'executable)

(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.

(defgroup mercurial nil

  "Mercurial distributed SCM."

  :group 'tools)

(defcustom hg-binary

    (or (executable-find "hg")

	(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)

  :group 'mercurial)

(defcustom hg-mode-hook nil

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

  :type 'sexp

  :group 'mercurial)

(defcustom hg-commit-mode-hook nil

  "Hook run when a buffer is created to prepare a commit."

  :type 'sexp

  :group 'mercurial)

(defcustom hg-pre-commit-hook nil

  "Hook run before a commit is performed.

If you want to prevent the commit from proceeding, raise an error."

  :type 'sexp

  :group 'mercurial)

(defcustom hg-log-mode-hook nil

  "Hook run after a buffer is filled with log information."

  :type 'sexp

  :group 'mercurial)

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

  "The global prefix for Mercurial keymap bindings."

  :type 'sexp

  :group 'mercurial)

(defcustom hg-commit-allow-empty-message nil

  "Whether to allow changes to be committed with empty descriptions."

  :type 'boolean

  :group 'mercurial)

(defcustom hg-commit-allow-empty-file-list nil

  "Whether to allow changes to be committed without any modified files."

  :type 'boolean

  :group 'mercurial)

(defcustom hg-rev-completion-limit 100

  "The maximum number of revisions that hg-read-rev will offer to complete.

This affects memory usage and performance when prompting for revisions

in a repository with a lot of history."

  :type 'integer

  :group 'mercurial)

(defcustom hg-log-limit 50

  "The maximum number of revisions that hg-log will display."

  :type 'integer

  :group 'mercurial)

(defcustom hg-update-modeline t

  "Whether to update the modeline with the status of a file after every save.

Set this to nil on platforms with poor process management, such as Windows."

  :type 'boolean

  :group 'mercurial)

(defcustom hg-incoming-repository "default"

  "The repository from which changes are pulled from by default.

This should be a symbolic repository name, since it is used for all

repository-related commands."

  :type 'string

  :group 'mercurial)

(defcustom hg-outgoing-repository "default-push"

  "The repository to which changes are pushed to by default.

This should be a symbolic repository name, since it is used for all

repository-related commands."

  :type 'string

  :group 'mercurial)

;;; 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?")

(make-variable-buffer-local 'hg-mode)

(put 'hg-mode 'permanent-local t)

(defvar hg-status nil)

(make-variable-buffer-local 'hg-status)

(put 'hg-status 'permanent-local t)

(defvar hg-prev-buffer nil)

(make-variable-buffer-local 'hg-prev-buffer)

(put 'hg-prev-buffer 'permanent-local t)

(defvar hg-root nil)

(make-variable-buffer-local 'hg-root)

(put 'hg-root 'permanent-local t)

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

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

(defvar hg-file-history nil)

(defvar hg-repo-history nil)

(defvar hg-rev-history nil)

;;; Random constants.

(defconst hg-commit-message-start

  "--- Enter your commit message.  Type `C-c C-c' to commit. ---\n")

(defconst hg-commit-message-end

  "--- Files in bold will be committed.  Click to toggle selection. ---\n")

;;; hg-mode keymap.

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

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

(defvar hg-prefix-map

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

    (if (functionp 'set-keymap-name)

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

    map)

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

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

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

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

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

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

(define-key hg-prefix-map "n" 'hg-commit-start)

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

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

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

(add-minor-mode 'hg-mode 'hg-mode hg-mode-map)

;;; Global keymap.

(global-set-key "\C-xvi" 'hg-add)

(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-repo)

(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-start)

(define-key hg-global-map "f" 'hg-forget)

(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-repo)

(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))))

    (if (functionp 'set-keymap-name)

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

    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)

;;; Commit mode keymaps.

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

(define-key hg-commit-mode-map "\C-c\C-c" 'hg-commit-finish)

(define-key hg-commit-mode-map "\C-c\C-k" 'hg-commit-kill)

(define-key hg-commit-mode-map "\C-xv=" 'hg-diff-repo)

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

(define-key hg-commit-mode-file-map

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

  'hg-commit-mouse-clicked)

(define-key hg-commit-mode-file-map " " 'hg-commit-toggle-file)

(define-key hg-commit-mode-file-map "\r" 'hg-commit-toggle-file)

;;; Convenience functions.

(defsubst hg-binary ()

  (if hg-binary

      hg-binary

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

(defsubst 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)))

(defsubst hg-strip (str)

  "Strip leading and trailing blank lines from a string."

  (hg-replace-in-string (hg-replace-in-string str "[\r\n][ \t\r\n]*\\'" "")

			"\\`[ \t\r\n]*[\r\n]" ""))

(defsubst 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-sync-buffers (path)

  "Sync buffers visiting PATH with their on-disk copies.

If PATH is not being visited, but is under the repository root, sync

all buffers visiting files in the repository."

  (let ((buf (find-buffer-visiting path)))

    (if buf

	(with-current-buffer buf

	  (vc-buffer-sync))

      (hg-do-across-repo path

	(vc-buffer-sync)))))

(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")))))

(defsubst hg-event-point (event)

  "Return the character position of the mouse event EVENT."

  (if hg-running-xemacs

      (event-point event)

    (posn-point (event-start event))))

(defsubst hg-event-window (event)

  "Return the window over which mouse event EVENT occurred."

  (if hg-running-xemacs

      (event-window event)

    (posn-window (event-start event))))

(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")

  (select-window (hg-event-window event))

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

(unless (fboundp 'view-minor-mode)

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

    (view-mode)))

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

  "Portable wrapper around abbreviate-file-name."

  (if hg-running-xemacs

      (abbreviate-file-name file t)

    (abbreviate-file-name file)))

(defun hg-read-file-name (&optional prompt default)

  "Read a file or directory name, or a pattern, to use with a command."

  (save-excursion

    (while hg-prev-buffer

      (set-buffer hg-prev-buffer))

    (let ((path (or default (buffer-file-name))))

      (if (or (not path) current-prefix-arg)

	  (expand-file-name

	   (read-file-name (format "File, directory or pattern%s: "

				   (or prompt ""))

			   (and path (file-name-directory path))

			   nil nil

			   (and path (file-name-nondirectory path))

			   'hg-file-history))

	path))))

(defun hg-read-config ()

  "Return an alist of (key . value) pairs of Mercurial config data.

Each key is of the form (section . name)."

  (let (items)

    (dolist (line (split-string (hg-chomp (hg-run0 "debugconfig")) "\n") items)

      (string-match "^\\([^=]*\\)=\\(.*\\)" line)

      (let* ((left (substring line (match-beginning 1) (match-end 1)))

	     (right (substring line (match-beginning 2) (match-end 2)))

	     (key (split-string left "\\."))

	     (value (hg-replace-in-string right "\\\\n" "\n" t)))

	(setq items (cons (cons (cons (car key) (cadr key)) value) items))))))

(defun hg-config-section (section config)

  "Return an alist of (name . value) pairs for SECTION of CONFIG."

  (let (items)

    (dolist (item config items)

      (when (equal (caar item) section)

	(setq items (cons (cons (cdar item) (cdr item)) items))))))

(defun hg-string-starts-with (sub str)

  "Indicate whether string STR starts with the substring or character SUB."

  (if (not (stringp sub))

      (and (> (length str) 0) (equal (elt str 0) sub))

    (let ((sub-len (length sub)))

      (and (<= sub-len (length str))

	   (string= sub (substring str 0 sub-len))))))

(defun hg-complete-repo (string predicate all)

  "Attempt to complete a repository name.

We complete on either symbolic names from Mercurial's config or real

directory names from the file system.  We do not penalise URLs."

  (or (if all

	  (all-completions string hg-repo-completion-table predicate)

	(try-completion string hg-repo-completion-table predicate))

      (let* ((str (expand-file-name string))

	     (dir (file-name-directory str))

	     (file (file-name-nondirectory str)))

	(if all

	    (let (completions)

	      (dolist (name (delete "./" (file-name-all-completions file dir))

			    completions)

		(let ((path (concat dir name)))

		  (when (file-directory-p path)

		    (setq completions (cons name completions))))))

	  (let ((comp (file-name-completion file dir)))

	    (if comp

		(hg-abbrev-file-name (concat dir comp))))))))

(defun hg-read-repo-name (&optional prompt initial-contents default)

  "Read the location of a repository."

  (save-excursion

    (while hg-prev-buffer

      (set-buffer hg-prev-buffer))

    (let (hg-repo-completion-table)

      (if current-prefix-arg

	  (progn

	    (dolist (path (hg-config-section "paths" (hg-read-config)))

	      (setq hg-repo-completion-table

		    (cons (cons (car path) t) hg-repo-completion-table))

	      (unless (hg-string-starts-with directory-sep-char (cdr path))

		(setq hg-repo-completion-table

		      (cons (cons (cdr path) t) hg-repo-completion-table))))

	    (completing-read (format "Repository%s: " (or prompt ""))

			     'hg-complete-repo

			     nil

			     nil

			     initial-contents

			     'hg-repo-history

			     default))

	default))))

(defun hg-read-rev (&optional prompt default)

  "Read a revision or tag, offering completions."

  (save-excursion

    (while hg-prev-buffer

      (set-buffer hg-prev-buffer))

    (let ((rev (or default "tip")))

      (if current-prefix-arg

	  (let ((revs (split-string

		       (hg-chomp

			(hg-run0 "-q" "log" "-r"

				 (format "-%d:tip" hg-rev-completion-limit)))

		       "[\n:]")))

	    (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n"))

	      (setq revs (cons (car (split-string line "\\s-")) revs)))

	    (completing-read (format "Revision%s (%s): "

				     (or prompt "")

				     (or default "tip"))

			     (map 'list 'cons revs revs)

			     nil

			     nil

			     nil

			     'hg-rev-history

			     (or default "tip")))

	rev))))

(defmacro hg-do-across-repo (path &rest body)

  (let ((root-name (gensym "root-"))

	(buf-name (gensym "buf-")))

    `(let ((,root-name (hg-root ,path)))

       (save-excursion

	 (dolist (,buf-name (buffer-list))

	   (set-buffer ,buf-name)

	   (when (and hg-status (equal (hg-root buffer-file-name) ,root-name))

	     ,@body))))))

(put 'hg-do-across-repo 'lisp-indent-function 1)