mercurial: comparison contrib/mercurial.el

equal deleted inserted replaced

-:905397be7688
+:ba22e867cb23
 ;; Please send problem reports and suggestions to bos@serpentine.com.
 ;;; Code:
-(require 'advice)
+(eval-when-compile (require 'cl))
-(require 'cl)
 (require 'diff-mode)
 (require 'easymenu)
 (require 'executable)
 (require 'vc)
+(defmacro hg-feature-cond (&rest clauses)
+"Test CLAUSES for feature at compile time.
+Each clause is (FEATURE BODY...)."
+(dolist (x clauses)
+(let ((feature (car x))
+	  (body (cdr x)))
+(when (or (eq feature t)
+		(featurep feature))
+	(return (cons 'progn body))))))
 ;;; XEmacs has view-less, while GNU Emacs has view.  Joy.
-(condition-case nil
+(hg-feature-cond
-(require 'view-less)
+(xemacs (require 'view-less))
-(error nil))
+(t (require 'view)))
-(condition-case nil
-(require 'view)
-(error nil))
 ;;; Variables accessible through the custom system.
 (defgroup mercurial nil
 :group 'mercurial)
 ;;; Other variables.
-(defconst hg-running-xemacs (string-match "XEmacs" emacs-version)
-"Is mercurial.el running under XEmacs?")
 (defvar hg-mode nil
 "Is this file managed by Mercurial?")
 (make-variable-buffer-local 'hg-mode)
 (put 'hg-mode 'permanent-local t)
 (defvar hg-root nil)
 (make-variable-buffer-local 'hg-root)
 (put 'hg-root 'permanent-local t)
+(defvar hg-view-mode nil)
+(make-variable-buffer-local 'hg-view-mode)
+(put 'hg-view-mode 'permanent-local t)
+(defvar hg-view-file-name nil)
+(make-variable-buffer-local 'hg-view-file-name)
+(put 'hg-view-file-name 'permanent-local t)
 (defvar hg-output-buffer-name "*Hg*"
 "The name to use for Mercurial output buffers.")
 (defvar hg-file-history nil)
 (defvar hg-repo-history nil)
 (defvar hg-rev-history nil)
+(defvar hg-repo-completion-table nil)	; shut up warnings
 ;;; Random constants.
 (defconst hg-commit-message-start
 "--- Enter your commit message.  Type `C-c C-c' to commit. ---\n")
 (defconst hg-commit-message-end
 "--- Files in bold will be committed.  Click to toggle selection. ---\n")
+(defconst hg-state-alist
+'((?M . modified)
+(?A . added)
+(?R . removed)
+(?! . deleted)
+(?C . normal)
+(?I . ignored)
+(?? . nil)))
 ;;; hg-mode keymap.
-(defvar hg-mode-map (make-sparse-keymap))
-(define-key hg-mode-map "\C-xv" 'hg-prefix-map)
 (defvar hg-prefix-map
-(let ((map (copy-keymap vc-prefix-map)))
+(let ((map (make-sparse-keymap)))
-(if (functionp 'set-keymap-name)
+(hg-feature-cond (xemacs (set-keymap-name map 'hg-prefix-map))) ; XEmacs
-(set-keymap-name map 'hg-prefix-map)); XEmacs
+(set-keymap-parent map vc-prefix-map)
+(define-key map "=" 'hg-diff)
+(define-key map "c" 'hg-undo)
+(define-key map "g" 'hg-annotate)
+(define-key map "i" 'hg-add)
+(define-key map "l" 'hg-log)
+(define-key map "n" 'hg-commit-start)
+;; (define-key map "r" 'hg-update)
+(define-key map "u" 'hg-revert-buffer)
+(define-key map "~" 'hg-version-other-window)
 map)
 "This keymap overrides some default vc-mode bindings.")
-(fset 'hg-prefix-map hg-prefix-map)
-(define-key hg-prefix-map "=" 'hg-diff)
+(defvar hg-mode-map
-(define-key hg-prefix-map "c" 'hg-undo)
+(let ((map (make-sparse-keymap)))
-(define-key hg-prefix-map "g" 'hg-annotate)
+(define-key map "\C-xv" hg-prefix-map)
-(define-key hg-prefix-map "l" 'hg-log)
+map))
-(define-key hg-prefix-map "n" 'hg-commit-start)
-;; (define-key hg-prefix-map "r" 'hg-update)
-(define-key hg-prefix-map "u" 'hg-revert-buffer)
-(define-key hg-prefix-map "~" 'hg-version-other-window)
 (add-minor-mode 'hg-mode 'hg-mode hg-mode-map)
 ;;; Global keymap.
-(global-set-key "\C-xvi" 'hg-add)
+(defvar hg-global-map
+(let ((map (make-sparse-keymap)))
-(defvar hg-global-map (make-sparse-keymap))
+(define-key map "," 'hg-incoming)
-(fset 'hg-global-map hg-global-map)
+(define-key map "." 'hg-outgoing)
-(global-set-key hg-global-prefix 'hg-global-map)
+(define-key map "<" 'hg-pull)
-(define-key hg-global-map "," 'hg-incoming)
+(define-key map "=" 'hg-diff-repo)
-(define-key hg-global-map "." 'hg-outgoing)
+(define-key map ">" 'hg-push)
-(define-key hg-global-map "<" 'hg-pull)
+(define-key map "?" 'hg-help-overview)
-(define-key hg-global-map "=" 'hg-diff-repo)
+(define-key map "A" 'hg-addremove)
-(define-key hg-global-map ">" 'hg-push)
+(define-key map "U" 'hg-revert)
-(define-key hg-global-map "?" 'hg-help-overview)
+(define-key map "a" 'hg-add)
-(define-key hg-global-map "A" 'hg-addremove)
+(define-key map "c" 'hg-commit-start)
-(define-key hg-global-map "U" 'hg-revert)
+(define-key map "f" 'hg-forget)
-(define-key hg-global-map "a" 'hg-add)
+(define-key map "h" 'hg-help-overview)
-(define-key hg-global-map "c" 'hg-commit-start)
+(define-key map "i" 'hg-init)
-(define-key hg-global-map "f" 'hg-forget)
+(define-key map "l" 'hg-log-repo)
-(define-key hg-global-map "h" 'hg-help-overview)
+(define-key map "r" 'hg-root)
-(define-key hg-global-map "i" 'hg-init)
+(define-key map "s" 'hg-status)
-(define-key hg-global-map "l" 'hg-log-repo)
+(define-key map "u" 'hg-update)
-(define-key hg-global-map "r" 'hg-root)
+map))
-(define-key hg-global-map "s" 'hg-status)
-(define-key hg-global-map "u" 'hg-update)
+(global-set-key hg-global-prefix hg-global-map)
 ;;; View mode keymap.
 (defvar hg-view-mode-map
-(let ((map (copy-keymap (if (boundp 'view-minor-mode-map)
+(let ((map (make-sparse-keymap)))
-			      view-minor-mode-map
+(hg-feature-cond (xemacs (set-keymap-name map 'hg-view-mode-map))) ; XEmacs
-			    view-mode-map))))
+(define-key map (hg-feature-cond (xemacs [button2])
-(if (functionp 'set-keymap-name)
+				     (t [mouse-2]))
-(set-keymap-name map 'hg-view-mode-map)); XEmacs
+'hg-buffer-mouse-clicked)
 map))
-(fset 'hg-view-mode-map hg-view-mode-map)
-(define-key hg-view-mode-map
+(add-minor-mode 'hg-view-mode "" hg-view-mode-map)
-(if hg-running-xemacs [button2] [mouse-2])
-'hg-buffer-mouse-clicked)
 ;;; Commit mode keymaps.
-(defvar hg-commit-mode-map (make-sparse-keymap))
+(defvar hg-commit-mode-map
-(define-key hg-commit-mode-map "\C-c\C-c" 'hg-commit-finish)
+(let ((map (make-sparse-keymap)))
-(define-key hg-commit-mode-map "\C-c\C-k" 'hg-commit-kill)
+(define-key map "\C-c\C-c" 'hg-commit-finish)
-(define-key hg-commit-mode-map "\C-xv=" 'hg-diff-repo)
+(define-key map "\C-c\C-k" 'hg-commit-kill)
+(define-key map "\C-xv=" 'hg-diff-repo)
-(defvar hg-commit-mode-file-map (make-sparse-keymap))
+map))
-(define-key hg-commit-mode-file-map
-(if hg-running-xemacs [button2] [mouse-2])
+(defvar hg-commit-mode-file-map
-'hg-commit-mouse-clicked)
+(let ((map (make-sparse-keymap)))
-(define-key hg-commit-mode-file-map " " 'hg-commit-toggle-file)
+(define-key map (hg-feature-cond (xemacs [button2])
-(define-key hg-commit-mode-file-map "\r" 'hg-commit-toggle-file)
+				     (t [mouse-2]))
+'hg-commit-mouse-clicked)
+(define-key map " " 'hg-commit-toggle-file)
+(define-key map "\r" 'hg-commit-toggle-file)
+map))
 ;;; Convenience functions.
 (defsubst hg-binary ()
 Return the new string.  Optional LITERAL non-nil means do a literal
 replacement.
 This function bridges yet another pointless impedance gap between
 XEmacs and GNU Emacs."
-(if (fboundp 'replace-in-string)
+(hg-feature-cond
-(replace-in-string str regexp newtext literal)
+(xemacs (replace-in-string str regexp newtext literal))
-(replace-regexp-in-string regexp newtext str nil literal)))
+(t (replace-regexp-in-string regexp newtext str nil literal))))
 (defsubst hg-strip (str)
 "Strip leading and trailing blank lines from a string."
 (hg-replace-in-string (hg-replace-in-string str "[\r\n][ \t\r\n]*\\'" "")
 			"\\`[ \t\r\n]*[\r\n]" ""))
 	       (cons command args)
 	       (car res))
 (cdr res))))
 (defmacro hg-do-across-repo (path &rest body)
-(let ((root-name (gensym "root-"))
+(let ((root-name (make-symbol "root-"))
-	(buf-name (gensym "buf-")))
+	(buf-name (make-symbol "buf-")))
 `(let ((,root-name (hg-root ,path)))
 (save-excursion
 	 (dolist (,buf-name (buffer-list))
 	   (set-buffer ,buf-name)
 	   (when (and hg-status (equal (hg-root buffer-file-name) ,root-name))
 (defun hg-buffer-commands (pnt)
 "Use the properties of a character to do something sensible."
 (interactive "d")
 (let ((rev (get-char-property pnt 'rev))
-	(file (get-char-property pnt 'file))
+	(file (get-char-property pnt 'file)))
-	(date (get-char-property pnt 'date))
-	(user (get-char-property pnt 'user))
-	(host (get-char-property pnt 'host))
-	(prev-buf (current-buffer)))
 (cond
 (file
 (find-file-other-window file))
 (rev
-(hg-diff hg-view-file-name rev rev prev-buf))
+(hg-diff hg-view-file-name rev rev))
 ((message "I don't know how to do that yet")))))
 (defsubst hg-event-point (event)
 "Return the character position of the mouse event EVENT."
-(if hg-running-xemacs
+(hg-feature-cond (xemacs (event-point event))
-(event-point event)
+		   (t (posn-point (event-start event)))))
-(posn-point (event-start event))))
 (defsubst hg-event-window (event)
 "Return the window over which mouse event EVENT occurred."
-(if hg-running-xemacs
+(hg-feature-cond (xemacs (event-window event))
-(event-window event)
+		   (t (posn-window (event-start event)))))
-(posn-window (event-start event))))
 (defun hg-buffer-mouse-clicked (event)
 "Translate the mouse clicks in a HG log buffer to character events.
 These are then handed off to `hg-buffer-commands'.
 Handle frickin' frackin' gratuitous event-related incompatibilities."
 (interactive "e")
 (select-window (hg-event-window event))
 (hg-buffer-commands (hg-event-point event)))
-(unless (fboundp 'view-minor-mode)
-(defun view-minor-mode (prev-buffer exit-func)
-(view-mode)))
 (defsubst hg-abbrev-file-name (file)
 "Portable wrapper around abbreviate-file-name."
-(if hg-running-xemacs
+(hg-feature-cond (xemacs (abbreviate-file-name file t))
-(abbreviate-file-name file t)
+		   (t (abbreviate-file-name file))))
-(abbreviate-file-name file)))
 (defun hg-read-file-name (&optional prompt default)
 "Read a file or directory name, or a pattern, to use with a command."
 (save-excursion
 (while hg-prev-buffer
 (format "File, directory or pattern%s: "
 (or prompt ""))
 (and path (file-name-directory path))
 nil nil
 (and path (file-name-nondirectory path))
-(if hg-running-xemacs
+(hg-feature-cond
-(cons (quote 'hg-file-history) nil)
+			 (xemacs (cons (quote 'hg-file-history) nil))
-nil))))
+			 (t nil)))))
 path))))
 (defun hg-read-number (&optional prompt default)
 "Read a integer value."
 (save-excursion
 (if current-prefix-arg
 	  (progn
 	    (dolist (path (hg-config-section "paths" (hg-read-config)))
 	      (setq hg-repo-completion-table
 		    (cons (cons (car path) t) hg-repo-completion-table))
-	      (unless (hg-string-starts-with directory-sep-char (cdr path))
+	      (unless (hg-string-starts-with (hg-feature-cond
+					      (xemacs directory-sep-char)
+					      (t ?/))
+					     (cdr path))
 		(setq hg-repo-completion-table
 		      (cons (cons (cdr path) t) hg-repo-completion-table))))
 	    (completing-read (format "Repository%s: " (or prompt ""))
 			     'hg-complete-repo
 			     nil
 (set-buffer hg-prev-buffer))
 (let ((rev (or default "tip")))
 (if current-prefix-arg
 	  (let ((revs (split-string
 		       (hg-chomp
-			(hg-run0 "-q" "log" "-r"
+			(hg-run0 "-q" "log" "-l"
-				 (format "-%d:tip" hg-rev-completion-limit)))
+				 (format "%d" hg-rev-completion-limit)))
 		       "[\n:]")))
 	    (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n"))
 	      (setq revs (cons (car (split-string line "\\s-")) revs)))
 	    (completing-read (format "Revision%s (%s): "
 				     (or prompt "")
 (defun hg-view-mode (prev-buffer &optional file-name)
 (goto-char (point-min))
 (set-buffer-modified-p nil)
 (toggle-read-only t)
-(view-minor-mode prev-buffer 'hg-exit-view-mode)
+(hg-feature-cond (xemacs (view-minor-mode prev-buffer 'hg-exit-view-mode))
-(use-local-map hg-view-mode-map)
+		   (t (view-mode-enter nil 'hg-exit-view-mode)))
+(setq hg-view-mode t)
 (setq truncate-lines t)
 (when file-name
-(set (make-local-variable 'hg-view-file-name)
+(setq hg-view-file-name
-	 (hg-abbrev-file-name file-name))))
+	  (hg-abbrev-file-name file-name))))
 (defun hg-file-status (file)
 "Return status of FILE, or nil if FILE does not exist or is unmanaged."
 (let* ((s (hg-run "status" file))
 	 (exit (car s))
 	 (output (cdr s)))
 (if (= exit 0)
-	(let ((state (assoc (substring output 0 (min (length output) 2))
+	(let ((state (and (>= (length output) 2)
-			    '(("M " . modified)
+			  (= (aref output 1) ? )
-			      ("A " . added)
+			  (assq (aref output 0) hg-state-alist))))
-			      ("R " . removed)
-			      ("! " . deleted)
-			      ("? " . nil)))))
 	  (if state
 	      (cdr state)
 	    'normal)))))
 (defun hg-path-status (root paths)
 Each entry is a pair (FILE-NAME . STATUS)."
 (let ((s (apply 'hg-run "--cwd" root "status" "-marduc" paths))
 	result)
 (dolist (entry (split-string (hg-chomp (cdr s)) "\n") (nreverse result))
 (let (state name)
-	(if (equal (substring entry 1 2) " ")
+	(cond ((= (aref entry 1) ? )
-	    (setq state (cdr (assoc (substring entry 0 2)
+	       (setq state (assq (aref entry 0) hg-state-alist)
-				    '(("M " . modified)
+		     name (substring entry 2)))
-				      ("A " . added)
+	      ((string-match "\\(.*\\): " entry)
-				      ("R " . removed)
+	       (setq name (match-string 1 entry))))
-				      ("! " . deleted)
-				      ("C " . normal)
-				      ("I " . ignored)
-				      ("? " . nil))))
-		  name (substring entry 2))
-	  (setq name (substring entry 0 (search ": " entry :from-end t))))
 	(setq result (cons (cons name state) result))))))
 (defmacro hg-view-output (args &rest body)
 "Execute BODY in a clean buffer, then quickly display that buffer.
 If the buffer contains one line, its contents are displayed in the
 minibuffer.  Otherwise, the buffer is displayed in view-mode.
 ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is
 the name of the buffer to create, and FILE is the name of the file
 being viewed."
-(let ((prev-buf (gensym "prev-buf-"))
+(let ((prev-buf (make-symbol "prev-buf-"))
 	(v-b-name (car args))
 	(v-m-rest (cdr args)))
 `(let ((view-buf-name ,v-b-name)
 	   (,prev-buf (current-buffer)))
 (get-buffer-create view-buf-name)

changeset 4433	ba22e867cb23
parent 4413	b008deae9910
child 4693	3f484688c702