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

;; Copyright (C) 2005, 2006 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:

(eval-when-compile (require 'cl))

(require 'diff-mode)

(require 'easymenu)

(require 'executable)

(require 'vc)

(defmacro hg-feature-cond (&rest clauses)

  "Test CLAUSES for feature at compile time.

Each clause is (FEATURE BODY...)."

  (dolist (x clauses)

    (let ((feature (car x))

	  (body (cdr x)))

      (when (or (eq feature t)

		(featurep feature))

	(return (cons 'progn body))))))

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

(hg-feature-cond

 (xemacs (require 'view-less))

 (t (require 'view)))

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

(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-view-mode nil)

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

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

(defvar hg-view-file-name nil)

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

(put 'hg-view-file-name '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)

(defvar hg-repo-completion-table nil)	; shut up warnings

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

(defconst hg-state-alist

  '((?M . modified)

    (?A . added)

    (?R . removed)

    (?! . deleted)

    (?C . normal)

    (?I . ignored)

    (?? . nil)))

;;; hg-mode keymap.

(defvar hg-prefix-map

  (let ((map (make-sparse-keymap)))

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

    (set-keymap-parent map vc-prefix-map)

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

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

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

    (define-key map "i" 'hg-add)

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

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

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

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

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

    map)

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

(defvar hg-mode-map

  (let ((map (make-sparse-keymap)))

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

    map))

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

;;; Global keymap.

(defvar hg-global-map

  (let ((map (make-sparse-keymap)))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    map))

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

;;; View mode keymap.

(defvar hg-view-mode-map

  (let ((map (make-sparse-keymap)))

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

    (define-key map (hg-feature-cond (xemacs [button2])

				     (t [mouse-2]))

      'hg-buffer-mouse-clicked)

    map))

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

;;; Commit mode keymaps.

(defvar hg-commit-mode-map

  (let ((map (make-sparse-keymap)))

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

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

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

    map))

(defvar hg-commit-mode-file-map

  (let ((map (make-sparse-keymap)))

    (define-key map (hg-feature-cond (xemacs [button2])

				     (t [mouse-2]))

      'hg-commit-mouse-clicked)

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

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

    map))

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

  (hg-feature-cond

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

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

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

  (let ((root-name (make-symbol "root-"))

	(buf-name (make-symbol "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)

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

    (cond

     (file

      (find-file-other-window file))

     (rev

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

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

(defsubst hg-event-point (event)

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

  (hg-feature-cond (xemacs (event-point event))

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

(defsubst hg-event-window (event)

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

  (hg-feature-cond (xemacs (event-window event))

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

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

  "Portable wrapper around abbreviate-file-name."

  (hg-feature-cond (xemacs (abbreviate-file-name file t))

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

                    (expand-file-name default-directory))))

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

          (expand-file-name

           (eval (list* '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-feature-cond

			 (xemacs (cons (quote 'hg-file-history) nil))

			 (t nil)))))

        path))))

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

  "Read a integer value."

  (save-excursion

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

        (string-to-number

         (eval (list* 'read-string

                      (or prompt "")

                      (if default (cons (format "%d" default) nil) nil))))

      default)))

(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 (hg-feature-cond

					      (xemacs directory-sep-char)

					      (t ?/))

					     (cdr path))

		(setq hg-repo-completion-table

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