In-progress Emacs snapshot.

.hgignore

@@ -1,3 +1,4
+\.elc$
 \.orig$
 \.rej$
 ~$

contrib/mercurial.el

@@ -6,17 +6,17
 
 ;; $Id$
 
-;; mercurial.el ("this file") 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 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.
 
-;; This file is distributed in the hope that it will be useful, but
+;; 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 this file, GNU Emacs, or XEmacs; see the file COPYING
+;; 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.
 
@@ -25,7 +25,7
 ;; This mode builds upon Emacs's VC mode to provide flexible
 ;; integration with the Mercurial distributed SCM tool.
 
-;; To get going as quickly as possible, load this file into Emacs and
+;; 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.
 
@@ -64,7 +64,7
 
 ;;; Variables accessible through the custom system.
 
-(defgroup hg nil
+(defgroup mercurial nil
   "Mercurial distributed SCM."
   :group 'tools)
 
@@ -76,17 +76,29
       (return path)))
   "The path to Mercurial's hg executable."
   :type '(file :must-match t)
-  :group 'hg)
+  :group 'mercurial)
 
 (defcustom hg-mode-hook nil
   "Hook run when a buffer enters hg-mode."
   :type 'sexp
-  :group 'hg)
+  :group 'mercurial)
 
 (defcustom hg-global-prefix "\C-ch"
   "The global prefix for Mercurial keymap bindings."
   :type 'sexp
-  :group 'hg)
+  :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)
 
 
 ;;; Other variables.
@@ -96,11 +108,18
 
 (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-output-buffer-name "*Hg*"
   "The name to use for Mercurial output buffers.")
 
-(defvar hg-file-name-history nil)
+(defvar hg-file-history nil)
+(defvar hg-rev-history nil)
 
 
 ;;; hg-mode keymap.
@@ -111,10 +130,11
     map)
   "This keymap overrides some default vc-mode bindings.")
 (fset 'hg-prefix-map hg-prefix-map)
-(define-key hg-prefix-map "=" 'hg-diff-file)
+(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-file)
+(define-key hg-prefix-map "l" 'hg-log)
+(define-key hg-prefix-map "n" 'hg-commit-file)
 ;; (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)
@@ -122,10 +142,12
 (defvar hg-mode-map (make-sparse-keymap))
 (define-key hg-mode-map "\C-xv" 'hg-prefix-map)
 
+(add-minor-mode 'hg-mode 'hg-mode hg-mode-map)
+
 
 ;;; Global keymap.
 
-(global-set-key "\C-xvi" 'hg-add-file)
+(global-set-key "\C-xvi" 'hg-add)
 
 (defvar hg-global-map (make-sparse-keymap))
 (fset 'hg-global-map hg-global-map)
@@ -140,6 +162,7
 (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 "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)
@@ -248,6 +271,41 Handle frickin' frackin' gratuitous even
       (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."
+  (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-rev (&optional prompt default)
+  "Read a revision or tag, offering completions."
+  (let ((rev (or default "tip")))
+    (if (or (not rev) current-prefix-arg)
+	(let ((revs (split-string (hg-chomp
+				   (hg-run0 "-q" "log" "-r"
+					    (format "-%d"
+						    hg-rev-completion-limit)
+					    "-r" "tip"))
+				  "[\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)))
 
 ;;; View mode bits.
 
@@ -272,8 +330,27 current frame."
     (set (make-local-variable 'hg-view-file-name)
 	 (hg-abbrev-file-name file-name))))
   
+(defun hg-file-status (file)
+  "Return status of FILE, or nil if FILE does not exist or is unmanaged."
+  (let* ((s (hg-run "status" file))
+	 (exit (car s))
+	 (output (cdr s)))
+    (if (= exit 0)
+	(let ((state (assoc (substring output 0 (min (length output) 2))
+			    '(("M " . modified)
+			      ("A " . added)
+			      ("R " . removed)))))
+	  (if state
+	      (cdr state)
+	    'normal)))))
+
+(defun hg-tip ()
+  (split-string (hg-chomp (hg-run0 "-q" "tip")) ":"))
+
 (defmacro hg-view-output (args &rest body)
-  "Execute BODY in a clean buffer, then switch that buffer to view-mode.
+  "Execute BODY in a clean buffer, then quickly display that buffer.
+If the buffer contains one line, its contents are displayed in the
+minibuffer.  Otherwise, the buffer is displayed in view-mode.
 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."
@@ -284,12 +361,52 being viewed."
 	   (,prev-buf (current-buffer)))
        (get-buffer-create view-buf-name)
        (kill-buffer view-buf-name)
-       (pop-to-buffer view-buf-name)
+       (get-buffer-create view-buf-name)
+       (set-buffer view-buf-name)
        (save-excursion
 	 ,@body)
-       (hg-view-mode ,prev-buf ,@v-m-rest))))
+       (case (count-lines (point-min) (point-max))
+	 ((0)
+	  (kill-buffer view-buf-name)
+	  (message "(No output)"))
+	 ((1)
+	  (let ((msg (hg-chomp (buffer-substring (point-min) (point-max)))))
+	    (kill-buffer view-buf-name)
+	    (message "%s" msg)))
+	 (t
+	  (pop-to-buffer view-buf-name)
+	  (hg-view-mode ,prev-buf ,@v-m-rest))))))
 
 (put 'hg-view-output 'lisp-indent-function 1)
+
+;;; Hooks.
+
+(defun hg-mode-line ()
+  (when (hg-root)
+    (let ((status (hg-file-status buffer-file-name)))
+      (setq hg-status status
+	    hg-mode (and status (concat " Hg:"
+					(car (hg-tip))
+					(cdr (assq status
+						   '((normal . "")
+						     (removed . "r")
+						     (added . "a")
+						     (modified . "m")))))))
+      status)))
+
+(defun hg-find-file-hook ()
+  (when (hg-mode-line)
+    (run-hooks 'hg-mode-hook)))
+
+(add-hook 'find-file-hooks 'hg-find-file-hook)
+
+(defun hg-after-save-hook ()
+  (let ((old-status hg-status))
+    (hg-mode-line)
+    (if (and (not old-status) hg-status)
+	(run-hooks 'hg-mode-hook))))
+
+(add-hook 'after-save-hook 'hg-after-save-hook)
 
 
 ;;; User interface functions.
@@ -317,13 +434,13 SCM Task G/
 --------                              ---  -----------  ------------
 Help overview (what you are reading)  G    C-c h h      hg-help-overview
 
-Tell Mercurial to manage a file       G    C-x v i      hg-add-file
-Commit changes to current file only   L    C-x C-q      vc-toggle-read-only
+Tell Mercurial to manage a file       G    C-c h a      hg-add
+Commit changes to current file only   L    C-x v n      hg-commit
 Undo changes to file since commit     L    C-x v u      hg-revert-file
 
-Diff file vs last checkin             L    C-x v =      hg-diff-file
+Diff file vs last checkin             L    C-x v =      hg-diff
 
-View file change history              L    C-x v l      hg-log-file
+View file change history              L    C-x v l      hg-log
 View annotated file                   L    C-x v a      hg-annotate
 
 Diff repo vs last checkin             G    C-c h =      hg-diff
@@ -342,13 +459,15 Push changes G
   (hg-view-output ("Mercurial Help Overview")
     (insert (documentation 'hg-help-overview))))
 
-(defun hg-add ()
-  (interactive)
-  (error "not implemented"))
-
-(defun hg-add-file ()
-  (interactive)
-  (error "not implemented"))
+(defun hg-add (path)
+  (interactive (list (hg-read-file-name " to add")))
+  (let ((buf (current-buffer))
+	(update (equal buffer-file-name path)))
+    (hg-view-output (hg-output-buffer-name)
+      (apply 'call-process (hg-binary) nil t nil (list "add" path)))
+    (when update
+      (with-current-buffer buf
+	(hg-mode-line)))))
 
 (defun hg-addremove ()
   (interactive)
@@ -362,13 +481,31 Push changes G
   (interactive)
   (error "not implemented"))
 
-(defun hg-diff ()
-  (interactive)
-  (error "not implemented"))
+(defun hg-diff (path &optional rev1 rev2)
+  (interactive (list (hg-read-file-name " to diff")
+		     (hg-read-rev " to start with")
+		     (let ((rev2 (hg-read-rev " to end with" 'working-dir)))
+		       (and (not (eq rev2 'working-dir)) rev2))))
+  (let ((a-path (hg-abbrev-file-name path)))
+    (hg-view-output ((if (equal rev1 rev2)
+			 (format "Mercurial: Rev %s of %s" rev1 a-path)
+		       (format "Mercurial: Rev %s to %s of %s"
+			       rev1 (or rev2 "Current") a-path)))
+      (if rev2
+	  (call-process (hg-binary) nil t nil "diff" "-r" rev1 "-r" rev2 path)
+	(call-process (hg-binary) nil t nil "diff" "-r" rev1 path))
+      (diff-mode)
+      (font-lock-fontify-buffer))))
 
-(defun hg-diff-file ()
-  (interactive)
-  (error "not implemented"))
+(defun hg-forget (path)
+  (interactive (list (hg-read-file-name " to forget")))
+  (let ((buf (current-buffer))
+	(update (equal buffer-file-name path)))
+    (hg-view-output (hg-output-buffer-name)
+      (apply 'call-process (hg-binary) nil t nil (list "forget" path)))
+    (when update
+      (with-current-buffer buf
+	(hg-mode-line)))))
 
 (defun hg-incoming ()
   (interactive)
@@ -378,13 +515,20 Push changes G
   (interactive)
   (error "not implemented"))
 
-(defun hg-log-file ()
-  (interactive)
-  (error "not implemented"))
-
-(defun hg-log ()
-  (interactive)
-  (error "not implemented"))
+(defun hg-log (path &optional rev1 rev2)
+  (interactive (list (hg-read-file-name " to log")
+		     (hg-read-rev " to start with" "-1")
+		     (hg-read-rev " to end with" (format "-%d" hg-log-limit))))
+  (message "log %s %s" rev1 rev2)
+  (sit-for 1)
+  (let ((a-path (hg-abbrev-file-name path)))
+    (hg-view-output ((if (equal rev1 rev2)
+			 (format "Mercurial: Rev %s of %s" rev1 a-path)
+		       (format "Mercurial: Rev %s to %s of %s"
+			       rev1 (or rev2 "Current") a-path)))
+      (call-process (hg-binary) nil t nil "log" "-r" rev1 "-r" rev2 path)
+      (diff-mode)
+      (font-lock-fontify-buffer))))
 
 (defun hg-outgoing ()
   (interactive)
@@ -407,13 +551,9 Push changes G
   (error "not implemented"))
 
 (defun hg-root (&optional path)
-  (interactive)
-  (unless path
-    (setq path (if (and (interactive-p) current-prefix-arg)
-		   (expand-file-name (read-file-name "Path name: "))
-		 (or (buffer-file-name) "(none)"))))
+  (interactive (list (hg-read-file-name)))
   (let ((root (do ((prev nil dir)
-		   (dir (file-name-directory path)
+		   (dir (file-name-directory (or path (buffer-file-name)))
 			(file-name-directory (directory-file-name dir))))
 		  ((equal prev dir))
 		(when (file-directory-p (concat dir ".hg"))
@@ -425,9 +565,12 Push changes G
 		 (abbreviate-file-name path t))))
     root))
 
-(defun hg-status ()
-  (interactive)
-  (error "not implemented"))
+(defun hg-status (path)
+  (interactive (list (hg-read-file-name " for status" (hg-root))))
+  (let ((root (hg-root)))
+    (hg-view-output (hg-output-buffer-name)
+      (apply 'call-process (hg-binary) nil t nil
+	     (list "-C" root "status" path)))))
 
 (defun hg-undo ()
   (interactive)