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