;;; vc-hg.el --- VC backend for the mercurial version control system -*- lexical-binding: t -*-
-;; Copyright (C) 2006-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2015 Free Software Foundation, Inc.
;; Author: Ivan Kanis
;; Maintainer: emacs-devel@gnu.org
;; - dir-extra-headers (dir) OK
;; - dir-printer (fileinfo) OK
;; * working-revision (file) OK
-;; - latest-on-branch-p (file) ??
;; * checkout-model (files) OK
;; - mode-line-string (file) NOT NEEDED
;; STATE-CHANGING FUNCTIONS
;; * find-revision (file rev buffer) OK
;; * checkout (file &optional rev) OK
;; * revert (file &optional contents-done) OK
-;; - rollback (files) ?? PROBABLY NOT NEEDED
;; - merge (file rev1 rev2) NEEDED
;; - merge-news (file) NEEDED
;; - steal-lock (file &optional revision) NOT NEEDED
:version "23.1"
:group 'vc-hg)
+(defcustom vc-hg-annotate-switches nil
+ "String or list of strings specifying switches for hg annotate under VC.
+If nil, use the value of `vc-annotate-switches'. If t, use no
+switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "25.1"
+ :group 'vc-hg)
+
(defcustom vc-hg-program "hg"
"Name of the Mercurial executable (excluding any arguments)."
:type 'string
(defun vc-hg-state (file)
"Hg-specific version of `vc-state'."
+ (setq file (expand-file-name file))
(let*
((status nil)
(default-directory (file-name-directory file))
;; Some problem happened. E.g. We can't find an `hg'
;; executable.
(error nil)))))))
- (when (eq 0 status)
- (when (null (string-match ".*: No such file or directory$" out))
- (let ((state (aref out 0)))
- (cond
- ((eq state ?=) 'up-to-date)
- ((eq state ?A) 'added)
- ((eq state ?M) 'edited)
- ((eq state ?I) 'ignored)
- ((eq state ?R) 'removed)
- ((eq state ?!) 'missing)
- ((eq state ??) 'unregistered)
- ((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
- (t 'up-to-date)))))))
+ (when (and (eq 0 status)
+ (> (length out) 0)
+ (null (string-match ".*: No such file or directory$" out)))
+ (let ((state (aref out 0)))
+ (cond
+ ((eq state ?=) 'up-to-date)
+ ((eq state ?A) 'added)
+ ((eq state ?M) 'edited)
+ ((eq state ?I) 'ignored)
+ ((eq state ?R) 'removed)
+ ((eq state ?!) 'missing)
+ ((eq state ??) 'unregistered)
+ ((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
+ (t 'up-to-date))))))
(defun vc-hg-working-revision (file)
"Hg-specific version of `vc-working-revision'."
(autoload 'vc-switches "vc")
-(defun vc-hg-diff (files &optional async oldvers newvers buffer)
+(defun vc-hg-diff (files &optional oldvers newvers buffer async)
"Get a difference report using hg between two revisions of FILES."
(let* ((firstfile (car files))
(working (and firstfile (vc-working-revision firstfile))))
(defun vc-hg-annotate-command (file buffer &optional revision)
"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
Optional arg REVISION is a revision to annotate from."
- (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
- (when revision (concat "-r" revision))))
+ (apply #'vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
+ (append (vc-switches 'hg 'annotate)
+ (if revision (list (concat "-r" revision))))))
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
+(declare-function vc-annotate-convert-time "vc-annotate" (&optional time))
;; The format for one line output by "hg annotate -d -n" looks like this:
;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
(defun vc-hg-dir-status-files (dir files update-function)
- (apply 'vc-hg-command (current-buffer) 'async dir "status" "-mardui" "-C" files)
+ (apply 'vc-hg-command (current-buffer) 'async dir "status"
+ (concat "-mardu" (if files "i"))
+ "-C" files)
(vc-run-delayed
- (vc-hg-after-dir-status update-function)))
+ (vc-hg-after-dir-status update-function)))
(defun vc-hg-dir-extra-header (name &rest commands)
(concat (propertize name 'face 'font-lock-type-face)
(vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
remote-location)))
-(declare-function log-view-get-marked "log-view" ())
-
-;; XXX maybe also add key bindings for these functions.
-(defun vc-hg-push ()
- (interactive)
- (let ((marked-list (log-view-get-marked)))
- (if marked-list
- (apply #'vc-hg-command
- nil 0 nil
- "push"
- (apply 'nconc
- (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
- (error "No log entries selected for push"))))
-
(defvar vc-hg-error-regexp-alist nil
;; 'hg pull' does not list modified files, so, for now, the only
;; benefit of `vc-compilation-mode' is that one can get rid of
"Value of `compilation-error-regexp-alist' in *vc-hg* buffers.")
(autoload 'vc-do-async-command "vc-dispatcher")
+(autoload 'log-view-get-marked "log-view")
-(defun vc-hg-pull (prompt)
- "Issue a Mercurial pull command.
-If called interactively with a set of marked Log View buffers,
-call \"hg pull -r REVS\" to pull in the specified revisions REVS.
-
-With a prefix argument or if PROMPT is non-nil, prompt for a
-specific Mercurial pull command. The default is \"hg pull -u\",
-which fetches changesets from the default remote repository and
-then attempts to update the working directory."
- (interactive "P")
+(defun vc-hg--pushpull (command prompt &optional obsolete)
+ "Run COMMAND (a string; either push or pull) on the current Hg branch.
+If PROMPT is non-nil, prompt for the Hg command to run.
+If OBSOLETE is non-nil, behave like the old versions of the Hg push/pull
+commands, which only operated on marked files."
(let (marked-list)
- ;; The `vc-hg-pull' command existed before the `pull' VC action
- ;; was implemented. Keep it for backward compatibility.
- (if (and (called-interactively-p 'interactive)
- (setq marked-list (log-view-get-marked)))
+ ;; The `vc-hg-pull' and `vc-hg-push' commands existed before the
+ ;; `pull'/`push' VC actions were implemented.
+ ;; The following is for backwards compatibility.
+ (if (and obsolete (setq marked-list (log-view-get-marked)))
(apply #'vc-hg-command
nil 0 nil
- "pull"
+ command
(apply 'nconc
- (mapcar (lambda (arg) (list "-r" arg))
- marked-list)))
+ (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
(let* ((root (vc-hg-root default-directory))
(buffer (format "*vc-hg : %s*" (expand-file-name root)))
- (command "pull")
(hg-program vc-hg-program)
;; Fixme: before updating the working copy to the latest
;; state, should check if it's visiting an old revision.
- (args '("-u")))
+ (args (if (equal command "pull") '("-u"))))
;; If necessary, prompt for the exact command.
+ ;; TODO if pushing, prompt if no default push location - cf bzr.
(when prompt
(setq args (split-string
- (read-shell-command "Run Hg (like this): "
- (format "%s pull -u" hg-program)
- 'vc-hg-history)
+ (read-shell-command
+ (format "Hg %s command: " command)
+ (format "%s %s%s" hg-program command
+ (if (not args) ""
+ (concat " " (mapconcat 'identity args " "))))
+ 'vc-hg-history)
" " t))
(setq hg-program (car args)
command (cadr args)
args (cddr args)))
- (apply 'vc-do-async-command buffer root hg-program
- command args)
+ (apply 'vc-do-async-command buffer root hg-program command args)
(with-current-buffer buffer
(vc-run-delayed (vc-compilation-mode 'hg)))
(vc-set-async-update buffer)))))
+(defun vc-hg-pull (prompt)
+ "Issue a Mercurial pull command.
+If called interactively with a set of marked Log View buffers,
+call \"hg pull -r REVS\" to pull in the specified revisions REVS.
+
+With a prefix argument or if PROMPT is non-nil, prompt for a
+specific Mercurial pull command. The default is \"hg pull -u\",
+which fetches changesets from the default remote repository and
+then attempts to update the working directory."
+ (interactive "P")
+ (vc-hg--pushpull "pull" prompt (called-interactively-p 'interactive)))
+
+(defun vc-hg-push (prompt)
+ "Push changes from the current Mercurial branch.
+Normally, this runs \"hg push\". If PROMPT is non-nil, prompt
+for the Hg command to run.
+
+If called interactively with a set of marked Log View buffers,
+call \"hg push -r REVS\" to push the specified revisions REVS."
+ (interactive "P")
+ (vc-hg--pushpull "push" prompt (called-interactively-p 'interactive)))
+
(defun vc-hg-merge-branch ()
"Merge incoming changes into the current working directory.
This runs the command \"hg merge\"."