changeset 3002:65efeb7b2c56

mercurial.el: speed up mode line updates.

--- a/contrib/mercurial.el	Tue Aug 22 11:37:18 2006 -0700
+++ b/contrib/mercurial.el	Tue Aug 22 14:02:43 2006 -0700
@@ -502,6 +502,43 @@
 			     (or default "tip")))
 	rev))))
 
+(defun hg-parents-for-mode-line (root)
+  "Format the parents of the working directory for the mode line."
+  (let ((parents (split-string (hg-chomp
+				(hg-run0 "--cwd" root "parents" "--template"
+					 "{rev}\n")) "\n")))
+    (mapconcat 'identity parents "+")))
+
+(defun hg-buffers-visiting-repo (&optional path)
+  "Return a list of buffers visiting the repository containing PATH."
+  (let ((root-name (hg-root (or path (buffer-file-name))))
+	bufs)
+    (save-excursion
+      (dolist (buf (buffer-list) bufs)
+	(set-buffer buf)
+	(let ((name (buffer-file-name)))
+	  (when (and hg-status name (equal (hg-root name) root-name))
+	    (setq bufs (cons buf bufs))))))))
+
+(defun hg-update-mode-lines (path)
+  "Update the mode lines of all buffers visiting the same repository as PATH."
+  (let* ((root (hg-root path))
+	 (parents (hg-parents-for-mode-line root)))
+    (save-excursion
+      (dolist (info (hg-path-status
+		     root
+		     (mapcar
+		      (function
+		       (lambda (buf)
+			 (substring (buffer-file-name buf) (length root))))
+		      (hg-buffers-visiting-repo root))))
+	(let* ((name (car info))
+	       (status (cdr info))
+	       (buf (find-buffer-visiting (concat root name))))
+	  (when buf
+	    (set-buffer buf)
+	    (hg-mode-line-internal status parents)))))))
+  
 (defmacro hg-do-across-repo (path &rest body)
   (let ((root-name (gensym "root-"))
 	(buf-name (gensym "buf-")))
@@ -554,10 +591,10 @@
 	      (cdr state)
 	    'normal)))))
 
-(defun hg-status (&rest paths)
-  "Return status of PATHS as an alist.
+(defun hg-path-status (root paths)
+  "Return status of PATHS in repo ROOT as an alist.
 Each entry is a pair (FILE-NAME . STATUS)."
-  (let ((s (apply 'hg-run "status" "-marduc" paths))
+  (let ((s (apply 'hg-run "--cwd" root "status" "-marduc" paths))
 	 result)
       (dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result))
 	(let ((state (cdr (assoc (substring entry 0 2)
@@ -569,7 +606,7 @@
 				   ("I " . ignored)
 				   ("? " . nil)))))
 	      (name (substring entry 2)))
-	  (setq result (cons (cons name state) result)))))))
+	  (setq result (cons (cons name state) result))))))
 
 (defmacro hg-view-output (args &rest body)
   "Execute BODY in a clean buffer, then quickly display that buffer.
@@ -646,25 +683,28 @@
 
 ;;; Hooks.
 
+(defun hg-mode-line-internal (status parents)
+  (setq hg-status status
+	hg-mode (and status (concat " Hg:"
+				    parents
+				    (cdr (assq status
+					       '((normal . "")
+						 (removed . "r")
+						 (added . "a")
+						 (deleted . "!")
+						 (modified . "m"))))))))
+  
 (defun hg-mode-line (&optional force)
   "Update the modeline with the current status of a file.
 An update occurs if optional argument FORCE is non-nil,
 hg-update-modeline is non-nil, or we have not yet checked the state of
 the file."
-  (when (and (hg-root) (or force hg-update-modeline (not hg-mode)))
-    (let ((status (hg-file-status buffer-file-name))
-	  (parents
-	   (split-string (hg-chomp
-			  (hg-run0 "parents" "--template" "{rev}\n")) "\n")))
-      (setq hg-status status
-	    hg-mode (and status (concat " Hg:"
-					(mapconcat 'identity parents "+")
-					(cdr (assq status
-						   '((normal . "")
-						     (removed . "r")
-						     (added . "a")
-						     (modified . "m")))))))
-      status)))
+  (let ((root (hg-root)))
+    (when (and root (or force hg-update-modeline (not hg-mode)))
+      (let ((status (hg-file-status buffer-file-name))
+	    (parents (hg-parents-for-mode-line root)))
+	(hg-mode-line-internal status parents)
+	status))))
 
 (defun hg-mode (&optional toggle)
   "Minor mode for Mercurial distributed SCM integration.
@@ -844,8 +884,7 @@
       (let ((buf hg-prev-buffer))
 	(kill-buffer nil)
 	(switch-to-buffer buf))
-      (hg-do-across-repo root
-	(hg-mode-line)))))
+      (hg-update-mode-lines root))))
 
 (defun hg-commit-mode ()
   "Mode for describing a commit of changes to a Mercurial repository.