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