##// END OF EJS Templates
mercurial.el: fix error on hg-read-rev() with small tip, and cleanups...
NIIMI Satoshi -
r4433:ba22e867 default
parent child Browse files
Show More
@@ -43,22 +43,28 b''
43
43
44 ;;; Code:
44 ;;; Code:
45
45
46 (require 'advice)
46 (eval-when-compile (require 'cl))
47 (require 'cl)
48 (require 'diff-mode)
47 (require 'diff-mode)
49 (require 'easymenu)
48 (require 'easymenu)
50 (require 'executable)
49 (require 'executable)
51 (require 'vc)
50 (require 'vc)
52
51
52 (defmacro hg-feature-cond (&rest clauses)
53 "Test CLAUSES for feature at compile time.
54 Each clause is (FEATURE BODY...)."
55 (dolist (x clauses)
56 (let ((feature (car x))
57 (body (cdr x)))
58 (when (or (eq feature t)
59 (featurep feature))
60 (return (cons 'progn body))))))
61
53
62
54 ;;; XEmacs has view-less, while GNU Emacs has view. Joy.
63 ;;; XEmacs has view-less, while GNU Emacs has view. Joy.
55
64
56 (condition-case nil
65 (hg-feature-cond
57 (require 'view-less)
66 (xemacs (require 'view-less))
58 (error nil))
67 (t (require 'view)))
59 (condition-case nil
60 (require 'view)
61 (error nil))
62
68
63
69
64 ;;; Variables accessible through the custom system.
70 ;;; Variables accessible through the custom system.
@@ -147,9 +153,6 b' repository-related commands."'
147
153
148 ;;; Other variables.
154 ;;; Other variables.
149
155
150 (defconst hg-running-xemacs (string-match "XEmacs" emacs-version)
151 "Is mercurial.el running under XEmacs?")
152
153 (defvar hg-mode nil
156 (defvar hg-mode nil
154 "Is this file managed by Mercurial?")
157 "Is this file managed by Mercurial?")
155 (make-variable-buffer-local 'hg-mode)
158 (make-variable-buffer-local 'hg-mode)
@@ -167,12 +170,21 b' repository-related commands."'
167 (make-variable-buffer-local 'hg-root)
170 (make-variable-buffer-local 'hg-root)
168 (put 'hg-root 'permanent-local t)
171 (put 'hg-root 'permanent-local t)
169
172
173 (defvar hg-view-mode nil)
174 (make-variable-buffer-local 'hg-view-mode)
175 (put 'hg-view-mode 'permanent-local t)
176
177 (defvar hg-view-file-name nil)
178 (make-variable-buffer-local 'hg-view-file-name)
179 (put 'hg-view-file-name 'permanent-local t)
180
170 (defvar hg-output-buffer-name "*Hg*"
181 (defvar hg-output-buffer-name "*Hg*"
171 "The name to use for Mercurial output buffers.")
182 "The name to use for Mercurial output buffers.")
172
183
173 (defvar hg-file-history nil)
184 (defvar hg-file-history nil)
174 (defvar hg-repo-history nil)
185 (defvar hg-repo-history nil)
175 (defvar hg-rev-history nil)
186 (defvar hg-rev-history nil)
187 (defvar hg-repo-completion-table nil) ; shut up warnings
176
188
177
189
178 ;;; Random constants.
190 ;;; Random constants.
@@ -183,85 +195,96 b' repository-related commands."'
183 (defconst hg-commit-message-end
195 (defconst hg-commit-message-end
184 "--- Files in bold will be committed. Click to toggle selection. ---\n")
196 "--- Files in bold will be committed. Click to toggle selection. ---\n")
185
197
198 (defconst hg-state-alist
199 '((?M . modified)
200 (?A . added)
201 (?R . removed)
202 (?! . deleted)
203 (?C . normal)
204 (?I . ignored)
205 (?? . nil)))
186
206
187 ;;; hg-mode keymap.
207 ;;; hg-mode keymap.
188
208
189 (defvar hg-mode-map (make-sparse-keymap))
190 (define-key hg-mode-map "\C-xv" 'hg-prefix-map)
191
192 (defvar hg-prefix-map
209 (defvar hg-prefix-map
193 (let ((map (copy-keymap vc-prefix-map)))
210 (let ((map (make-sparse-keymap)))
194 (if (functionp 'set-keymap-name)
211 (hg-feature-cond (xemacs (set-keymap-name map 'hg-prefix-map))) ; XEmacs
195 (set-keymap-name map 'hg-prefix-map)); XEmacs
212 (set-keymap-parent map vc-prefix-map)
213 (define-key map "=" 'hg-diff)
214 (define-key map "c" 'hg-undo)
215 (define-key map "g" 'hg-annotate)
216 (define-key map "i" 'hg-add)
217 (define-key map "l" 'hg-log)
218 (define-key map "n" 'hg-commit-start)
219 ;; (define-key map "r" 'hg-update)
220 (define-key map "u" 'hg-revert-buffer)
221 (define-key map "~" 'hg-version-other-window)
196 map)
222 map)
197 "This keymap overrides some default vc-mode bindings.")
223 "This keymap overrides some default vc-mode bindings.")
198 (fset 'hg-prefix-map hg-prefix-map)
224
199 (define-key hg-prefix-map "=" 'hg-diff)
225 (defvar hg-mode-map
200 (define-key hg-prefix-map "c" 'hg-undo)
226 (let ((map (make-sparse-keymap)))
201 (define-key hg-prefix-map "g" 'hg-annotate)
227 (define-key map "\C-xv" hg-prefix-map)
202 (define-key hg-prefix-map "l" 'hg-log)
228 map))
203 (define-key hg-prefix-map "n" 'hg-commit-start)
204 ;; (define-key hg-prefix-map "r" 'hg-update)
205 (define-key hg-prefix-map "u" 'hg-revert-buffer)
206 (define-key hg-prefix-map "~" 'hg-version-other-window)
207
229
208 (add-minor-mode 'hg-mode 'hg-mode hg-mode-map)
230 (add-minor-mode 'hg-mode 'hg-mode hg-mode-map)
209
231
210
232
211 ;;; Global keymap.
233 ;;; Global keymap.
212
234
213 (global-set-key "\C-xvi" 'hg-add)
235 (defvar hg-global-map
236 (let ((map (make-sparse-keymap)))
237 (define-key map "," 'hg-incoming)
238 (define-key map "." 'hg-outgoing)
239 (define-key map "<" 'hg-pull)
240 (define-key map "=" 'hg-diff-repo)
241 (define-key map ">" 'hg-push)
242 (define-key map "?" 'hg-help-overview)
243 (define-key map "A" 'hg-addremove)
244 (define-key map "U" 'hg-revert)
245 (define-key map "a" 'hg-add)
246 (define-key map "c" 'hg-commit-start)
247 (define-key map "f" 'hg-forget)
248 (define-key map "h" 'hg-help-overview)
249 (define-key map "i" 'hg-init)
250 (define-key map "l" 'hg-log-repo)
251 (define-key map "r" 'hg-root)
252 (define-key map "s" 'hg-status)
253 (define-key map "u" 'hg-update)
254 map))
214
255
215 (defvar hg-global-map (make-sparse-keymap))
256 (global-set-key hg-global-prefix hg-global-map)
216 (fset 'hg-global-map hg-global-map)
217 (global-set-key hg-global-prefix 'hg-global-map)
218 (define-key hg-global-map "," 'hg-incoming)
219 (define-key hg-global-map "." 'hg-outgoing)
220 (define-key hg-global-map "<" 'hg-pull)
221 (define-key hg-global-map "=" 'hg-diff-repo)
222 (define-key hg-global-map ">" 'hg-push)
223 (define-key hg-global-map "?" 'hg-help-overview)
224 (define-key hg-global-map "A" 'hg-addremove)
225 (define-key hg-global-map "U" 'hg-revert)
226 (define-key hg-global-map "a" 'hg-add)
227 (define-key hg-global-map "c" 'hg-commit-start)
228 (define-key hg-global-map "f" 'hg-forget)
229 (define-key hg-global-map "h" 'hg-help-overview)
230 (define-key hg-global-map "i" 'hg-init)
231 (define-key hg-global-map "l" 'hg-log-repo)
232 (define-key hg-global-map "r" 'hg-root)
233 (define-key hg-global-map "s" 'hg-status)
234 (define-key hg-global-map "u" 'hg-update)
235
236
257
237 ;;; View mode keymap.
258 ;;; View mode keymap.
238
259
239 (defvar hg-view-mode-map
260 (defvar hg-view-mode-map
240 (let ((map (copy-keymap (if (boundp 'view-minor-mode-map)
261 (let ((map (make-sparse-keymap)))
241 view-minor-mode-map
262 (hg-feature-cond (xemacs (set-keymap-name map 'hg-view-mode-map))) ; XEmacs
242 view-mode-map))))
263 (define-key map (hg-feature-cond (xemacs [button2])
243 (if (functionp 'set-keymap-name)
264 (t [mouse-2]))
244 (set-keymap-name map 'hg-view-mode-map)); XEmacs
265 'hg-buffer-mouse-clicked)
245 map))
266 map))
246 (fset 'hg-view-mode-map hg-view-mode-map)
267
247 (define-key hg-view-mode-map
268 (add-minor-mode 'hg-view-mode "" hg-view-mode-map)
248 (if hg-running-xemacs [button2] [mouse-2])
249 'hg-buffer-mouse-clicked)
250
269
251
270
252 ;;; Commit mode keymaps.
271 ;;; Commit mode keymaps.
253
272
254 (defvar hg-commit-mode-map (make-sparse-keymap))
273 (defvar hg-commit-mode-map
255 (define-key hg-commit-mode-map "\C-c\C-c" 'hg-commit-finish)
274 (let ((map (make-sparse-keymap)))
256 (define-key hg-commit-mode-map "\C-c\C-k" 'hg-commit-kill)
275 (define-key map "\C-c\C-c" 'hg-commit-finish)
257 (define-key hg-commit-mode-map "\C-xv=" 'hg-diff-repo)
276 (define-key map "\C-c\C-k" 'hg-commit-kill)
277 (define-key map "\C-xv=" 'hg-diff-repo)
278 map))
258
279
259 (defvar hg-commit-mode-file-map (make-sparse-keymap))
280 (defvar hg-commit-mode-file-map
260 (define-key hg-commit-mode-file-map
281 (let ((map (make-sparse-keymap)))
261 (if hg-running-xemacs [button2] [mouse-2])
282 (define-key map (hg-feature-cond (xemacs [button2])
283 (t [mouse-2]))
262 'hg-commit-mouse-clicked)
284 'hg-commit-mouse-clicked)
263 (define-key hg-commit-mode-file-map " " 'hg-commit-toggle-file)
285 (define-key map " " 'hg-commit-toggle-file)
264 (define-key hg-commit-mode-file-map "\r" 'hg-commit-toggle-file)
286 (define-key map "\r" 'hg-commit-toggle-file)
287 map))
265
288
266
289
267 ;;; Convenience functions.
290 ;;; Convenience functions.
@@ -278,9 +301,9 b' replacement.'
278
301
279 This function bridges yet another pointless impedance gap between
302 This function bridges yet another pointless impedance gap between
280 XEmacs and GNU Emacs."
303 XEmacs and GNU Emacs."
281 (if (fboundp 'replace-in-string)
304 (hg-feature-cond
282 (replace-in-string str regexp newtext literal)
305 (xemacs (replace-in-string str regexp newtext literal))
283 (replace-regexp-in-string regexp newtext str nil literal)))
306 (t (replace-regexp-in-string regexp newtext str nil literal))))
284
307
285 (defsubst hg-strip (str)
308 (defsubst hg-strip (str)
286 "Strip leading and trailing blank lines from a string."
309 "Strip leading and trailing blank lines from a string."
@@ -318,8 +341,8 b' If the command does not exit with a zero'
318 (cdr res))))
341 (cdr res))))
319
342
320 (defmacro hg-do-across-repo (path &rest body)
343 (defmacro hg-do-across-repo (path &rest body)
321 (let ((root-name (gensym "root-"))
344 (let ((root-name (make-symbol "root-"))
322 (buf-name (gensym "buf-")))
345 (buf-name (make-symbol "buf-")))
323 `(let ((,root-name (hg-root ,path)))
346 `(let ((,root-name (hg-root ,path)))
324 (save-excursion
347 (save-excursion
325 (dolist (,buf-name (buffer-list))
348 (dolist (,buf-name (buffer-list))
@@ -344,29 +367,23 b' all buffers visiting files in the reposi'
344 "Use the properties of a character to do something sensible."
367 "Use the properties of a character to do something sensible."
345 (interactive "d")
368 (interactive "d")
346 (let ((rev (get-char-property pnt 'rev))
369 (let ((rev (get-char-property pnt 'rev))
347 (file (get-char-property pnt 'file))
370 (file (get-char-property pnt 'file)))
348 (date (get-char-property pnt 'date))
349 (user (get-char-property pnt 'user))
350 (host (get-char-property pnt 'host))
351 (prev-buf (current-buffer)))
352 (cond
371 (cond
353 (file
372 (file
354 (find-file-other-window file))
373 (find-file-other-window file))
355 (rev
374 (rev
356 (hg-diff hg-view-file-name rev rev prev-buf))
375 (hg-diff hg-view-file-name rev rev))
357 ((message "I don't know how to do that yet")))))
376 ((message "I don't know how to do that yet")))))
358
377
359 (defsubst hg-event-point (event)
378 (defsubst hg-event-point (event)
360 "Return the character position of the mouse event EVENT."
379 "Return the character position of the mouse event EVENT."
361 (if hg-running-xemacs
380 (hg-feature-cond (xemacs (event-point event))
362 (event-point event)
381 (t (posn-point (event-start event)))))
363 (posn-point (event-start event))))
364
382
365 (defsubst hg-event-window (event)
383 (defsubst hg-event-window (event)
366 "Return the window over which mouse event EVENT occurred."
384 "Return the window over which mouse event EVENT occurred."
367 (if hg-running-xemacs
385 (hg-feature-cond (xemacs (event-window event))
368 (event-window event)
386 (t (posn-window (event-start event)))))
369 (posn-window (event-start event))))
370
387
371 (defun hg-buffer-mouse-clicked (event)
388 (defun hg-buffer-mouse-clicked (event)
372 "Translate the mouse clicks in a HG log buffer to character events.
389 "Translate the mouse clicks in a HG log buffer to character events.
@@ -377,15 +394,10 b" Handle frickin' frackin' gratuitous even"
377 (select-window (hg-event-window event))
394 (select-window (hg-event-window event))
378 (hg-buffer-commands (hg-event-point event)))
395 (hg-buffer-commands (hg-event-point event)))
379
396
380 (unless (fboundp 'view-minor-mode)
381 (defun view-minor-mode (prev-buffer exit-func)
382 (view-mode)))
383
384 (defsubst hg-abbrev-file-name (file)
397 (defsubst hg-abbrev-file-name (file)
385 "Portable wrapper around abbreviate-file-name."
398 "Portable wrapper around abbreviate-file-name."
386 (if hg-running-xemacs
399 (hg-feature-cond (xemacs (abbreviate-file-name file t))
387 (abbreviate-file-name file t)
400 (t (abbreviate-file-name file))))
388 (abbreviate-file-name file)))
389
401
390 (defun hg-read-file-name (&optional prompt default)
402 (defun hg-read-file-name (&optional prompt default)
391 "Read a file or directory name, or a pattern, to use with a command."
403 "Read a file or directory name, or a pattern, to use with a command."
@@ -403,9 +415,9 b" Handle frickin' frackin' gratuitous even"
403 (and path (file-name-directory path))
415 (and path (file-name-directory path))
404 nil nil
416 nil nil
405 (and path (file-name-nondirectory path))
417 (and path (file-name-nondirectory path))
406 (if hg-running-xemacs
418 (hg-feature-cond
407 (cons (quote 'hg-file-history) nil)
419 (xemacs (cons (quote 'hg-file-history) nil))
408 nil))))
420 (t nil)))))
409 path))))
421 path))))
410
422
411 (defun hg-read-number (&optional prompt default)
423 (defun hg-read-number (&optional prompt default)
@@ -477,7 +489,10 b' directory names from the file system. W'
477 (dolist (path (hg-config-section "paths" (hg-read-config)))
489 (dolist (path (hg-config-section "paths" (hg-read-config)))
478 (setq hg-repo-completion-table
490 (setq hg-repo-completion-table
479 (cons (cons (car path) t) hg-repo-completion-table))
491 (cons (cons (car path) t) hg-repo-completion-table))
480 (unless (hg-string-starts-with directory-sep-char (cdr path))
492 (unless (hg-string-starts-with (hg-feature-cond
493 (xemacs directory-sep-char)
494 (t ?/))
495 (cdr path))
481 (setq hg-repo-completion-table
496 (setq hg-repo-completion-table
482 (cons (cons (cdr path) t) hg-repo-completion-table))))
497 (cons (cons (cdr path) t) hg-repo-completion-table))))
483 (completing-read (format "Repository%s: " (or prompt ""))
498 (completing-read (format "Repository%s: " (or prompt ""))
@@ -498,8 +513,8 b' directory names from the file system. W'
498 (if current-prefix-arg
513 (if current-prefix-arg
499 (let ((revs (split-string
514 (let ((revs (split-string
500 (hg-chomp
515 (hg-chomp
501 (hg-run0 "-q" "log" "-r"
516 (hg-run0 "-q" "log" "-l"
502 (format "-%d:tip" hg-rev-completion-limit)))
517 (format "%d" hg-rev-completion-limit)))
503 "[\n:]")))
518 "[\n:]")))
504 (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n"))
519 (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n"))
505 (setq revs (cons (car (split-string line "\\s-")) revs)))
520 (setq revs (cons (car (split-string line "\\s-")) revs)))
@@ -568,11 +583,12 b' current frame."'
568 (goto-char (point-min))
583 (goto-char (point-min))
569 (set-buffer-modified-p nil)
584 (set-buffer-modified-p nil)
570 (toggle-read-only t)
585 (toggle-read-only t)
571 (view-minor-mode prev-buffer 'hg-exit-view-mode)
586 (hg-feature-cond (xemacs (view-minor-mode prev-buffer 'hg-exit-view-mode))
572 (use-local-map hg-view-mode-map)
587 (t (view-mode-enter nil 'hg-exit-view-mode)))
588 (setq hg-view-mode t)
573 (setq truncate-lines t)
589 (setq truncate-lines t)
574 (when file-name
590 (when file-name
575 (set (make-local-variable 'hg-view-file-name)
591 (setq hg-view-file-name
576 (hg-abbrev-file-name file-name))))
592 (hg-abbrev-file-name file-name))))
577
593
578 (defun hg-file-status (file)
594 (defun hg-file-status (file)
@@ -581,12 +597,9 b' current frame."'
581 (exit (car s))
597 (exit (car s))
582 (output (cdr s)))
598 (output (cdr s)))
583 (if (= exit 0)
599 (if (= exit 0)
584 (let ((state (assoc (substring output 0 (min (length output) 2))
600 (let ((state (and (>= (length output) 2)
585 '(("M " . modified)
601 (= (aref output 1) ? )
586 ("A " . added)
602 (assq (aref output 0) hg-state-alist))))
587 ("R " . removed)
588 ("! " . deleted)
589 ("? " . nil)))))
590 (if state
603 (if state
591 (cdr state)
604 (cdr state)
592 'normal)))))
605 'normal)))))
@@ -598,17 +611,11 b' Each entry is a pair (FILE-NAME . STATUS'
598 result)
611 result)
599 (dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result))
612 (dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result))
600 (let (state name)
613 (let (state name)
601 (if (equal (substring entry 1 2) " ")
614 (cond ((= (aref entry 1) ? )
602 (setq state (cdr (assoc (substring entry 0 2)
615 (setq state (assq (aref entry 0) hg-state-alist)
603 '(("M " . modified)
616 name (substring entry 2)))
604 ("A " . added)
617 ((string-match "\\(.*\\): " entry)
605 ("R " . removed)
618 (setq name (match-string 1 entry))))
606 ("! " . deleted)
607 ("C " . normal)
608 ("I " . ignored)
609 ("? " . nil))))
610 name (substring entry 2))
611 (setq name (substring entry 0 (search ": " entry :from-end t))))
612 (setq result (cons (cons name state) result))))))
619 (setq result (cons (cons name state) result))))))
613
620
614 (defmacro hg-view-output (args &rest body)
621 (defmacro hg-view-output (args &rest body)
@@ -618,7 +625,7 b' minibuffer. Otherwise, the buffer is di'
618 ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is
625 ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is
619 the name of the buffer to create, and FILE is the name of the file
626 the name of the buffer to create, and FILE is the name of the file
620 being viewed."
627 being viewed."
621 (let ((prev-buf (gensym "prev-buf-"))
628 (let ((prev-buf (make-symbol "prev-buf-"))
622 (v-b-name (car args))
629 (v-b-name (car args))
623 (v-m-rest (cdr args)))
630 (v-m-rest (cdr args)))
624 `(let ((view-buf-name ,v-b-name)
631 `(let ((view-buf-name ,v-b-name)
General Comments 0
You need to be logged in to leave comments. Login now