mercurial.el
1273 lines
| 42.5 KiB
| text/x-common-lisp
|
EmacsLispLexer
/ contrib / mercurial.el
|
r944 | ;;; mercurial.el --- Emacs support for the Mercurial distributed SCM | ||
|
r2997 | ;; Copyright (C) 2005, 2006 Bryan O'Sullivan | ||
|
r944 | |||
;; Author: Bryan O'Sullivan <bos@serpentine.com> | ||||
|
r947 | ;; 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. | ||||
|
r944 | |||
|
r947 | ;; mercurial.el is distributed in the hope that it will be useful, but | ||
|
r944 | ;; 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 | ||||
|
r947 | ;; along with mercurial.el, GNU Emacs, or XEmacs; see the file COPYING | ||
|
r944 | ;; (`C-h C-l'). If not, write to the Free Software Foundation, Inc., | ||
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ||||
;;; Commentary: | ||||
|
r1004 | ;; mercurial.el builds upon Emacs's VC mode to provide flexible | ||
|
r944 | ;; integration with the Mercurial distributed SCM tool. | ||
|
r947 | ;; To get going as quickly as possible, load mercurial.el into Emacs and | ||
|
r944 | ;; 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. | ||||
|
r1004 | ;; 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 | ||||
|
r944 | ;; 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: | ||||
|
r4433 | (eval-when-compile (require 'cl)) | ||
|
r944 | (require 'diff-mode) | ||
(require 'easymenu) | ||||
|
r1024 | (require 'executable) | ||
|
r944 | (require 'vc) | ||
|
r4433 | (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)))))) | ||||
|
r944 | |||
;;; XEmacs has view-less, while GNU Emacs has view. Joy. | ||||
|
r4433 | (hg-feature-cond | ||
(xemacs (require 'view-less)) | ||||
(t (require 'view))) | ||||
|
r944 | |||
;;; Variables accessible through the custom system. | ||||
|
r947 | (defgroup mercurial nil | ||
|
r944 | "Mercurial distributed SCM." | ||
:group 'tools) | ||||
(defcustom hg-binary | ||||
|
r1011 | (or (executable-find "hg") | ||
(dolist (path '("~/bin/hg" "/usr/bin/hg" "/usr/local/bin/hg")) | ||||
(when (file-executable-p path) | ||||
(return path)))) | ||||
|
r944 | "The path to Mercurial's hg executable." | ||
:type '(file :must-match t) | ||||
|
r947 | :group 'mercurial) | ||
|
r944 | |||
(defcustom hg-mode-hook nil | ||||
"Hook run when a buffer enters hg-mode." | ||||
:type 'sexp | ||||
|
r947 | :group 'mercurial) | ||
|
r944 | |||
|
r1003 | (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) | ||||
|
r1029 | (defcustom hg-log-mode-hook nil | ||
"Hook run after a buffer is filled with log information." | ||||
:type 'sexp | ||||
:group 'mercurial) | ||||
|
r944 | (defcustom hg-global-prefix "\C-ch" | ||
"The global prefix for Mercurial keymap bindings." | ||||
:type 'sexp | ||||
|
r947 | :group 'mercurial) | ||
|
r999 | (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) | ||||
|
r947 | (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) | ||||
|
r944 | |||
|
r995 | (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) | ||||
|
r1029 | (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) | ||||
|
r944 | |||
;;; Other variables. | ||||
(defvar hg-mode nil | ||||
"Is this file managed by Mercurial?") | ||||
|
r947 | (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) | ||||
|
r944 | |||
|
r1003 | (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) | ||||
|
r4433 | (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) | ||||
|
r944 | (defvar hg-output-buffer-name "*Hg*" | ||
"The name to use for Mercurial output buffers.") | ||||
|
r947 | (defvar hg-file-history nil) | ||
|
r1029 | (defvar hg-repo-history nil) | ||
|
r947 | (defvar hg-rev-history nil) | ||
|
r4433 | (defvar hg-repo-completion-table nil) ; shut up warnings | ||
|
r944 | |||
|
r999 | ;;; 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") | ||||
|
r4433 | (defconst hg-state-alist | ||
'((?M . modified) | ||||
(?A . added) | ||||
(?R . removed) | ||||
(?! . deleted) | ||||
(?C . normal) | ||||
(?I . ignored) | ||||
(?? . nil))) | ||||
|
r999 | |||
|
r944 | ;;; hg-mode keymap. | ||
(defvar hg-prefix-map | ||||
|
r4433 | (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) | ||||
|
r944 | map) | ||
"This keymap overrides some default vc-mode bindings.") | ||||
|
r4433 | |||
(defvar hg-mode-map | ||||
(let ((map (make-sparse-keymap))) | ||||
(define-key map "\C-xv" hg-prefix-map) | ||||
map)) | ||||
|
r944 | |||
|
r947 | (add-minor-mode 'hg-mode 'hg-mode hg-mode-map) | ||
|
r944 | |||
;;; Global keymap. | ||||
|
r4433 | (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)) | ||||
|
r944 | |||
|
r4433 | (global-set-key hg-global-prefix hg-global-map) | ||
|
r944 | |||
;;; View mode keymap. | ||||
(defvar hg-view-mode-map | ||||
|
r4433 | (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) | ||||
|
r944 | map)) | ||
|
r4433 | |||
(add-minor-mode 'hg-view-mode "" hg-view-mode-map) | ||||
|
r944 | |||
|
r999 | ;;; Commit mode keymaps. | ||
|
r4433 | (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)) | ||||
|
r999 | |||
|
r4433 | (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)) | ||||
|
r1308 | |||
|
r999 | |||
|
r944 | ;;; Convenience functions. | ||
|
r995 | (defsubst hg-binary () | ||
|
r944 | (if hg-binary | ||
hg-binary | ||||
(error "No `hg' executable found!"))) | ||||
|
r995 | (defsubst hg-replace-in-string (str regexp newtext &optional literal) | ||
|
r944 | "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." | ||||
|
r4433 | (hg-feature-cond | ||
(xemacs (replace-in-string str regexp newtext literal)) | ||||
(t (replace-regexp-in-string regexp newtext str nil literal)))) | ||||
|
r944 | |||
|
r999 | (defsubst hg-strip (str) | ||
|
r1178 | "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]" "")) | ||||
|
r999 | |||
|
r995 | (defsubst hg-chomp (str) | ||
|
r944 | "Strip trailing newlines from a string." | ||
|
r2999 | (hg-replace-in-string str "[\r\n]+\\'" "")) | ||
|
r944 | |||
(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)))) | ||||
|
r4412 | (defmacro hg-do-across-repo (path &rest body) | ||
|
r4433 | (let ((root-name (make-symbol "root-")) | ||
(buf-name (make-symbol "buf-"))) | ||||
|
r4412 | `(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) | ||||
|
r1024 | (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))))) | ||||
|
r1308 | |||
|
r944 | (defun hg-buffer-commands (pnt) | ||
"Use the properties of a character to do something sensible." | ||||
(interactive "d") | ||||
(let ((rev (get-char-property pnt 'rev)) | ||||
|
r4433 | (file (get-char-property pnt 'file))) | ||
|
r944 | (cond | ||
(file | ||||
(find-file-other-window file)) | ||||
(rev | ||||
|
r4433 | (hg-diff hg-view-file-name rev rev)) | ||
|
r944 | ((message "I don't know how to do that yet"))))) | ||
|
r1004 | (defsubst hg-event-point (event) | ||
"Return the character position of the mouse event EVENT." | ||||
|
r4433 | (hg-feature-cond (xemacs (event-point event)) | ||
(t (posn-point (event-start event))))) | ||||
|
r1004 | |||
(defsubst hg-event-window (event) | ||||
"Return the window over which mouse event EVENT occurred." | ||||
|
r4433 | (hg-feature-cond (xemacs (event-window event)) | ||
(t (posn-window (event-start event))))) | ||||
|
r1004 | |||
|
r944 | (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") | ||||
|
r1004 | (select-window (hg-event-window event)) | ||
(hg-buffer-commands (hg-event-point event))) | ||||
|
r944 | |||
|
r995 | (defsubst hg-abbrev-file-name (file) | ||
"Portable wrapper around abbreviate-file-name." | ||||
|
r4433 | (hg-feature-cond (xemacs (abbreviate-file-name file t)) | ||
(t (abbreviate-file-name file)))) | ||||
|
r944 | |||
|
r947 | (defun hg-read-file-name (&optional prompt default) | ||
"Read a file or directory name, or a pattern, to use with a command." | ||||
|
r1003 | (save-excursion | ||
(while hg-prev-buffer | ||||
(set-buffer hg-prev-buffer)) | ||||
|
r2668 | (let ((path (or default | ||
(buffer-file-name) | ||||
(expand-file-name default-directory)))) | ||||
|
r1003 | (if (or (not path) current-prefix-arg) | ||
|
r2315 | (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)) | ||||
|
r4433 | (hg-feature-cond | ||
(xemacs (cons (quote 'hg-file-history) nil)) | ||||
(t nil))))) | ||||
|
r2315 | path)))) | ||
|
r947 | |||
|
r2316 | (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))) | ||||
|
r1029 | (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)))))) | ||||
|
r1308 | |||
|
r1029 | (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)) | ||||
|
r4433 | (unless (hg-string-starts-with (hg-feature-cond | ||
(xemacs directory-sep-char) | ||||
(t ?/)) | ||||
(cdr path)) | ||||
|
r1029 | (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)))) | ||||
|
r947 | (defun hg-read-rev (&optional prompt default) | ||
"Read a revision or tag, offering completions." | ||||
|
r1003 | (save-excursion | ||
(while hg-prev-buffer | ||||
(set-buffer hg-prev-buffer)) | ||||
(let ((rev (or default "tip"))) | ||||
|
r1029 | (if current-prefix-arg | ||
|
r1175 | (let ((revs (split-string | ||
(hg-chomp | ||||
|
r4433 | (hg-run0 "-q" "log" "-l" | ||
(format "%d" hg-rev-completion-limit))) | ||||
|
r1175 | "[\n:]"))) | ||
|
r1003 | (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)))) | ||||
|
r999 | |||
|
r3002 | (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))))))) | ||||
|
r944 | |||
;;; View mode bits. | ||||
(defun hg-exit-view-mode (buf) | ||||
"Exit from hg-view-mode. | ||||
We delete the current window if entering hg-view-mode split the | ||||
current frame." | ||||
(when (and (eq buf (current-buffer)) | ||||
(> (length (window-list)) 1)) | ||||
(delete-window)) | ||||
(when (buffer-live-p buf) | ||||
(kill-buffer buf))) | ||||
(defun hg-view-mode (prev-buffer &optional file-name) | ||||
(goto-char (point-min)) | ||||
(set-buffer-modified-p nil) | ||||
(toggle-read-only t) | ||||
|
r4433 | (hg-feature-cond (xemacs (view-minor-mode prev-buffer 'hg-exit-view-mode)) | ||
(t (view-mode-enter nil 'hg-exit-view-mode))) | ||||
(setq hg-view-mode t) | ||||
|
r944 | (setq truncate-lines t) | ||
(when file-name | ||||
|
r4433 | (setq hg-view-file-name | ||
(hg-abbrev-file-name file-name)))) | ||||
|
r1308 | |||
|
r947 | (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) | ||||
|
r4433 | (let ((state (and (>= (length output) 2) | ||
(= (aref output 1) ? ) | ||||
(assq (aref output 0) hg-state-alist)))) | ||||
|
r947 | (if state | ||
(cdr state) | ||||
'normal))))) | ||||
|
r3002 | (defun hg-path-status (root paths) | ||
"Return status of PATHS in repo ROOT as an alist. | ||||
|
r3001 | Each entry is a pair (FILE-NAME . STATUS)." | ||
|
r3002 | (let ((s (apply 'hg-run "--cwd" root "status" "-marduc" paths)) | ||
|
r3005 | result) | ||
(dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result)) | ||||
(let (state name) | ||||
|
r4433 | (cond ((= (aref entry 1) ? ) | ||
(setq state (assq (aref entry 0) hg-state-alist) | ||||
name (substring entry 2))) | ||||
((string-match "\\(.*\\): " entry) | ||||
(setq name (match-string 1 entry)))) | ||||
|
r3005 | (setq result (cons (cons name state) result)))))) | ||
|
r3001 | |||
|
r944 | (defmacro hg-view-output (args &rest body) | ||
|
r947 | "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. | ||||
|
r944 | 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." | ||||
|
r4433 | (let ((prev-buf (make-symbol "prev-buf-")) | ||
|
r944 | (v-b-name (car args)) | ||
(v-m-rest (cdr args))) | ||||
`(let ((view-buf-name ,v-b-name) | ||||
(,prev-buf (current-buffer))) | ||||
(get-buffer-create view-buf-name) | ||||
(kill-buffer view-buf-name) | ||||
|
r947 | (get-buffer-create view-buf-name) | ||
(set-buffer view-buf-name) | ||||
|
r944 | (save-excursion | ||
,@body) | ||||
|
r947 | (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) | ||||
|
r1003 | (setq hg-prev-buffer ,prev-buf) | ||
|
r947 | (hg-view-mode ,prev-buf ,@v-m-rest)))))) | ||
|
r944 | |||
(put 'hg-view-output 'lisp-indent-function 1) | ||||
|
r947 | |||
|
r3005 | ;;; Context save and restore across revert and other operations. | ||
|
r995 | |||
(defun hg-position-context (pos) | ||||
"Return information to help find the given position again." | ||||
(let* ((end (min (point-max) (+ pos 98)))) | ||||
(list pos | ||||
(buffer-substring (max (point-min) (- pos 2)) end) | ||||
(- end pos)))) | ||||
(defun hg-buffer-context () | ||||
"Return information to help restore a user's editing context. | ||||
This is useful across reverts and merges, where a context is likely | ||||
to have moved a little, but not really changed." | ||||
(let ((point-context (hg-position-context (point))) | ||||
(mark-context (let ((mark (mark-marker))) | ||||
(and mark (hg-position-context mark))))) | ||||
(list point-context mark-context))) | ||||
|
r1308 | |||
|
r995 | (defun hg-find-context (ctx) | ||
"Attempt to find a context in the given buffer. | ||||
Always returns a valid, hopefully sane, position." | ||||
(let ((pos (nth 0 ctx)) | ||||
(str (nth 1 ctx)) | ||||
(fixup (nth 2 ctx))) | ||||
(save-excursion | ||||
(goto-char (max (point-min) (- pos 15000))) | ||||
(if (and (not (equal str "")) | ||||
(search-forward str nil t)) | ||||
(- (point) fixup) | ||||
(max pos (point-min)))))) | ||||
(defun hg-restore-context (ctx) | ||||
"Attempt to restore the user's editing context." | ||||
(let ((point-context (nth 0 ctx)) | ||||
(mark-context (nth 1 ctx))) | ||||
(goto-char (hg-find-context point-context)) | ||||
(when mark-context | ||||
(set-mark (hg-find-context mark-context))))) | ||||
|
r947 | ;;; Hooks. | ||
|
r3002 | (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")))))))) | ||||
|
r995 | (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." | ||||
|
r3002 | (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)))) | ||||
|
r947 | |||
|
r1371 | (defun hg-mode (&optional toggle) | ||
|
r1003 | "Minor mode for Mercurial distributed SCM integration. | ||
|
r944 | |||
|
r1003 | The Mercurial mode user interface is based on that of VC mode, so if | ||
you're already familiar with VC, the same keybindings and functions | ||||
will generally work. | ||||
|
r944 | |||
|
r2517 | Below is a list of many common SCM tasks. In the list, `G/L\' | ||
|
r4411 | indicates whether a key binding is global (G) to a repository or | ||
local (L) to a file. Many commands take a prefix argument. | ||||
|
r944 | |||
SCM Task G/L Key Binding Command Name | ||||
-------- --- ----------- ------------ | ||||
Help overview (what you are reading) G C-c h h hg-help-overview | ||||
|
r947 | Tell Mercurial to manage a file G C-c h a hg-add | ||
|
r1179 | Commit changes to current file only L C-x v n hg-commit-start | ||
|
r995 | Undo changes to file since commit L C-x v u hg-revert-buffer | ||
|
r944 | |||
|
r947 | Diff file vs last checkin L C-x v = hg-diff | ||
|
r944 | |||
|
r947 | View file change history L C-x v l hg-log | ||
|
r944 | View annotated file L C-x v a hg-annotate | ||
|
r1003 | Diff repo vs last checkin G C-c h = hg-diff-repo | ||
|
r944 | View status of files in repo G C-c h s hg-status | ||
|
r1179 | Commit all changes G C-c h c hg-commit-start | ||
|
r944 | |||
Undo all changes since last commit G C-c h U hg-revert | ||||
|
r1179 | View repo change history G C-c h l hg-log-repo | ||
|
r944 | |||
See changes that can be pulled G C-c h , hg-incoming | ||||
Pull changes G C-c h < hg-pull | ||||
Update working directory after pull G C-c h u hg-update | ||||
See changes that can be pushed G C-c h . hg-outgoing | ||||
Push changes G C-c h > hg-push" | ||||
|
r2517 | (unless vc-make-backup-files | ||
(set (make-local-variable 'backup-inhibited) t)) | ||||
|
r2518 | (run-hooks 'hg-mode-hook)) | ||
|
r1003 | |||
(defun hg-find-file-hook () | ||||
|
r4413 | (ignore-errors | ||
(when (hg-mode-line) | ||||
(hg-mode)))) | ||||
|
r1003 | |||
(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) | ||||
(hg-mode)))) | ||||
(add-hook 'after-save-hook 'hg-after-save-hook) | ||||
;;; User interface functions. | ||||
(defun hg-help-overview () | ||||
"This is an overview of the Mercurial SCM mode for Emacs. | ||||
You can find the source code, license (GPL v2), and credits for this | ||||
code by typing `M-x find-library mercurial RET'." | ||||
|
r944 | (interactive) | ||
(hg-view-output ("Mercurial Help Overview") | ||||
|
r1003 | (insert (documentation 'hg-help-overview)) | ||
(let ((pos (point))) | ||||
(insert (documentation 'hg-mode)) | ||||
(goto-char pos) | ||||
|
r2452 | (end-of-line 1) | ||
|
r2457 | (delete-region pos (point))) | ||
|
r2737 | (let ((hg-root-dir (hg-root))) | ||
(if (not hg-root-dir) | ||||
(error "error: %s: directory is not part of a Mercurial repository." | ||||
default-directory) | ||||
|
r2877 | (cd hg-root-dir))))) | ||
|
r944 | |||
|
r2997 | (defun hg-fix-paths () | ||
"Fix paths reported by some Mercurial commands." | ||||
(save-excursion | ||||
(goto-char (point-min)) | ||||
(while (re-search-forward " \\.\\.." nil t) | ||||
(replace-match " " nil nil)))) | ||||
|
r947 | (defun hg-add (path) | ||
|
r996 | "Add PATH to the Mercurial repository on the next commit. | ||
With a prefix argument, prompt for the path to add." | ||||
|
r947 | (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) | ||||
|
r2454 | (apply 'call-process (hg-binary) nil t nil (list "add" path)) | ||
|
r2997 | (hg-fix-paths) | ||
|
r2998 | (goto-char (point-min)) | ||
|
r2454 | (cd (hg-root path))) | ||
|
r947 | (when update | ||
|
r2517 | (unless vc-make-backup-files | ||
(set (make-local-variable 'backup-inhibited) t)) | ||||
|
r947 | (with-current-buffer buf | ||
(hg-mode-line))))) | ||||
|
r944 | |||
(defun hg-addremove () | ||||
(interactive) | ||||
(error "not implemented")) | ||||
(defun hg-annotate () | ||||
(interactive) | ||||
(error "not implemented")) | ||||
|
r999 | (defun hg-commit-toggle-file (pos) | ||
"Toggle whether or not the file at POS will be committed." | ||||
(interactive "d") | ||||
(save-excursion | ||||
(goto-char pos) | ||||
(let ((face (get-text-property pos 'face)) | ||||
|
r1004 | (inhibit-read-only t) | ||
|
r999 | bol) | ||
(beginning-of-line) | ||||
(setq bol (+ (point) 4)) | ||||
(end-of-line) | ||||
(if (eq face 'bold) | ||||
(progn | ||||
(remove-text-properties bol (point) '(face nil)) | ||||
(message "%s will not be committed" | ||||
(buffer-substring bol (point)))) | ||||
(add-text-properties bol (point) '(face bold)) | ||||
(message "%s will be committed" | ||||
(buffer-substring bol (point))))))) | ||||
|
r1308 | |||
|
r999 | (defun hg-commit-mouse-clicked (event) | ||
"Toggle whether or not the file at POS will be committed." | ||||
(interactive "@e") | ||||
|
r1004 | (hg-commit-toggle-file (hg-event-point event))) | ||
|
r999 | |||
|
r1003 | (defun hg-commit-kill () | ||
"Kill the commit currently being prepared." | ||||
|
r999 | (interactive) | ||
|
r1003 | (when (or (not (buffer-modified-p)) (y-or-n-p "Really kill this commit? ")) | ||
(let ((buf hg-prev-buffer)) | ||||
(kill-buffer nil) | ||||
(switch-to-buffer buf)))) | ||||
|
r999 | |||
(defun hg-commit-finish () | ||||
|
r1003 | "Finish preparing a commit, and perform the actual commit. | ||
The hook hg-pre-commit-hook is run before anything else is done. If | ||||
the commit message is empty and hg-commit-allow-empty-message is nil, | ||||
an error is raised. If the list of files to commit is empty and | ||||
hg-commit-allow-empty-file-list is nil, an error is raised." | ||||
|
r999 | (interactive) | ||
|
r1003 | (let ((root hg-root)) | ||
(save-excursion | ||||
(run-hooks 'hg-pre-commit-hook) | ||||
(goto-char (point-min)) | ||||
(search-forward hg-commit-message-start) | ||||
(let (message files) | ||||
(let ((start (point))) | ||||
(goto-char (point-max)) | ||||
(search-backward hg-commit-message-end) | ||||
(setq message (hg-strip (buffer-substring start (point))))) | ||||
(when (and (= (length message) 0) | ||||
(not hg-commit-allow-empty-message)) | ||||
(error "Cannot proceed - commit message is empty")) | ||||
(forward-line 1) | ||||
(beginning-of-line) | ||||
(while (< (point) (point-max)) | ||||
(let ((pos (+ (point) 4))) | ||||
(end-of-line) | ||||
(when (eq (get-text-property pos 'face) 'bold) | ||||
(end-of-line) | ||||
(setq files (cons (buffer-substring pos (point)) files)))) | ||||
(forward-line 1)) | ||||
(when (and (= (length files) 0) | ||||
(not hg-commit-allow-empty-file-list)) | ||||
(error "Cannot proceed - no files to commit")) | ||||
(setq message (concat message "\n")) | ||||
(apply 'hg-run0 "--cwd" hg-root "commit" "-m" message files)) | ||||
(let ((buf hg-prev-buffer)) | ||||
(kill-buffer nil) | ||||
(switch-to-buffer buf)) | ||||
|
r3002 | (hg-update-mode-lines root)))) | ||
|
r999 | |||
(defun hg-commit-mode () | ||||
"Mode for describing a commit of changes to a Mercurial repository. | ||||
This involves two actions: describing the changes with a commit | ||||
message, and choosing the files to commit. | ||||
To describe the commit, simply type some text in the designated area. | ||||
By default, all modified, added and removed files are selected for | ||||
committing. Files that will be committed are displayed in bold face\; | ||||
those that will not are displayed in normal face. | ||||
To toggle whether a file will be committed, move the cursor over a | ||||
particular file and hit space or return. Alternatively, middle click | ||||
on the file. | ||||
|
r1003 | Key bindings | ||
------------ | ||||
\\[hg-commit-finish] proceed with commit | ||||
\\[hg-commit-kill] kill commit | ||||
\\[hg-diff-repo] view diff of pending changes" | ||||
|
r999 | (interactive) | ||
(use-local-map hg-commit-mode-map) | ||||
(set-syntax-table text-mode-syntax-table) | ||||
(setq local-abbrev-table text-mode-abbrev-table | ||||
major-mode 'hg-commit-mode | ||||
mode-name "Hg-Commit") | ||||
(set-buffer-modified-p nil) | ||||
(setq buffer-undo-list nil) | ||||
(run-hooks 'text-mode-hook 'hg-commit-mode-hook)) | ||||
|
r1003 | (defun hg-commit-start () | ||
"Prepare a commit of changes to the repository containing the current file." | ||||
|
r944 | (interactive) | ||
|
r1003 | (while hg-prev-buffer | ||
(set-buffer hg-prev-buffer)) | ||||
|
r999 | (let ((root (hg-root)) | ||
|
r1003 | (prev-buffer (current-buffer)) | ||
modified-files) | ||||
|
r999 | (unless root | ||
(error "Cannot commit outside a repository!")) | ||||
|
r1024 | (hg-sync-buffers root) | ||
|
r1003 | (setq modified-files (hg-chomp (hg-run0 "--cwd" root "status" "-arm"))) | ||
(when (and (= (length modified-files) 0) | ||||
(not hg-commit-allow-empty-file-list)) | ||||
(error "No pending changes to commit")) | ||||
|
r999 | (let* ((buf-name (format "*Mercurial: Commit %s*" root))) | ||
(pop-to-buffer (get-buffer-create buf-name)) | ||||
(when (= (point-min) (point-max)) | ||||
(set (make-local-variable 'hg-root) root) | ||||
|
r1003 | (setq hg-prev-buffer prev-buffer) | ||
|
r999 | (insert "\n") | ||
(let ((bol (point))) | ||||
(insert hg-commit-message-end) | ||||
|
r1004 | (add-text-properties bol (point) '(face bold-italic))) | ||
|
r999 | (let ((file-area (point))) | ||
|
r1003 | (insert modified-files) | ||
|
r999 | (goto-char file-area) | ||
(while (< (point) (point-max)) | ||||
(let ((bol (point))) | ||||
(forward-char 1) | ||||
(insert " ") | ||||
(end-of-line) | ||||
(add-text-properties (+ bol 4) (point) | ||||
'(face bold mouse-face highlight))) | ||||
(forward-line 1)) | ||||
(goto-char file-area) | ||||
(add-text-properties (point) (point-max) | ||||
|
r1004 | `(keymap ,hg-commit-mode-file-map)) | ||
|
r999 | (goto-char (point-min)) | ||
(insert hg-commit-message-start) | ||||
|
r1004 | (add-text-properties (point-min) (point) '(face bold-italic)) | ||
|
r999 | (insert "\n\n") | ||
(forward-line -1) | ||||
|
r1004 | (save-excursion | ||
(goto-char (point-max)) | ||||
(search-backward hg-commit-message-end) | ||||
(add-text-properties (match-beginning 0) (point-max) | ||||
'(read-only t)) | ||||
(goto-char (point-min)) | ||||
(search-forward hg-commit-message-start) | ||||
(add-text-properties (match-beginning 0) (match-end 0) | ||||
'(read-only t))) | ||||
|
r2454 | (hg-commit-mode) | ||
(cd root)))))) | ||||
|
r944 | |||
|
r947 | (defun hg-diff (path &optional rev1 rev2) | ||
|
r996 | "Show the differences between REV1 and REV2 of PATH. | ||
When called interactively, the default behaviour is to treat REV1 as | ||||
|
r2455 | the \"parent\" revision, REV2 as the current edited version of the file, and | ||
|
r996 | PATH as the file edited in the current buffer. | ||
With a prefix argument, prompt for all of these." | ||||
|
r947 | (interactive (list (hg-read-file-name " to diff") | ||
|
r2455 | (let ((rev1 (hg-read-rev " to start with" 'parent))) | ||
(and (not (eq rev1 'parent)) rev1)) | ||||
|
r947 | (let ((rev2 (hg-read-rev " to end with" 'working-dir))) | ||
(and (not (eq rev2 'working-dir)) rev2)))) | ||||
|
r1024 | (hg-sync-buffers path) | ||
|
r995 | (let ((a-path (hg-abbrev-file-name path)) | ||
|
r2455 | ;; none revision is specified explicitly | ||
(none (and (not rev1) (not rev2))) | ||||
;; only one revision is specified explicitly | ||||
(one (or (and (or (equal rev1 rev2) (not rev2)) rev1) | ||||
(and (not rev1) rev2))) | ||||
|
r995 | diff) | ||
|
r1027 | (hg-view-output ((cond | ||
|
r2455 | (none | ||
(format "Mercurial: Diff against parent of %s" a-path)) | ||||
(one | ||||
(format "Mercurial: Diff of rev %s of %s" one a-path)) | ||||
|
r1027 | (t | ||
(format "Mercurial: Diff from rev %s to %s of %s" | ||||
|
r2455 | rev1 rev2 a-path)))) | ||
(cond | ||||
(none | ||||
(call-process (hg-binary) nil t nil "diff" path)) | ||||
(one | ||||
(call-process (hg-binary) nil t nil "diff" "-r" one path)) | ||||
(t | ||||
(call-process (hg-binary) nil t nil "diff" "-r" rev1 "-r" rev2 path))) | ||||
|
r947 | (diff-mode) | ||
|
r995 | (setq diff (not (= (point-min) (point-max)))) | ||
|
r2454 | (font-lock-fontify-buffer) | ||
(cd (hg-root path))) | ||||
|
r995 | diff)) | ||
|
r944 | |||
|
r2455 | (defun hg-diff-repo (path &optional rev1 rev2) | ||
"Show the differences between REV1 and REV2 of repository containing PATH. | ||||
When called interactively, the default behaviour is to treat REV1 as | ||||
the \"parent\" revision, REV2 as the current edited version of the file, and | ||||
PATH as the `hg-root' of the current buffer. | ||||
With a prefix argument, prompt for all of these." | ||||
(interactive (list (hg-read-file-name " to diff") | ||||
(let ((rev1 (hg-read-rev " to start with" 'parent))) | ||||
(and (not (eq rev1 'parent)) rev1)) | ||||
(let ((rev2 (hg-read-rev " to end with" 'working-dir))) | ||||
(and (not (eq rev2 'working-dir)) rev2)))) | ||||
(hg-diff (hg-root path) rev1 rev2)) | ||||
|
r1003 | |||
|
r947 | (defun hg-forget (path) | ||
|
r996 | "Lose track of PATH, which has been added, but not yet committed. | ||
This will prevent the file from being incorporated into the Mercurial | ||||
repository on the next commit. | ||||
With a prefix argument, prompt for the path to forget." | ||||
|
r947 | (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) | ||||
|
r2454 | (apply 'call-process (hg-binary) nil t nil (list "forget" path)) | ||
;; "hg forget" shows pathes relative NOT TO ROOT BUT TO REPOSITORY | ||||
|
r2997 | (hg-fix-paths) | ||
|
r2998 | (goto-char (point-min)) | ||
|
r2454 | (cd (hg-root path))) | ||
|
r947 | (when update | ||
(with-current-buffer buf | ||||
|
r2667 | (when (local-variable-p 'backup-inhibited) | ||
(kill-local-variable 'backup-inhibited)) | ||||
|
r947 | (hg-mode-line))))) | ||
|
r1308 | |||
|
r1029 | (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)) | ||||
|
r2454 | (hg-log-mode) | ||
(cd (hg-root)))) | ||||
|
r944 | |||
(defun hg-init () | ||||
(interactive) | ||||
(error "not implemented")) | ||||
|
r1029 | (defun hg-log-mode () | ||
"Mode for viewing a Mercurial change log." | ||||
(goto-char (point-min)) | ||||
|
r2452 | (when (looking-at "^searching for changes.*$") | ||
(delete-region (match-beginning 0) (match-end 0))) | ||||
|
r1029 | (run-hooks 'hg-log-mode-hook)) | ||
|
r2316 | (defun hg-log (path &optional rev1 rev2 log-limit) | ||
"Display the revision history of PATH. | ||||
History is displayed between REV1 and REV2. | ||||
Number of displayed changesets is limited to LOG-LIMIT. | ||||
|
r4693 | REV1 defaults to the tip, while REV2 defaults to 0. | ||
|
r2316 | LOG-LIMIT defaults to `hg-log-limit'. | ||
|
r1027 | With a prefix argument, prompt for each parameter." | ||
|
r947 | (interactive (list (hg-read-file-name " to log") | ||
|
r2316 | (hg-read-rev " to start with" | ||
"tip") | ||||
(hg-read-rev " to end with" | ||||
|
r4693 | "0") | ||
|
r2316 | (hg-read-number "Output limited to: " | ||
hg-log-limit))) | ||||
|
r1027 | (let ((a-path (hg-abbrev-file-name path)) | ||
|
r4693 | (r1 (or rev1 "tip")) | ||
(r2 (or rev2 "0")) | ||||
|
r2316 | (limit (format "%d" (or log-limit hg-log-limit)))) | ||
|
r1027 | (hg-view-output ((if (equal r1 r2) | ||
|
r2316 | (format "Mercurial: Log of rev %s of %s" rev1 a-path) | ||
(format | ||||
"Mercurial: at most %s log(s) from rev %s to %s of %s" | ||||
limit r1 r2 a-path))) | ||||
(eval (list* 'call-process (hg-binary) nil t nil | ||||
"log" | ||||
"-r" (format "%s:%s" r1 r2) | ||||
"-l" limit | ||||
(if (> (length path) (length (hg-root path))) | ||||
(cons path nil) | ||||
nil))) | ||||
|
r2454 | (hg-log-mode) | ||
(cd (hg-root path))))) | ||||
|
r944 | |||
|
r2316 | (defun hg-log-repo (path &optional rev1 rev2 log-limit) | ||
|
r1003 | "Display the revision history of the repository containing PATH. | ||
|
r2316 | History is displayed between REV1 and REV2. | ||
Number of displayed changesets is limited to LOG-LIMIT, | ||||
|
r4693 | REV1 defaults to the tip, while REV2 defaults to 0. | ||
|
r2316 | LOG-LIMIT defaults to `hg-log-limit'. | ||
With a prefix argument, prompt for each parameter." | ||||
|
r1003 | (interactive (list (hg-read-file-name " to log") | ||
|
r2316 | (hg-read-rev " to start with" | ||
"tip") | ||||
(hg-read-rev " to end with" | ||||
|
r4693 | "0") | ||
|
r2316 | (hg-read-number "Output limited to: " | ||
hg-log-limit))) | ||||
(hg-log (hg-root path) rev1 rev2 log-limit)) | ||||
|
r1003 | |||
|
r1029 | (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)) | ||||
|
r2454 | (hg-log-mode) | ||
(cd (hg-root)))) | ||||
|
r944 | |||
|
r1246 | (defun hg-pull (&optional repo) | ||
"Pull changes from repository REPO. | ||||
This does not update the working directory." | ||||
(interactive (list (hg-read-repo-name " to pull from"))) | ||||
(hg-view-output ((format "Mercurial: Pull to %s from %s" | ||||
(hg-abbrev-file-name (hg-root)) | ||||
(hg-abbrev-file-name | ||||
(or repo hg-incoming-repository)))) | ||||
(call-process (hg-binary) nil t nil "pull" | ||||
|
r2454 | (or repo hg-incoming-repository)) | ||
(cd (hg-root)))) | ||||
|
r944 | |||
|
r1029 | (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" | ||||
|
r2454 | (or repo hg-outgoing-repository)) | ||
(cd (hg-root)))) | ||||
|
r944 | |||
|
r995 | (defun hg-revert-buffer-internal () | ||
(let ((ctx (hg-buffer-context))) | ||||
(message "Reverting %s..." buffer-file-name) | ||||
(hg-run0 "revert" buffer-file-name) | ||||
(revert-buffer t t t) | ||||
(hg-restore-context ctx) | ||||
(hg-mode-line) | ||||
(message "Reverting %s...done" buffer-file-name))) | ||||
|
r944 | |||
|
r995 | (defun hg-revert-buffer () | ||
|
r996 | "Revert current buffer's file back to the latest committed version. | ||
If the file has not changed, nothing happens. Otherwise, this | ||||
displays a diff and asks for confirmation before reverting." | ||||
|
r944 | (interactive) | ||
|
r995 | (let ((vc-suppress-confirm nil) | ||
(obuf (current-buffer)) | ||||
diff) | ||||
(vc-buffer-sync) | ||||
(unwind-protect | ||||
(setq diff (hg-diff buffer-file-name)) | ||||
(when diff | ||||
(unless (yes-or-no-p "Discard changes? ") | ||||
(error "Revert cancelled"))) | ||||
(when diff | ||||
(let ((buf (current-buffer))) | ||||
(delete-window (selected-window)) | ||||
(kill-buffer buf)))) | ||||
(set-buffer obuf) | ||||
(when diff | ||||
(hg-revert-buffer-internal)))) | ||||
|
r944 | |||
(defun hg-root (&optional path) | ||||
|
r996 | "Return the root of the repository that contains the given path. | ||
If the path is outside a repository, return nil. | ||||
When called interactively, the root is printed. A prefix argument | ||||
prompts for a path to check." | ||||
|
r947 | (interactive (list (hg-read-file-name))) | ||
|
r1003 | (if (or path (not hg-root)) | ||
(let ((root (do ((prev nil dir) | ||||
|
r2453 | (dir (file-name-directory | ||
(or | ||||
path | ||||
buffer-file-name | ||||
(expand-file-name default-directory))) | ||||
|
r1003 | (file-name-directory (directory-file-name dir)))) | ||
((equal prev dir)) | ||||
(when (file-directory-p (concat dir ".hg")) | ||||
(return dir))))) | ||||
(when (interactive-p) | ||||
(if root | ||||
(message "The root of this repository is `%s'." root) | ||||
(message "The path `%s' is not in a Mercurial repository." | ||||
|
r1029 | (hg-abbrev-file-name path)))) | ||
|
r1003 | root) | ||
hg-root)) | ||||
|
r944 | |||
|
r3003 | (defun hg-cwd (&optional path) | ||
"Return the current directory of PATH within the repository." | ||||
(do ((stack nil (cons (file-name-nondirectory | ||||
(directory-file-name dir)) | ||||
stack)) | ||||
(prev nil dir) | ||||
(dir (file-name-directory (or path buffer-file-name | ||||
(expand-file-name default-directory))) | ||||
(file-name-directory (directory-file-name dir)))) | ||||
((equal prev dir)) | ||||
(when (file-directory-p (concat dir ".hg")) | ||||
(let ((cwd (mapconcat 'identity stack "/"))) | ||||
(unless (equal cwd "") | ||||
(return (file-name-as-directory cwd))))))) | ||||
|
r947 | (defun hg-status (path) | ||
|
r996 | "Print revision control status of a file or directory. | ||
With prefix argument, prompt for the path to give status for. | ||||
Names are displayed relative to the repository root." | ||||
|
r947 | (interactive (list (hg-read-file-name " for status" (hg-root)))) | ||
(let ((root (hg-root))) | ||||
|
r996 | (hg-view-output ((format "Mercurial: Status of %s in %s" | ||
(let ((name (substring (expand-file-name path) | ||||
(length root)))) | ||||
(if (> (length name) 0) | ||||
name | ||||
"*")) | ||||
(hg-abbrev-file-name root))) | ||||
|
r947 | (apply 'call-process (hg-binary) nil t nil | ||
|
r2454 | (list "--cwd" root "status" path)) | ||
(cd (hg-root path))))) | ||||
|
r944 | |||
(defun hg-undo () | ||||
(interactive) | ||||
(error "not implemented")) | ||||
|
r1246 | (defun hg-update () | ||
(interactive) | ||||
(error "not implemented")) | ||||
|
r944 | (defun hg-version-other-window () | ||
(interactive) | ||||
(error "not implemented")) | ||||
(provide 'mercurial) | ||||
;;; Local Variables: | ||||
;;; prompt-to-byte-compile: nil | ||||
;;; end: | ||||