Mercurial > dotfiles
comparison .elisp/mercurial.el @ 12:d4d720c4c416
Add mercurial support to emacs. Improve setting of PYTHONPATH in there.
| author | Augie Fackler <durin42@gmail.com> |
|---|---|
| date | Wed, 03 Dec 2008 22:34:01 -0600 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 11:9b9098bda691 | 12:d4d720c4c416 |
|---|---|
| 1 ;;; mercurial.el --- Emacs support for the Mercurial distributed SCM | |
| 2 | |
| 3 ;; Copyright (C) 2005, 2006 Bryan O'Sullivan | |
| 4 | |
| 5 ;; Author: Bryan O'Sullivan <bos@serpentine.com> | |
| 6 | |
| 7 ;; mercurial.el is free software; you can redistribute it and/or | |
| 8 ;; modify it under the terms of version 2 of the GNU General Public | |
| 9 ;; License as published by the Free Software Foundation. | |
| 10 | |
| 11 ;; mercurial.el is distributed in the hope that it will be useful, but | |
| 12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 14 ;; General Public License for more details. | |
| 15 | |
| 16 ;; You should have received a copy of the GNU General Public License | |
| 17 ;; along with mercurial.el, GNU Emacs, or XEmacs; see the file COPYING | |
| 18 ;; (`C-h C-l'). If not, write to the Free Software Foundation, Inc., | |
| 19 ;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
| 20 | |
| 21 ;;; Commentary: | |
| 22 | |
| 23 ;; mercurial.el builds upon Emacs's VC mode to provide flexible | |
| 24 ;; integration with the Mercurial distributed SCM tool. | |
| 25 | |
| 26 ;; To get going as quickly as possible, load mercurial.el into Emacs and | |
| 27 ;; type `C-c h h'; this runs hg-help-overview, which prints a helpful | |
| 28 ;; usage overview. | |
| 29 | |
| 30 ;; Much of the inspiration for mercurial.el comes from Rajesh | |
| 31 ;; Vaidheeswarran's excellent p4.el, which does an admirably thorough | |
| 32 ;; job for the commercial Perforce SCM product. In fact, substantial | |
| 33 ;; chunks of code are adapted from p4.el. | |
| 34 | |
| 35 ;; This code has been developed under XEmacs 21.5, and may not work as | |
| 36 ;; well under GNU Emacs (albeit tested under 21.4). Patches to | |
| 37 ;; enhance the portability of this code, fix bugs, and add features | |
| 38 ;; are most welcome. | |
| 39 | |
| 40 ;; As of version 22.3, GNU Emacs's VC mode has direct support for | |
| 41 ;; Mercurial, so this package may not prove as useful there. | |
| 42 | |
| 43 ;; Please send problem reports and suggestions to bos@serpentine.com. | |
| 44 | |
| 45 | |
| 46 ;;; Code: | |
| 47 | |
| 48 (eval-when-compile (require 'cl)) | |
| 49 (require 'diff-mode) | |
| 50 (require 'easymenu) | |
| 51 (require 'executable) | |
| 52 (require 'vc) | |
| 53 | |
| 54 (defmacro hg-feature-cond (&rest clauses) | |
| 55 "Test CLAUSES for feature at compile time. | |
| 56 Each clause is (FEATURE BODY...)." | |
| 57 (dolist (x clauses) | |
| 58 (let ((feature (car x)) | |
| 59 (body (cdr x))) | |
| 60 (when (or (eq feature t) | |
| 61 (featurep feature)) | |
| 62 (return (cons 'progn body)))))) | |
| 63 | |
| 64 | |
| 65 ;;; XEmacs has view-less, while GNU Emacs has view. Joy. | |
| 66 | |
| 67 (hg-feature-cond | |
| 68 (xemacs (require 'view-less)) | |
| 69 (t (require 'view))) | |
| 70 | |
| 71 | |
| 72 ;;; Variables accessible through the custom system. | |
| 73 | |
| 74 (defgroup mercurial nil | |
| 75 "Mercurial distributed SCM." | |
| 76 :group 'tools) | |
| 77 | |
| 78 (defcustom hg-binary | |
| 79 (or (executable-find "hg") | |
| 80 (dolist (path '("~/bin/hg" "/usr/bin/hg" "/usr/local/bin/hg")) | |
| 81 (when (file-executable-p path) | |
| 82 (return path)))) | |
| 83 "The path to Mercurial's hg executable." | |
| 84 :type '(file :must-match t) | |
| 85 :group 'mercurial) | |
| 86 | |
| 87 (defcustom hg-mode-hook nil | |
| 88 "Hook run when a buffer enters hg-mode." | |
| 89 :type 'sexp | |
| 90 :group 'mercurial) | |
| 91 | |
| 92 (defcustom hg-commit-mode-hook nil | |
| 93 "Hook run when a buffer is created to prepare a commit." | |
| 94 :type 'sexp | |
| 95 :group 'mercurial) | |
| 96 | |
| 97 (defcustom hg-pre-commit-hook nil | |
| 98 "Hook run before a commit is performed. | |
| 99 If you want to prevent the commit from proceeding, raise an error." | |
| 100 :type 'sexp | |
| 101 :group 'mercurial) | |
| 102 | |
| 103 (defcustom hg-log-mode-hook nil | |
| 104 "Hook run after a buffer is filled with log information." | |
| 105 :type 'sexp | |
| 106 :group 'mercurial) | |
| 107 | |
| 108 (defcustom hg-global-prefix "\C-ch" | |
| 109 "The global prefix for Mercurial keymap bindings." | |
| 110 :type 'sexp | |
| 111 :group 'mercurial) | |
| 112 | |
| 113 (defcustom hg-commit-allow-empty-message nil | |
| 114 "Whether to allow changes to be committed with empty descriptions." | |
| 115 :type 'boolean | |
| 116 :group 'mercurial) | |
| 117 | |
| 118 (defcustom hg-commit-allow-empty-file-list nil | |
| 119 "Whether to allow changes to be committed without any modified files." | |
| 120 :type 'boolean | |
| 121 :group 'mercurial) | |
| 122 | |
| 123 (defcustom hg-rev-completion-limit 100 | |
| 124 "The maximum number of revisions that hg-read-rev will offer to complete. | |
| 125 This affects memory usage and performance when prompting for revisions | |
| 126 in a repository with a lot of history." | |
| 127 :type 'integer | |
| 128 :group 'mercurial) | |
| 129 | |
| 130 (defcustom hg-log-limit 50 | |
| 131 "The maximum number of revisions that hg-log will display." | |
| 132 :type 'integer | |
| 133 :group 'mercurial) | |
| 134 | |
| 135 (defcustom hg-update-modeline t | |
| 136 "Whether to update the modeline with the status of a file after every save. | |
| 137 Set this to nil on platforms with poor process management, such as Windows." | |
| 138 :type 'boolean | |
| 139 :group 'mercurial) | |
| 140 | |
| 141 (defcustom hg-incoming-repository "default" | |
| 142 "The repository from which changes are pulled from by default. | |
| 143 This should be a symbolic repository name, since it is used for all | |
| 144 repository-related commands." | |
| 145 :type 'string | |
| 146 :group 'mercurial) | |
| 147 | |
| 148 (defcustom hg-outgoing-repository "default-push" | |
| 149 "The repository to which changes are pushed to by default. | |
| 150 This should be a symbolic repository name, since it is used for all | |
| 151 repository-related commands." | |
| 152 :type 'string | |
| 153 :group 'mercurial) | |
| 154 | |
| 155 | |
| 156 ;;; Other variables. | |
| 157 | |
| 158 (defvar hg-mode nil | |
| 159 "Is this file managed by Mercurial?") | |
| 160 (make-variable-buffer-local 'hg-mode) | |
| 161 (put 'hg-mode 'permanent-local t) | |
| 162 | |
| 163 (defvar hg-status nil) | |
| 164 (make-variable-buffer-local 'hg-status) | |
| 165 (put 'hg-status 'permanent-local t) | |
| 166 | |
| 167 (defvar hg-prev-buffer nil) | |
| 168 (make-variable-buffer-local 'hg-prev-buffer) | |
| 169 (put 'hg-prev-buffer 'permanent-local t) | |
| 170 | |
| 171 (defvar hg-root nil) | |
| 172 (make-variable-buffer-local 'hg-root) | |
| 173 (put 'hg-root 'permanent-local t) | |
| 174 | |
| 175 (defvar hg-view-mode nil) | |
| 176 (make-variable-buffer-local 'hg-view-mode) | |
| 177 (put 'hg-view-mode 'permanent-local t) | |
| 178 | |
| 179 (defvar hg-view-file-name nil) | |
| 180 (make-variable-buffer-local 'hg-view-file-name) | |
| 181 (put 'hg-view-file-name 'permanent-local t) | |
| 182 | |
| 183 (defvar hg-output-buffer-name "*Hg*" | |
| 184 "The name to use for Mercurial output buffers.") | |
| 185 | |
| 186 (defvar hg-file-history nil) | |
| 187 (defvar hg-repo-history nil) | |
| 188 (defvar hg-rev-history nil) | |
| 189 (defvar hg-repo-completion-table nil) ; shut up warnings | |
| 190 | |
| 191 | |
| 192 ;;; Random constants. | |
| 193 | |
| 194 (defconst hg-commit-message-start | |
| 195 "--- Enter your commit message. Type `C-c C-c' to commit. ---\n") | |
| 196 | |
| 197 (defconst hg-commit-message-end | |
| 198 "--- Files in bold will be committed. Click to toggle selection. ---\n") | |
| 199 | |
| 200 (defconst hg-state-alist | |
| 201 '((?M . modified) | |
| 202 (?A . added) | |
| 203 (?R . removed) | |
| 204 (?! . deleted) | |
| 205 (?C . normal) | |
| 206 (?I . ignored) | |
| 207 (?? . nil))) | |
| 208 | |
| 209 ;;; hg-mode keymap. | |
| 210 | |
| 211 (defvar hg-prefix-map | |
| 212 (let ((map (make-sparse-keymap))) | |
| 213 (hg-feature-cond (xemacs (set-keymap-name map 'hg-prefix-map))) ; XEmacs | |
| 214 (set-keymap-parent map vc-prefix-map) | |
| 215 (define-key map "=" 'hg-diff) | |
| 216 (define-key map "c" 'hg-undo) | |
| 217 (define-key map "g" 'hg-annotate) | |
| 218 (define-key map "i" 'hg-add) | |
| 219 (define-key map "l" 'hg-log) | |
| 220 (define-key map "n" 'hg-commit-start) | |
| 221 ;; (define-key map "r" 'hg-update) | |
| 222 (define-key map "u" 'hg-revert-buffer) | |
| 223 (define-key map "~" 'hg-version-other-window) | |
| 224 map) | |
| 225 "This keymap overrides some default vc-mode bindings.") | |
| 226 | |
| 227 (defvar hg-mode-map | |
| 228 (let ((map (make-sparse-keymap))) | |
| 229 (define-key map "\C-xv" hg-prefix-map) | |
| 230 map)) | |
| 231 | |
| 232 (add-minor-mode 'hg-mode 'hg-mode hg-mode-map) | |
| 233 | |
| 234 | |
| 235 ;;; Global keymap. | |
| 236 | |
| 237 (defvar hg-global-map | |
| 238 (let ((map (make-sparse-keymap))) | |
| 239 (define-key map "," 'hg-incoming) | |
| 240 (define-key map "." 'hg-outgoing) | |
| 241 (define-key map "<" 'hg-pull) | |
| 242 (define-key map "=" 'hg-diff-repo) | |
| 243 (define-key map ">" 'hg-push) | |
| 244 (define-key map "?" 'hg-help-overview) | |
| 245 (define-key map "A" 'hg-addremove) | |
| 246 (define-key map "U" 'hg-revert) | |
| 247 (define-key map "a" 'hg-add) | |
| 248 (define-key map "c" 'hg-commit-start) | |
| 249 (define-key map "f" 'hg-forget) | |
| 250 (define-key map "h" 'hg-help-overview) | |
| 251 (define-key map "i" 'hg-init) | |
| 252 (define-key map "l" 'hg-log-repo) | |
| 253 (define-key map "r" 'hg-root) | |
| 254 (define-key map "s" 'hg-status) | |
| 255 (define-key map "u" 'hg-update) | |
| 256 map)) | |
| 257 | |
| 258 (global-set-key hg-global-prefix hg-global-map) | |
| 259 | |
| 260 ;;; View mode keymap. | |
| 261 | |
| 262 (defvar hg-view-mode-map | |
| 263 (let ((map (make-sparse-keymap))) | |
| 264 (hg-feature-cond (xemacs (set-keymap-name map 'hg-view-mode-map))) ; XEmacs | |
| 265 (define-key map (hg-feature-cond (xemacs [button2]) | |
| 266 (t [mouse-2])) | |
| 267 'hg-buffer-mouse-clicked) | |
| 268 map)) | |
| 269 | |
| 270 (add-minor-mode 'hg-view-mode "" hg-view-mode-map) | |
| 271 | |
| 272 | |
| 273 ;;; Commit mode keymaps. | |
| 274 | |
| 275 (defvar hg-commit-mode-map | |
| 276 (let ((map (make-sparse-keymap))) | |
| 277 (define-key map "\C-c\C-c" 'hg-commit-finish) | |
| 278 (define-key map "\C-c\C-k" 'hg-commit-kill) | |
| 279 (define-key map "\C-xv=" 'hg-diff-repo) | |
| 280 map)) | |
| 281 | |
| 282 (defvar hg-commit-mode-file-map | |
| 283 (let ((map (make-sparse-keymap))) | |
| 284 (define-key map (hg-feature-cond (xemacs [button2]) | |
| 285 (t [mouse-2])) | |
| 286 'hg-commit-mouse-clicked) | |
| 287 (define-key map " " 'hg-commit-toggle-file) | |
| 288 (define-key map "\r" 'hg-commit-toggle-file) | |
| 289 map)) | |
| 290 | |
| 291 | |
| 292 ;;; Convenience functions. | |
| 293 | |
| 294 (defsubst hg-binary () | |
| 295 (if hg-binary | |
| 296 hg-binary | |
| 297 (error "No `hg' executable found!"))) | |
| 298 | |
| 299 (defsubst hg-replace-in-string (str regexp newtext &optional literal) | |
| 300 "Replace all matches in STR for REGEXP with NEWTEXT string. | |
| 301 Return the new string. Optional LITERAL non-nil means do a literal | |
| 302 replacement. | |
| 303 | |
| 304 This function bridges yet another pointless impedance gap between | |
| 305 XEmacs and GNU Emacs." | |
| 306 (hg-feature-cond | |
| 307 (xemacs (replace-in-string str regexp newtext literal)) | |
| 308 (t (replace-regexp-in-string regexp newtext str nil literal)))) | |
| 309 | |
| 310 (defsubst hg-strip (str) | |
| 311 "Strip leading and trailing blank lines from a string." | |
| 312 (hg-replace-in-string (hg-replace-in-string str "[\r\n][ \t\r\n]*\\'" "") | |
| 313 "\\`[ \t\r\n]*[\r\n]" "")) | |
| 314 | |
| 315 (defsubst hg-chomp (str) | |
| 316 "Strip trailing newlines from a string." | |
| 317 (hg-replace-in-string str "[\r\n]+\\'" "")) | |
| 318 | |
| 319 (defun hg-run-command (command &rest args) | |
| 320 "Run the shell command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT). | |
| 321 The list ARGS contains a list of arguments to pass to the command." | |
| 322 (let* (exit-code | |
| 323 (output | |
| 324 (with-output-to-string | |
| 325 (with-current-buffer | |
| 326 standard-output | |
| 327 (setq exit-code | |
| 328 (apply 'call-process command nil t nil args)))))) | |
| 329 (cons exit-code output))) | |
| 330 | |
| 331 (defun hg-run (command &rest args) | |
| 332 "Run the Mercurial command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT)." | |
| 333 (apply 'hg-run-command (hg-binary) command args)) | |
| 334 | |
| 335 (defun hg-run0 (command &rest args) | |
| 336 "Run the Mercurial command COMMAND, returning its output. | |
| 337 If the command does not exit with a zero status code, raise an error." | |
| 338 (let ((res (apply 'hg-run-command (hg-binary) command args))) | |
| 339 (if (not (eq (car res) 0)) | |
| 340 (error "Mercurial command failed %s - exit code %s" | |
| 341 (cons command args) | |
| 342 (car res)) | |
| 343 (cdr res)))) | |
| 344 | |
| 345 (defmacro hg-do-across-repo (path &rest body) | |
| 346 (let ((root-name (make-symbol "root-")) | |
| 347 (buf-name (make-symbol "buf-"))) | |
| 348 `(let ((,root-name (hg-root ,path))) | |
| 349 (save-excursion | |
| 350 (dolist (,buf-name (buffer-list)) | |
| 351 (set-buffer ,buf-name) | |
| 352 (when (and hg-status (equal (hg-root buffer-file-name) ,root-name)) | |
| 353 ,@body)))))) | |
| 354 | |
| 355 (put 'hg-do-across-repo 'lisp-indent-function 1) | |
| 356 | |
| 357 (defun hg-sync-buffers (path) | |
| 358 "Sync buffers visiting PATH with their on-disk copies. | |
| 359 If PATH is not being visited, but is under the repository root, sync | |
| 360 all buffers visiting files in the repository." | |
| 361 (let ((buf (find-buffer-visiting path))) | |
| 362 (if buf | |
| 363 (with-current-buffer buf | |
| 364 (vc-buffer-sync)) | |
| 365 (hg-do-across-repo path | |
| 366 (vc-buffer-sync))))) | |
| 367 | |
| 368 (defun hg-buffer-commands (pnt) | |
| 369 "Use the properties of a character to do something sensible." | |
| 370 (interactive "d") | |
| 371 (let ((rev (get-char-property pnt 'rev)) | |
| 372 (file (get-char-property pnt 'file))) | |
| 373 (cond | |
| 374 (file | |
| 375 (find-file-other-window file)) | |
| 376 (rev | |
| 377 (hg-diff hg-view-file-name rev rev)) | |
| 378 ((message "I don't know how to do that yet"))))) | |
| 379 | |
| 380 (defsubst hg-event-point (event) | |
| 381 "Return the character position of the mouse event EVENT." | |
| 382 (hg-feature-cond (xemacs (event-point event)) | |
| 383 (t (posn-point (event-start event))))) | |
| 384 | |
| 385 (defsubst hg-event-window (event) | |
| 386 "Return the window over which mouse event EVENT occurred." | |
| 387 (hg-feature-cond (xemacs (event-window event)) | |
| 388 (t (posn-window (event-start event))))) | |
| 389 | |
| 390 (defun hg-buffer-mouse-clicked (event) | |
| 391 "Translate the mouse clicks in a HG log buffer to character events. | |
| 392 These are then handed off to `hg-buffer-commands'. | |
| 393 | |
| 394 Handle frickin' frackin' gratuitous event-related incompatibilities." | |
| 395 (interactive "e") | |
| 396 (select-window (hg-event-window event)) | |
| 397 (hg-buffer-commands (hg-event-point event))) | |
| 398 | |
| 399 (defsubst hg-abbrev-file-name (file) | |
| 400 "Portable wrapper around abbreviate-file-name." | |
| 401 (hg-feature-cond (xemacs (abbreviate-file-name file t)) | |
| 402 (t (abbreviate-file-name file)))) | |
| 403 | |
| 404 (defun hg-read-file-name (&optional prompt default) | |
| 405 "Read a file or directory name, or a pattern, to use with a command." | |
| 406 (save-excursion | |
| 407 (while hg-prev-buffer | |
| 408 (set-buffer hg-prev-buffer)) | |
| 409 (let ((path (or default | |
| 410 (buffer-file-name) | |
| 411 (expand-file-name default-directory)))) | |
| 412 (if (or (not path) current-prefix-arg) | |
| 413 (expand-file-name | |
| 414 (eval (list* 'read-file-name | |
| 415 (format "File, directory or pattern%s: " | |
| 416 (or prompt "")) | |
| 417 (and path (file-name-directory path)) | |
| 418 nil nil | |
| 419 (and path (file-name-nondirectory path)) | |
| 420 (hg-feature-cond | |
| 421 (xemacs (cons (quote 'hg-file-history) nil)) | |
| 422 (t nil))))) | |
| 423 path)))) | |
| 424 | |
| 425 (defun hg-read-number (&optional prompt default) | |
| 426 "Read a integer value." | |
| 427 (save-excursion | |
| 428 (if (or (not default) current-prefix-arg) | |
| 429 (string-to-number | |
| 430 (eval (list* 'read-string | |
| 431 (or prompt "") | |
| 432 (if default (cons (format "%d" default) nil) nil)))) | |
| 433 default))) | |
| 434 | |
| 435 (defun hg-read-config () | |
| 436 "Return an alist of (key . value) pairs of Mercurial config data. | |
| 437 Each key is of the form (section . name)." | |
| 438 (let (items) | |
| 439 (dolist (line (split-string (hg-chomp (hg-run0 "debugconfig")) "\n") items) | |
| 440 (string-match "^\\([^=]*\\)=\\(.*\\)" line) | |
| 441 (let* ((left (substring line (match-beginning 1) (match-end 1))) | |
| 442 (right (substring line (match-beginning 2) (match-end 2))) | |
| 443 (key (split-string left "\\.")) | |
| 444 (value (hg-replace-in-string right "\\\\n" "\n" t))) | |
| 445 (setq items (cons (cons (cons (car key) (cadr key)) value) items)))))) | |
| 446 | |
| 447 (defun hg-config-section (section config) | |
| 448 "Return an alist of (name . value) pairs for SECTION of CONFIG." | |
| 449 (let (items) | |
| 450 (dolist (item config items) | |
| 451 (when (equal (caar item) section) | |
| 452 (setq items (cons (cons (cdar item) (cdr item)) items)))))) | |
| 453 | |
| 454 (defun hg-string-starts-with (sub str) | |
| 455 "Indicate whether string STR starts with the substring or character SUB." | |
| 456 (if (not (stringp sub)) | |
| 457 (and (> (length str) 0) (equal (elt str 0) sub)) | |
| 458 (let ((sub-len (length sub))) | |
| 459 (and (<= sub-len (length str)) | |
| 460 (string= sub (substring str 0 sub-len)))))) | |
| 461 | |
| 462 (defun hg-complete-repo (string predicate all) | |
| 463 "Attempt to complete a repository name. | |
| 464 We complete on either symbolic names from Mercurial's config or real | |
| 465 directory names from the file system. We do not penalise URLs." | |
| 466 (or (if all | |
| 467 (all-completions string hg-repo-completion-table predicate) | |
| 468 (try-completion string hg-repo-completion-table predicate)) | |
| 469 (let* ((str (expand-file-name string)) | |
| 470 (dir (file-name-directory str)) | |
| 471 (file (file-name-nondirectory str))) | |
| 472 (if all | |
| 473 (let (completions) | |
| 474 (dolist (name (delete "./" (file-name-all-completions file dir)) | |
| 475 completions) | |
| 476 (let ((path (concat dir name))) | |
| 477 (when (file-directory-p path) | |
| 478 (setq completions (cons name completions)))))) | |
| 479 (let ((comp (file-name-completion file dir))) | |
| 480 (if comp | |
| 481 (hg-abbrev-file-name (concat dir comp)))))))) | |
| 482 | |
| 483 (defun hg-read-repo-name (&optional prompt initial-contents default) | |
| 484 "Read the location of a repository." | |
| 485 (save-excursion | |
| 486 (while hg-prev-buffer | |
| 487 (set-buffer hg-prev-buffer)) | |
| 488 (let (hg-repo-completion-table) | |
| 489 (if current-prefix-arg | |
| 490 (progn | |
| 491 (dolist (path (hg-config-section "paths" (hg-read-config))) | |
| 492 (setq hg-repo-completion-table | |
| 493 (cons (cons (car path) t) hg-repo-completion-table)) | |
| 494 (unless (hg-string-starts-with (hg-feature-cond | |
| 495 (xemacs directory-sep-char) | |
| 496 (t ?/)) | |
| 497 (cdr path)) | |
| 498 (setq hg-repo-completion-table | |
| 499 (cons (cons (cdr path) t) hg-repo-completion-table)))) | |
| 500 (completing-read (format "Repository%s: " (or prompt "")) | |
| 501 'hg-complete-repo | |
| 502 nil | |
| 503 nil | |
| 504 initial-contents | |
| 505 'hg-repo-history | |
| 506 default)) | |
| 507 default)))) | |
| 508 | |
| 509 (defun hg-read-rev (&optional prompt default) | |
| 510 "Read a revision or tag, offering completions." | |
| 511 (save-excursion | |
| 512 (while hg-prev-buffer | |
| 513 (set-buffer hg-prev-buffer)) | |
| 514 (let ((rev (or default "tip"))) | |
| 515 (if current-prefix-arg | |
| 516 (let ((revs (split-string | |
| 517 (hg-chomp | |
| 518 (hg-run0 "-q" "log" "-l" | |
| 519 (format "%d" hg-rev-completion-limit))) | |
| 520 "[\n:]"))) | |
| 521 (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n")) | |
| 522 (setq revs (cons (car (split-string line "\\s-")) revs))) | |
| 523 (completing-read (format "Revision%s (%s): " | |
| 524 (or prompt "") | |
| 525 (or default "tip")) | |
| 526 (mapcar (lambda (x) (cons x x)) revs) | |
| 527 nil | |
| 528 nil | |
| 529 nil | |
| 530 'hg-rev-history | |
| 531 (or default "tip"))) | |
| 532 rev)))) | |
| 533 | |
| 534 (defun hg-parents-for-mode-line (root) | |
| 535 "Format the parents of the working directory for the mode line." | |
| 536 (let ((parents (split-string (hg-chomp | |
| 537 (hg-run0 "--cwd" root "parents" "--template" | |
| 538 "{rev}\n")) "\n"))) | |
| 539 (mapconcat 'identity parents "+"))) | |
| 540 | |
| 541 (defun hg-buffers-visiting-repo (&optional path) | |
| 542 "Return a list of buffers visiting the repository containing PATH." | |
| 543 (let ((root-name (hg-root (or path (buffer-file-name)))) | |
| 544 bufs) | |
| 545 (save-excursion | |
| 546 (dolist (buf (buffer-list) bufs) | |
| 547 (set-buffer buf) | |
| 548 (let ((name (buffer-file-name))) | |
| 549 (when (and hg-status name (equal (hg-root name) root-name)) | |
| 550 (setq bufs (cons buf bufs)))))))) | |
| 551 | |
| 552 (defun hg-update-mode-lines (path) | |
| 553 "Update the mode lines of all buffers visiting the same repository as PATH." | |
| 554 (let* ((root (hg-root path)) | |
| 555 (parents (hg-parents-for-mode-line root))) | |
| 556 (save-excursion | |
| 557 (dolist (info (hg-path-status | |
| 558 root | |
| 559 (mapcar | |
| 560 (function | |
| 561 (lambda (buf) | |
| 562 (substring (buffer-file-name buf) (length root)))) | |
| 563 (hg-buffers-visiting-repo root)))) | |
| 564 (let* ((name (car info)) | |
| 565 (status (cdr info)) | |
| 566 (buf (find-buffer-visiting (concat root name)))) | |
| 567 (when buf | |
| 568 (set-buffer buf) | |
| 569 (hg-mode-line-internal status parents))))))) | |
| 570 | |
| 571 | |
| 572 ;;; View mode bits. | |
| 573 | |
| 574 (defun hg-exit-view-mode (buf) | |
| 575 "Exit from hg-view-mode. | |
| 576 We delete the current window if entering hg-view-mode split the | |
| 577 current frame." | |
| 578 (when (and (eq buf (current-buffer)) | |
| 579 (> (length (window-list)) 1)) | |
| 580 (delete-window)) | |
| 581 (when (buffer-live-p buf) | |
| 582 (kill-buffer buf))) | |
| 583 | |
| 584 (defun hg-view-mode (prev-buffer &optional file-name) | |
| 585 (goto-char (point-min)) | |
| 586 (set-buffer-modified-p nil) | |
| 587 (toggle-read-only t) | |
| 588 (hg-feature-cond (xemacs (view-minor-mode prev-buffer 'hg-exit-view-mode)) | |
| 589 (t (view-mode-enter nil 'hg-exit-view-mode))) | |
| 590 (setq hg-view-mode t) | |
| 591 (setq truncate-lines t) | |
| 592 (when file-name | |
| 593 (setq hg-view-file-name | |
| 594 (hg-abbrev-file-name file-name)))) | |
| 595 | |
| 596 (defun hg-file-status (file) | |
| 597 "Return status of FILE, or nil if FILE does not exist or is unmanaged." | |
| 598 (let* ((s (hg-run "status" file)) | |
| 599 (exit (car s)) | |
| 600 (output (cdr s))) | |
| 601 (if (= exit 0) | |
| 602 (let ((state (and (>= (length output) 2) | |
| 603 (= (aref output 1) ? ) | |
| 604 (assq (aref output 0) hg-state-alist)))) | |
| 605 (if state | |
| 606 (cdr state) | |
| 607 'normal))))) | |
| 608 | |
| 609 (defun hg-path-status (root paths) | |
| 610 "Return status of PATHS in repo ROOT as an alist. | |
| 611 Each entry is a pair (FILE-NAME . STATUS)." | |
| 612 (let ((s (apply 'hg-run "--cwd" root "status" "-marduc" paths)) | |
| 613 result) | |
| 614 (dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result)) | |
| 615 (let (state name) | |
| 616 (cond ((= (aref entry 1) ? ) | |
| 617 (setq state (assq (aref entry 0) hg-state-alist) | |
| 618 name (substring entry 2))) | |
| 619 ((string-match "\\(.*\\): " entry) | |
| 620 (setq name (match-string 1 entry)))) | |
| 621 (setq result (cons (cons name state) result)))))) | |
| 622 | |
| 623 (defmacro hg-view-output (args &rest body) | |
| 624 "Execute BODY in a clean buffer, then quickly display that buffer. | |
| 625 If the buffer contains one line, its contents are displayed in the | |
| 626 minibuffer. Otherwise, the buffer is displayed in view-mode. | |
| 627 ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is | |
| 628 the name of the buffer to create, and FILE is the name of the file | |
| 629 being viewed." | |
| 630 (let ((prev-buf (make-symbol "prev-buf-")) | |
| 631 (v-b-name (car args)) | |
| 632 (v-m-rest (cdr args))) | |
| 633 `(let ((view-buf-name ,v-b-name) | |
| 634 (,prev-buf (current-buffer))) | |
| 635 (get-buffer-create view-buf-name) | |
| 636 (kill-buffer view-buf-name) | |
| 637 (get-buffer-create view-buf-name) | |
| 638 (set-buffer view-buf-name) | |
| 639 (save-excursion | |
| 640 ,@body) | |
| 641 (case (count-lines (point-min) (point-max)) | |
| 642 ((0) | |
| 643 (kill-buffer view-buf-name) | |
| 644 (message "(No output)")) | |
| 645 ((1) | |
| 646 (let ((msg (hg-chomp (buffer-substring (point-min) (point-max))))) | |
| 647 (kill-buffer view-buf-name) | |
| 648 (message "%s" msg))) | |
| 649 (t | |
| 650 (pop-to-buffer view-buf-name) | |
| 651 (setq hg-prev-buffer ,prev-buf) | |
| 652 (hg-view-mode ,prev-buf ,@v-m-rest)))))) | |
| 653 | |
| 654 (put 'hg-view-output 'lisp-indent-function 1) | |
| 655 | |
| 656 ;;; Context save and restore across revert and other operations. | |
| 657 | |
| 658 (defun hg-position-context (pos) | |
| 659 "Return information to help find the given position again." | |
| 660 (let* ((end (min (point-max) (+ pos 98)))) | |
| 661 (list pos | |
| 662 (buffer-substring (max (point-min) (- pos 2)) end) | |
| 663 (- end pos)))) | |
| 664 | |
| 665 (defun hg-buffer-context () | |
| 666 "Return information to help restore a user's editing context. | |
| 667 This is useful across reverts and merges, where a context is likely | |
| 668 to have moved a little, but not really changed." | |
| 669 (let ((point-context (hg-position-context (point))) | |
| 670 (mark-context (let ((mark (mark-marker))) | |
| 671 (and mark | |
| 672 ;; make sure active mark | |
| 673 (marker-buffer mark) | |
| 674 (marker-position mark) | |
| 675 (hg-position-context mark))))) | |
| 676 (list point-context mark-context))) | |
| 677 | |
| 678 (defun hg-find-context (ctx) | |
| 679 "Attempt to find a context in the given buffer. | |
| 680 Always returns a valid, hopefully sane, position." | |
| 681 (let ((pos (nth 0 ctx)) | |
| 682 (str (nth 1 ctx)) | |
| 683 (fixup (nth 2 ctx))) | |
| 684 (save-excursion | |
| 685 (goto-char (max (point-min) (- pos 15000))) | |
| 686 (if (and (not (equal str "")) | |
| 687 (search-forward str nil t)) | |
| 688 (- (point) fixup) | |
| 689 (max pos (point-min)))))) | |
| 690 | |
| 691 (defun hg-restore-context (ctx) | |
| 692 "Attempt to restore the user's editing context." | |
| 693 (let ((point-context (nth 0 ctx)) | |
| 694 (mark-context (nth 1 ctx))) | |
| 695 (goto-char (hg-find-context point-context)) | |
| 696 (when mark-context | |
| 697 (set-mark (hg-find-context mark-context))))) | |
| 698 | |
| 699 | |
| 700 ;;; Hooks. | |
| 701 | |
| 702 (defun hg-mode-line-internal (status parents) | |
| 703 (setq hg-status status | |
| 704 hg-mode (and status (concat " Hg:" | |
| 705 parents | |
| 706 (cdr (assq status | |
| 707 '((normal . "") | |
| 708 (removed . "r") | |
| 709 (added . "a") | |
| 710 (deleted . "!") | |
| 711 (modified . "m")))))))) | |
| 712 | |
| 713 (defun hg-mode-line (&optional force) | |
| 714 "Update the modeline with the current status of a file. | |
| 715 An update occurs if optional argument FORCE is non-nil, | |
| 716 hg-update-modeline is non-nil, or we have not yet checked the state of | |
| 717 the file." | |
| 718 (let ((root (hg-root))) | |
| 719 (when (and root (or force hg-update-modeline (not hg-mode))) | |
| 720 (let ((status (hg-file-status buffer-file-name)) | |
| 721 (parents (hg-parents-for-mode-line root))) | |
| 722 (hg-mode-line-internal status parents) | |
| 723 status)))) | |
| 724 | |
| 725 (defun hg-mode (&optional toggle) | |
| 726 "Minor mode for Mercurial distributed SCM integration. | |
| 727 | |
| 728 The Mercurial mode user interface is based on that of VC mode, so if | |
| 729 you're already familiar with VC, the same keybindings and functions | |
| 730 will generally work. | |
| 731 | |
| 732 Below is a list of many common SCM tasks. In the list, `G/L\' | |
| 733 indicates whether a key binding is global (G) to a repository or | |
| 734 local (L) to a file. Many commands take a prefix argument. | |
| 735 | |
| 736 SCM Task G/L Key Binding Command Name | |
| 737 -------- --- ----------- ------------ | |
| 738 Help overview (what you are reading) G C-c h h hg-help-overview | |
| 739 | |
| 740 Tell Mercurial to manage a file G C-c h a hg-add | |
| 741 Commit changes to current file only L C-x v n hg-commit-start | |
| 742 Undo changes to file since commit L C-x v u hg-revert-buffer | |
| 743 | |
| 744 Diff file vs last checkin L C-x v = hg-diff | |
| 745 | |
| 746 View file change history L C-x v l hg-log | |
| 747 View annotated file L C-x v a hg-annotate | |
| 748 | |
| 749 Diff repo vs last checkin G C-c h = hg-diff-repo | |
| 750 View status of files in repo G C-c h s hg-status | |
| 751 Commit all changes G C-c h c hg-commit-start | |
| 752 | |
| 753 Undo all changes since last commit G C-c h U hg-revert | |
| 754 View repo change history G C-c h l hg-log-repo | |
| 755 | |
| 756 See changes that can be pulled G C-c h , hg-incoming | |
| 757 Pull changes G C-c h < hg-pull | |
| 758 Update working directory after pull G C-c h u hg-update | |
| 759 See changes that can be pushed G C-c h . hg-outgoing | |
| 760 Push changes G C-c h > hg-push" | |
| 761 (unless vc-make-backup-files | |
| 762 (set (make-local-variable 'backup-inhibited) t)) | |
| 763 (run-hooks 'hg-mode-hook)) | |
| 764 | |
| 765 (defun hg-find-file-hook () | |
| 766 (ignore-errors | |
| 767 (when (hg-mode-line) | |
| 768 (hg-mode)))) | |
| 769 | |
| 770 (add-hook 'find-file-hooks 'hg-find-file-hook) | |
| 771 | |
| 772 (defun hg-after-save-hook () | |
| 773 (ignore-errors | |
| 774 (let ((old-status hg-status)) | |
| 775 (hg-mode-line) | |
| 776 (if (and (not old-status) hg-status) | |
| 777 (hg-mode))))) | |
| 778 | |
| 779 (add-hook 'after-save-hook 'hg-after-save-hook) | |
| 780 | |
| 781 | |
| 782 ;;; User interface functions. | |
| 783 | |
| 784 (defun hg-help-overview () | |
| 785 "This is an overview of the Mercurial SCM mode for Emacs. | |
| 786 | |
| 787 You can find the source code, license (GPL v2), and credits for this | |
| 788 code by typing `M-x find-library mercurial RET'." | |
| 789 (interactive) | |
| 790 (hg-view-output ("Mercurial Help Overview") | |
| 791 (insert (documentation 'hg-help-overview)) | |
| 792 (let ((pos (point))) | |
| 793 (insert (documentation 'hg-mode)) | |
| 794 (goto-char pos) | |
| 795 (end-of-line 1) | |
| 796 (delete-region pos (point))) | |
| 797 (let ((hg-root-dir (hg-root))) | |
| 798 (if (not hg-root-dir) | |
| 799 (error "error: %s: directory is not part of a Mercurial repository." | |
| 800 default-directory) | |
| 801 (cd hg-root-dir))))) | |
| 802 | |
| 803 (defun hg-fix-paths () | |
| 804 "Fix paths reported by some Mercurial commands." | |
| 805 (save-excursion | |
| 806 (goto-char (point-min)) | |
| 807 (while (re-search-forward " \\.\\.." nil t) | |
| 808 (replace-match " " nil nil)))) | |
| 809 | |
| 810 (defun hg-add (path) | |
| 811 "Add PATH to the Mercurial repository on the next commit. | |
| 812 With a prefix argument, prompt for the path to add." | |
| 813 (interactive (list (hg-read-file-name " to add"))) | |
| 814 (let ((buf (current-buffer)) | |
| 815 (update (equal buffer-file-name path))) | |
| 816 (hg-view-output (hg-output-buffer-name) | |
| 817 (apply 'call-process (hg-binary) nil t nil (list "add" path)) | |
| 818 (hg-fix-paths) | |
| 819 (goto-char (point-min)) | |
| 820 (cd (hg-root path))) | |
| 821 (when update | |
| 822 (unless vc-make-backup-files | |
| 823 (set (make-local-variable 'backup-inhibited) t)) | |
| 824 (with-current-buffer buf | |
| 825 (hg-mode-line))))) | |
| 826 | |
| 827 (defun hg-addremove () | |
| 828 (interactive) | |
| 829 (error "not implemented")) | |
| 830 | |
| 831 (defun hg-annotate () | |
| 832 (interactive) | |
| 833 (error "not implemented")) | |
| 834 | |
| 835 (defun hg-commit-toggle-file (pos) | |
| 836 "Toggle whether or not the file at POS will be committed." | |
| 837 (interactive "d") | |
| 838 (save-excursion | |
| 839 (goto-char pos) | |
| 840 (let ((face (get-text-property pos 'face)) | |
| 841 (inhibit-read-only t) | |
| 842 bol) | |
| 843 (beginning-of-line) | |
| 844 (setq bol (+ (point) 4)) | |
| 845 (end-of-line) | |
| 846 (if (eq face 'bold) | |
| 847 (progn | |
| 848 (remove-text-properties bol (point) '(face nil)) | |
| 849 (message "%s will not be committed" | |
| 850 (buffer-substring bol (point)))) | |
| 851 (add-text-properties bol (point) '(face bold)) | |
| 852 (message "%s will be committed" | |
| 853 (buffer-substring bol (point))))))) | |
| 854 | |
| 855 (defun hg-commit-mouse-clicked (event) | |
| 856 "Toggle whether or not the file at POS will be committed." | |
| 857 (interactive "@e") | |
| 858 (hg-commit-toggle-file (hg-event-point event))) | |
| 859 | |
| 860 (defun hg-commit-kill () | |
| 861 "Kill the commit currently being prepared." | |
| 862 (interactive) | |
| 863 (when (or (not (buffer-modified-p)) (y-or-n-p "Really kill this commit? ")) | |
| 864 (let ((buf hg-prev-buffer)) | |
| 865 (kill-buffer nil) | |
| 866 (switch-to-buffer buf)))) | |
| 867 | |
| 868 (defun hg-commit-finish () | |
| 869 "Finish preparing a commit, and perform the actual commit. | |
| 870 The hook hg-pre-commit-hook is run before anything else is done. If | |
| 871 the commit message is empty and hg-commit-allow-empty-message is nil, | |
| 872 an error is raised. If the list of files to commit is empty and | |
| 873 hg-commit-allow-empty-file-list is nil, an error is raised." | |
| 874 (interactive) | |
| 875 (let ((root hg-root)) | |
| 876 (save-excursion | |
| 877 (run-hooks 'hg-pre-commit-hook) | |
| 878 (goto-char (point-min)) | |
| 879 (search-forward hg-commit-message-start) | |
| 880 (let (message files) | |
| 881 (let ((start (point))) | |
| 882 (goto-char (point-max)) | |
| 883 (search-backward hg-commit-message-end) | |
| 884 (setq message (hg-strip (buffer-substring start (point))))) | |
| 885 (when (and (= (length message) 0) | |
| 886 (not hg-commit-allow-empty-message)) | |
| 887 (error "Cannot proceed - commit message is empty")) | |
| 888 (forward-line 1) | |
| 889 (beginning-of-line) | |
| 890 (while (< (point) (point-max)) | |
| 891 (let ((pos (+ (point) 4))) | |
| 892 (end-of-line) | |
| 893 (when (eq (get-text-property pos 'face) 'bold) | |
| 894 (end-of-line) | |
| 895 (setq files (cons (buffer-substring pos (point)) files)))) | |
| 896 (forward-line 1)) | |
| 897 (when (and (= (length files) 0) | |
| 898 (not hg-commit-allow-empty-file-list)) | |
| 899 (error "Cannot proceed - no files to commit")) | |
| 900 (setq message (concat message "\n")) | |
| 901 (apply 'hg-run0 "--cwd" hg-root "commit" "-m" message files)) | |
| 902 (let ((buf hg-prev-buffer)) | |
| 903 (kill-buffer nil) | |
| 904 (switch-to-buffer buf)) | |
| 905 (hg-update-mode-lines root)))) | |
| 906 | |
| 907 (defun hg-commit-mode () | |
| 908 "Mode for describing a commit of changes to a Mercurial repository. | |
| 909 This involves two actions: describing the changes with a commit | |
| 910 message, and choosing the files to commit. | |
| 911 | |
| 912 To describe the commit, simply type some text in the designated area. | |
| 913 | |
| 914 By default, all modified, added and removed files are selected for | |
| 915 committing. Files that will be committed are displayed in bold face\; | |
| 916 those that will not are displayed in normal face. | |
| 917 | |
| 918 To toggle whether a file will be committed, move the cursor over a | |
| 919 particular file and hit space or return. Alternatively, middle click | |
| 920 on the file. | |
| 921 | |
| 922 Key bindings | |
| 923 ------------ | |
| 924 \\[hg-commit-finish] proceed with commit | |
| 925 \\[hg-commit-kill] kill commit | |
| 926 | |
| 927 \\[hg-diff-repo] view diff of pending changes" | |
| 928 (interactive) | |
| 929 (use-local-map hg-commit-mode-map) | |
| 930 (set-syntax-table text-mode-syntax-table) | |
| 931 (setq local-abbrev-table text-mode-abbrev-table | |
| 932 major-mode 'hg-commit-mode | |
| 933 mode-name "Hg-Commit") | |
| 934 (set-buffer-modified-p nil) | |
| 935 (setq buffer-undo-list nil) | |
| 936 (run-hooks 'text-mode-hook 'hg-commit-mode-hook)) | |
| 937 | |
| 938 (defun hg-commit-start () | |
| 939 "Prepare a commit of changes to the repository containing the current file." | |
| 940 (interactive) | |
| 941 (while hg-prev-buffer | |
| 942 (set-buffer hg-prev-buffer)) | |
| 943 (let ((root (hg-root)) | |
| 944 (prev-buffer (current-buffer)) | |
| 945 modified-files) | |
| 946 (unless root | |
| 947 (error "Cannot commit outside a repository!")) | |
| 948 (hg-sync-buffers root) | |
| 949 (setq modified-files (hg-chomp (hg-run0 "--cwd" root "status" "-arm"))) | |
| 950 (when (and (= (length modified-files) 0) | |
| 951 (not hg-commit-allow-empty-file-list)) | |
| 952 (error "No pending changes to commit")) | |
| 953 (let* ((buf-name (format "*Mercurial: Commit %s*" root))) | |
| 954 (pop-to-buffer (get-buffer-create buf-name)) | |
| 955 (when (= (point-min) (point-max)) | |
| 956 (set (make-local-variable 'hg-root) root) | |
| 957 (setq hg-prev-buffer prev-buffer) | |
| 958 (insert "\n") | |
| 959 (let ((bol (point))) | |
| 960 (insert hg-commit-message-end) | |
| 961 (add-text-properties bol (point) '(face bold-italic))) | |
| 962 (let ((file-area (point))) | |
| 963 (insert modified-files) | |
| 964 (goto-char file-area) | |
| 965 (while (< (point) (point-max)) | |
| 966 (let ((bol (point))) | |
| 967 (forward-char 1) | |
| 968 (insert " ") | |
| 969 (end-of-line) | |
| 970 (add-text-properties (+ bol 4) (point) | |
| 971 '(face bold mouse-face highlight))) | |
| 972 (forward-line 1)) | |
| 973 (goto-char file-area) | |
| 974 (add-text-properties (point) (point-max) | |
| 975 `(keymap ,hg-commit-mode-file-map)) | |
| 976 (goto-char (point-min)) | |
| 977 (insert hg-commit-message-start) | |
| 978 (add-text-properties (point-min) (point) '(face bold-italic)) | |
| 979 (insert "\n\n") | |
| 980 (forward-line -1) | |
| 981 (save-excursion | |
| 982 (goto-char (point-max)) | |
| 983 (search-backward hg-commit-message-end) | |
| 984 (add-text-properties (match-beginning 0) (point-max) | |
| 985 '(read-only t)) | |
| 986 (goto-char (point-min)) | |
| 987 (search-forward hg-commit-message-start) | |
| 988 (add-text-properties (match-beginning 0) (match-end 0) | |
| 989 '(read-only t))) | |
| 990 (hg-commit-mode) | |
| 991 (cd root)))))) | |
| 992 | |
| 993 (defun hg-diff (path &optional rev1 rev2) | |
| 994 "Show the differences between REV1 and REV2 of PATH. | |
| 995 When called interactively, the default behaviour is to treat REV1 as | |
| 996 the \"parent\" revision, REV2 as the current edited version of the file, and | |
| 997 PATH as the file edited in the current buffer. | |
| 998 With a prefix argument, prompt for all of these." | |
| 999 (interactive (list (hg-read-file-name " to diff") | |
| 1000 (let ((rev1 (hg-read-rev " to start with" 'parent))) | |
| 1001 (and (not (eq rev1 'parent)) rev1)) | |
| 1002 (let ((rev2 (hg-read-rev " to end with" 'working-dir))) | |
| 1003 (and (not (eq rev2 'working-dir)) rev2)))) | |
| 1004 (hg-sync-buffers path) | |
| 1005 (let ((a-path (hg-abbrev-file-name path)) | |
| 1006 ;; none revision is specified explicitly | |
| 1007 (none (and (not rev1) (not rev2))) | |
| 1008 ;; only one revision is specified explicitly | |
| 1009 (one (or (and (or (equal rev1 rev2) (not rev2)) rev1) | |
| 1010 (and (not rev1) rev2))) | |
| 1011 diff) | |
| 1012 (hg-view-output ((cond | |
| 1013 (none | |
| 1014 (format "Mercurial: Diff against parent of %s" a-path)) | |
| 1015 (one | |
| 1016 (format "Mercurial: Diff of rev %s of %s" one a-path)) | |
| 1017 (t | |
| 1018 (format "Mercurial: Diff from rev %s to %s of %s" | |
| 1019 rev1 rev2 a-path)))) | |
| 1020 (cond | |
| 1021 (none | |
| 1022 (call-process (hg-binary) nil t nil "diff" path)) | |
| 1023 (one | |
| 1024 (call-process (hg-binary) nil t nil "diff" "-r" one path)) | |
| 1025 (t | |
| 1026 (call-process (hg-binary) nil t nil "diff" "-r" rev1 "-r" rev2 path))) | |
| 1027 (diff-mode) | |
| 1028 (setq diff (not (= (point-min) (point-max)))) | |
| 1029 (font-lock-fontify-buffer) | |
| 1030 (cd (hg-root path))) | |
| 1031 diff)) | |
| 1032 | |
| 1033 (defun hg-diff-repo (path &optional rev1 rev2) | |
| 1034 "Show the differences between REV1 and REV2 of repository containing PATH. | |
| 1035 When called interactively, the default behaviour is to treat REV1 as | |
| 1036 the \"parent\" revision, REV2 as the current edited version of the file, and | |
| 1037 PATH as the `hg-root' of the current buffer. | |
| 1038 With a prefix argument, prompt for all of these." | |
| 1039 (interactive (list (hg-read-file-name " to diff") | |
| 1040 (let ((rev1 (hg-read-rev " to start with" 'parent))) | |
| 1041 (and (not (eq rev1 'parent)) rev1)) | |
| 1042 (let ((rev2 (hg-read-rev " to end with" 'working-dir))) | |
| 1043 (and (not (eq rev2 'working-dir)) rev2)))) | |
| 1044 (hg-diff (hg-root path) rev1 rev2)) | |
| 1045 | |
| 1046 (defun hg-forget (path) | |
| 1047 "Lose track of PATH, which has been added, but not yet committed. | |
| 1048 This will prevent the file from being incorporated into the Mercurial | |
| 1049 repository on the next commit. | |
| 1050 With a prefix argument, prompt for the path to forget." | |
| 1051 (interactive (list (hg-read-file-name " to forget"))) | |
| 1052 (let ((buf (current-buffer)) | |
| 1053 (update (equal buffer-file-name path))) | |
| 1054 (hg-view-output (hg-output-buffer-name) | |
| 1055 (apply 'call-process (hg-binary) nil t nil (list "forget" path)) | |
| 1056 ;; "hg forget" shows pathes relative NOT TO ROOT BUT TO REPOSITORY | |
| 1057 (hg-fix-paths) | |
| 1058 (goto-char (point-min)) | |
| 1059 (cd (hg-root path))) | |
| 1060 (when update | |
| 1061 (with-current-buffer buf | |
| 1062 (when (local-variable-p 'backup-inhibited) | |
| 1063 (kill-local-variable 'backup-inhibited)) | |
| 1064 (hg-mode-line))))) | |
| 1065 | |
| 1066 (defun hg-incoming (&optional repo) | |
| 1067 "Display changesets present in REPO that are not present locally." | |
| 1068 (interactive (list (hg-read-repo-name " where changes would come from"))) | |
| 1069 (hg-view-output ((format "Mercurial: Incoming from %s to %s" | |
| 1070 (hg-abbrev-file-name (hg-root)) | |
| 1071 (hg-abbrev-file-name | |
| 1072 (or repo hg-incoming-repository)))) | |
| 1073 (call-process (hg-binary) nil t nil "incoming" | |
| 1074 (or repo hg-incoming-repository)) | |
| 1075 (hg-log-mode) | |
| 1076 (cd (hg-root)))) | |
| 1077 | |
| 1078 (defun hg-init () | |
| 1079 (interactive) | |
| 1080 (error "not implemented")) | |
| 1081 | |
| 1082 (defun hg-log-mode () | |
| 1083 "Mode for viewing a Mercurial change log." | |
| 1084 (goto-char (point-min)) | |
| 1085 (when (looking-at "^searching for changes.*$") | |
| 1086 (delete-region (match-beginning 0) (match-end 0))) | |
| 1087 (run-hooks 'hg-log-mode-hook)) | |
| 1088 | |
| 1089 (defun hg-log (path &optional rev1 rev2 log-limit) | |
| 1090 "Display the revision history of PATH. | |
| 1091 History is displayed between REV1 and REV2. | |
| 1092 Number of displayed changesets is limited to LOG-LIMIT. | |
| 1093 REV1 defaults to the tip, while REV2 defaults to 0. | |
| 1094 LOG-LIMIT defaults to `hg-log-limit'. | |
| 1095 With a prefix argument, prompt for each parameter." | |
| 1096 (interactive (list (hg-read-file-name " to log") | |
| 1097 (hg-read-rev " to start with" | |
| 1098 "tip") | |
| 1099 (hg-read-rev " to end with" | |
| 1100 "0") | |
| 1101 (hg-read-number "Output limited to: " | |
| 1102 hg-log-limit))) | |
| 1103 (let ((a-path (hg-abbrev-file-name path)) | |
| 1104 (r1 (or rev1 "tip")) | |
| 1105 (r2 (or rev2 "0")) | |
| 1106 (limit (format "%d" (or log-limit hg-log-limit)))) | |
| 1107 (hg-view-output ((if (equal r1 r2) | |
| 1108 (format "Mercurial: Log of rev %s of %s" rev1 a-path) | |
| 1109 (format | |
| 1110 "Mercurial: at most %s log(s) from rev %s to %s of %s" | |
| 1111 limit r1 r2 a-path))) | |
| 1112 (eval (list* 'call-process (hg-binary) nil t nil | |
| 1113 "log" | |
| 1114 "-r" (format "%s:%s" r1 r2) | |
| 1115 "-l" limit | |
| 1116 (if (> (length path) (length (hg-root path))) | |
| 1117 (cons path nil) | |
| 1118 nil))) | |
| 1119 (hg-log-mode) | |
| 1120 (cd (hg-root path))))) | |
| 1121 | |
| 1122 (defun hg-log-repo (path &optional rev1 rev2 log-limit) | |
| 1123 "Display the revision history of the repository containing PATH. | |
| 1124 History is displayed between REV1 and REV2. | |
| 1125 Number of displayed changesets is limited to LOG-LIMIT, | |
| 1126 REV1 defaults to the tip, while REV2 defaults to 0. | |
| 1127 LOG-LIMIT defaults to `hg-log-limit'. | |
| 1128 With a prefix argument, prompt for each parameter." | |
| 1129 (interactive (list (hg-read-file-name " to log") | |
| 1130 (hg-read-rev " to start with" | |
| 1131 "tip") | |
| 1132 (hg-read-rev " to end with" | |
| 1133 "0") | |
| 1134 (hg-read-number "Output limited to: " | |
| 1135 hg-log-limit))) | |
| 1136 (hg-log (hg-root path) rev1 rev2 log-limit)) | |
| 1137 | |
| 1138 (defun hg-outgoing (&optional repo) | |
| 1139 "Display changesets present locally that are not present in REPO." | |
| 1140 (interactive (list (hg-read-repo-name " where changes would go to" nil | |
| 1141 hg-outgoing-repository))) | |
| 1142 (hg-view-output ((format "Mercurial: Outgoing from %s to %s" | |
| 1143 (hg-abbrev-file-name (hg-root)) | |
| 1144 (hg-abbrev-file-name | |
| 1145 (or repo hg-outgoing-repository)))) | |
| 1146 (call-process (hg-binary) nil t nil "outgoing" | |
| 1147 (or repo hg-outgoing-repository)) | |
| 1148 (hg-log-mode) | |
| 1149 (cd (hg-root)))) | |
| 1150 | |
| 1151 (defun hg-pull (&optional repo) | |
| 1152 "Pull changes from repository REPO. | |
| 1153 This does not update the working directory." | |
| 1154 (interactive (list (hg-read-repo-name " to pull from"))) | |
| 1155 (hg-view-output ((format "Mercurial: Pull to %s from %s" | |
| 1156 (hg-abbrev-file-name (hg-root)) | |
| 1157 (hg-abbrev-file-name | |
| 1158 (or repo hg-incoming-repository)))) | |
| 1159 (call-process (hg-binary) nil t nil "pull" | |
| 1160 (or repo hg-incoming-repository)) | |
| 1161 (cd (hg-root)))) | |
| 1162 | |
| 1163 (defun hg-push (&optional repo) | |
| 1164 "Push changes to repository REPO." | |
| 1165 (interactive (list (hg-read-repo-name " to push to"))) | |
| 1166 (hg-view-output ((format "Mercurial: Push from %s to %s" | |
| 1167 (hg-abbrev-file-name (hg-root)) | |
| 1168 (hg-abbrev-file-name | |
| 1169 (or repo hg-outgoing-repository)))) | |
| 1170 (call-process (hg-binary) nil t nil "push" | |
| 1171 (or repo hg-outgoing-repository)) | |
| 1172 (cd (hg-root)))) | |
| 1173 | |
| 1174 (defun hg-revert-buffer-internal () | |
| 1175 (let ((ctx (hg-buffer-context))) | |
| 1176 (message "Reverting %s..." buffer-file-name) | |
| 1177 (hg-run0 "revert" buffer-file-name) | |
| 1178 (revert-buffer t t t) | |
| 1179 (hg-restore-context ctx) | |
| 1180 (hg-mode-line) | |
| 1181 (message "Reverting %s...done" buffer-file-name))) | |
| 1182 | |
| 1183 (defun hg-revert-buffer () | |
| 1184 "Revert current buffer's file back to the latest committed version. | |
| 1185 If the file has not changed, nothing happens. Otherwise, this | |
| 1186 displays a diff and asks for confirmation before reverting." | |
| 1187 (interactive) | |
| 1188 (let ((vc-suppress-confirm nil) | |
| 1189 (obuf (current-buffer)) | |
| 1190 diff) | |
| 1191 (vc-buffer-sync) | |
| 1192 (unwind-protect | |
| 1193 (setq diff (hg-diff buffer-file-name)) | |
| 1194 (when diff | |
| 1195 (unless (yes-or-no-p "Discard changes? ") | |
| 1196 (error "Revert cancelled"))) | |
| 1197 (when diff | |
| 1198 (let ((buf (current-buffer))) | |
| 1199 (delete-window (selected-window)) | |
| 1200 (kill-buffer buf)))) | |
| 1201 (set-buffer obuf) | |
| 1202 (when diff | |
| 1203 (hg-revert-buffer-internal)))) | |
| 1204 | |
| 1205 (defun hg-root (&optional path) | |
| 1206 "Return the root of the repository that contains the given path. | |
| 1207 If the path is outside a repository, return nil. | |
| 1208 When called interactively, the root is printed. A prefix argument | |
| 1209 prompts for a path to check." | |
| 1210 (interactive (list (hg-read-file-name))) | |
| 1211 (if (or path (not hg-root)) | |
| 1212 (let ((root (do ((prev nil dir) | |
| 1213 (dir (file-name-directory | |
| 1214 (or | |
| 1215 path | |
| 1216 buffer-file-name | |
| 1217 (expand-file-name default-directory))) | |
| 1218 (file-name-directory (directory-file-name dir)))) | |
| 1219 ((equal prev dir)) | |
| 1220 (when (file-directory-p (concat dir ".hg")) | |
| 1221 (return dir))))) | |
| 1222 (when (interactive-p) | |
| 1223 (if root | |
| 1224 (message "The root of this repository is `%s'." root) | |
| 1225 (message "The path `%s' is not in a Mercurial repository." | |
| 1226 (hg-abbrev-file-name path)))) | |
| 1227 root) | |
| 1228 hg-root)) | |
| 1229 | |
| 1230 (defun hg-cwd (&optional path) | |
| 1231 "Return the current directory of PATH within the repository." | |
| 1232 (do ((stack nil (cons (file-name-nondirectory | |
| 1233 (directory-file-name dir)) | |
| 1234 stack)) | |
| 1235 (prev nil dir) | |
| 1236 (dir (file-name-directory (or path buffer-file-name | |
| 1237 (expand-file-name default-directory))) | |
| 1238 (file-name-directory (directory-file-name dir)))) | |
| 1239 ((equal prev dir)) | |
| 1240 (when (file-directory-p (concat dir ".hg")) | |
| 1241 (let ((cwd (mapconcat 'identity stack "/"))) | |
| 1242 (unless (equal cwd "") | |
| 1243 (return (file-name-as-directory cwd))))))) | |
| 1244 | |
| 1245 (defun hg-status (path) | |
| 1246 "Print revision control status of a file or directory. | |
| 1247 With prefix argument, prompt for the path to give status for. | |
| 1248 Names are displayed relative to the repository root." | |
| 1249 (interactive (list (hg-read-file-name " for status" (hg-root)))) | |
| 1250 (let ((root (hg-root))) | |
| 1251 (hg-view-output ((format "Mercurial: Status of %s in %s" | |
| 1252 (let ((name (substring (expand-file-name path) | |
| 1253 (length root)))) | |
| 1254 (if (> (length name) 0) | |
| 1255 name | |
| 1256 "*")) | |
| 1257 (hg-abbrev-file-name root))) | |
| 1258 (apply 'call-process (hg-binary) nil t nil | |
| 1259 (list "--cwd" root "status" path)) | |
| 1260 (cd (hg-root path))))) | |
| 1261 | |
| 1262 (defun hg-undo () | |
| 1263 (interactive) | |
| 1264 (error "not implemented")) | |
| 1265 | |
| 1266 (defun hg-update () | |
| 1267 (interactive) | |
| 1268 (error "not implemented")) | |
| 1269 | |
| 1270 (defun hg-version-other-window (rev) | |
| 1271 "Visit version REV of the current file in another window. | |
| 1272 If the current file is named `F', the version is named `F.~REV~'. | |
| 1273 If `F.~REV~' already exists, use it instead of checking it out again." | |
| 1274 (interactive "sVersion to visit (default is workfile version): ") | |
| 1275 (let* ((file buffer-file-name) | |
| 1276 (version (if (string-equal rev "") | |
| 1277 "tip" | |
| 1278 rev)) | |
| 1279 (automatic-backup (vc-version-backup-file-name file version)) | |
| 1280 (manual-backup (vc-version-backup-file-name file version 'manual))) | |
| 1281 (unless (file-exists-p manual-backup) | |
| 1282 (if (file-exists-p automatic-backup) | |
| 1283 (rename-file automatic-backup manual-backup nil) | |
| 1284 (hg-run0 "-q" "cat" "-r" version "-o" manual-backup file))) | |
| 1285 (find-file-other-window manual-backup))) | |
| 1286 | |
| 1287 | |
| 1288 (provide 'mercurial) | |
| 1289 | |
| 1290 | |
| 1291 ;;; Local Variables: | |
| 1292 ;;; prompt-to-byte-compile: nil | |
| 1293 ;;; end: |