Emacs: implement hg-incoming, hg-outgoing and hg-push.
--- a/contrib/mercurial.el Tue Aug 23 21:30:12 2005 -0700
+++ b/contrib/mercurial.el Tue Aug 23 21:53:13 2005 -0700
@@ -92,6 +92,11 @@
: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
@@ -125,6 +130,20 @@
: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.
@@ -152,6 +171,7 @@
"The name to use for Mercurial output buffers.")
(defvar hg-file-history nil)
+(defvar hg-repo-history nil)
(defvar hg-rev-history nil)
@@ -234,6 +254,7 @@
(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
@@ -370,13 +391,84 @@
'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 (or (not rev) current-prefix-arg)
+ (if current-prefix-arg
(let ((revs (split-string (hg-chomp
(hg-run0 "-q" "log" "-r"
(format "-%d"
@@ -837,14 +929,28 @@
(with-current-buffer buf
(hg-mode-line)))))
-(defun hg-incoming ()
- (interactive)
- (error "not implemented"))
+(defun hg-incoming (&optional repo)
+ "Display changesets present in REPO that are not present locally."
+ (interactive (list (hg-read-repo-name " where changes would come from")))
+ (hg-view-output ((format "Mercurial: Incoming from %s to %s"
+ (hg-abbrev-file-name (hg-root))
+ (hg-abbrev-file-name
+ (or repo hg-incoming-repository))))
+ (call-process (hg-binary) nil t nil "incoming"
+ (or repo hg-incoming-repository))
+ (hg-log-mode)))
(defun hg-init ()
(interactive)
(error "not implemented"))
+(defun hg-log-mode ()
+ "Mode for viewing a Mercurial change log."
+ (goto-char (point-min))
+ (when (looking-at "^searching for changes")
+ (kill-entire-line))
+ (run-hooks 'hg-log-mode-hook))
+
(defun hg-log (path &optional rev1 rev2)
"Display the revision history of PATH, between REV1 and REV2.
REV1 defaults to hg-log-limit changes from the tip revision, while
@@ -863,7 +969,7 @@
(if (> (length path) (length (hg-root path)))
(call-process (hg-binary) nil t nil "log" "-r" r1 "-r" r2 path)
(call-process (hg-binary) nil t nil "log" "-r" r1 "-r" r2))
- (font-lock-fontify-buffer))))
+ (hg-log-mode))))
(defun hg-log-repo (path &optional rev1 rev2)
"Display the revision history of the repository containing PATH.
@@ -875,17 +981,31 @@
(hg-read-rev " to end with" (format "-%d" hg-log-limit))))
(hg-log (hg-root path) rev1 rev2))
-(defun hg-outgoing ()
- (interactive)
- (error "not implemented"))
+(defun hg-outgoing (&optional repo)
+ "Display changesets present locally that are not present in REPO."
+ (interactive (list (hg-read-repo-name " where changes would go to" nil
+ hg-outgoing-repository)))
+ (hg-view-output ((format "Mercurial: Outgoing from %s to %s"
+ (hg-abbrev-file-name (hg-root))
+ (hg-abbrev-file-name
+ (or repo hg-outgoing-repository))))
+ (call-process (hg-binary) nil t nil "outgoing"
+ (or repo hg-outgoing-repository))
+ (hg-log-mode)))
(defun hg-pull ()
(interactive)
(error "not implemented"))
-(defun hg-push ()
- (interactive)
- (error "not implemented"))
+(defun hg-push (&optional repo)
+ "Push changes to repository REPO."
+ (interactive (list (hg-read-repo-name " to push to")))
+ (hg-view-output ((format "Mercurial: Push from %s to %s"
+ (hg-abbrev-file-name (hg-root))
+ (hg-abbrev-file-name
+ (or repo hg-outgoing-repository))))
+ (call-process (hg-binary) nil t nil "push"
+ (or repo hg-outgoing-repository))))
(defun hg-revert-buffer-internal ()
(let ((ctx (hg-buffer-context)))
@@ -935,7 +1055,7 @@
(if root
(message "The root of this repository is `%s'." root)
(message "The path `%s' is not in a Mercurial repository."
- (abbreviate-file-name path t))))
+ (hg-abbrev-file-name path))))
root)
hg-root))