lisp/vc/vc-hg.el

   1 ;;; vc-hg.el --- VC backend for the mercurial version control system
   2
   3 ;; Copyright (C) 2006-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Ivan Kanis
   6 ;; Keywords: vc tools
   7 ;; Package: vc
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is a mercurial version control backend
  27
  28 ;;; Thanks:
  29
  30 ;;; Bugs:
  31
  32 ;;; Installation:
  33
  34 ;;; Todo:
  35
  36 ;; 1) Implement the rest of the vc interface. See the comment at the
  37 ;; beginning of vc.el. The current status is:
  38
  39 ;; FUNCTION NAME                               STATUS
  40 ;; BACKEND PROPERTIES
  41 ;; * revision-granularity                      OK
  42 ;; STATE-QUERYING FUNCTIONS
  43 ;; * registered (file)                         OK
  44 ;; * state (file)                              OK
  45 ;; - state-heuristic (file)                    NOT NEEDED
  46 ;; - dir-status (dir update-function)          OK
  47 ;; - dir-status-files (dir files ds uf)        OK
  48 ;; - dir-extra-headers (dir)                   OK
  49 ;; - dir-printer (fileinfo)                    OK
  50 ;; * working-revision (file)                   OK
  51 ;; - latest-on-branch-p (file)                 ??
  52 ;; * checkout-model (files)                    OK
  53 ;; - workfile-unchanged-p (file)               OK
  54 ;; - mode-line-string (file)                   NOT NEEDED
  55 ;; STATE-CHANGING FUNCTIONS
  56 ;; * register (files &optional rev comment)    OK
  57 ;; * create-repo ()                            OK
  58 ;; - init-revision ()                          NOT NEEDED
  59 ;; - responsible-p (file)                      OK
  60 ;; - could-register (file)                     OK
  61 ;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
  62 ;; - unregister (file)                         COMMENTED OUT, MAY BE INCORRECT
  63 ;; * checkin (files rev comment)               OK
  64 ;; * find-revision (file rev buffer)           OK
  65 ;; * checkout (file &optional editable rev)    OK
  66 ;; * revert (file &optional contents-done)     OK
  67 ;; - rollback (files)                          ?? PROBABLY NOT NEEDED
  68 ;; - merge (file rev1 rev2)                    NEEDED
  69 ;; - merge-news (file)                         NEEDED
  70 ;; - steal-lock (file &optional revision)      NOT NEEDED
  71 ;; HISTORY FUNCTIONS
  72 ;; * print-log (files buffer &optional shortlog start-revision limit) OK
  73 ;; - log-view-mode ()                          OK
  74 ;; - show-log-entry (revision)                 NOT NEEDED, DEFAULT IS GOOD
  75 ;; - comment-history (file)                    NOT NEEDED
  76 ;; - update-changelog (files)                  NOT NEEDED
  77 ;; * diff (files &optional rev1 rev2 buffer)   OK
  78 ;; - revision-completion-table (files)         OK?
  79 ;; - annotate-command (file buf &optional rev) OK
  80 ;; - annotate-time ()                          OK
  81 ;; - annotate-current-time ()                  NOT NEEDED
  82 ;; - annotate-extract-revision-at-line ()      OK
  83 ;; TAG SYSTEM
  84 ;; - create-tag (dir name branchp)             NEEDED
  85 ;; - retrieve-tag (dir name update)            NEEDED
  86 ;; MISCELLANEOUS
  87 ;; - make-version-backups-p (file)             ??
  88 ;; - repository-hostname (dirname)             ??
  89 ;; - previous-revision (file rev)              OK
  90 ;; - next-revision (file rev)                  OK
  91 ;; - check-headers ()                          ??
  92 ;; - clear-headers ()                          ??
  93 ;; - delete-file (file)                        TEST IT
  94 ;; - rename-file (old new)                     OK
  95 ;; - find-file-hook ()                         PROBABLY NOT NEEDED
  96
  97 ;; 2) Implement Stefan Monnier's advice:
  98 ;; vc-hg-registered and vc-hg-state
  99 ;; Both of those functions should be super extra careful to fail gracefully in
 100 ;; unexpected circumstances. The reason this is important is that any error
 101 ;; there will prevent the user from even looking at the file :-(
 102 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
 103 ;; mercurial's control and extracting the current revision should be done
 104 ;; without even using `hg' (this way even if you don't have `hg' installed,
 105 ;; Emacs is able to tell you this file is under mercurial's control).
 106
 107 ;;; History:
 108 ;;
 109
 110 ;;; Code:
 111
 112 (eval-when-compile
 113   (require 'cl)
 114   (require 'vc)
 115   (require 'vc-dir))
 116
 117 ;;; Customization options
 118
 119 (defgroup vc-hg nil
 120   "VC Mercurial (hg) backend."
 121   :version "24.1"
 122   :group 'vc)
 123
 124 (defcustom vc-hg-global-switches nil
 125   "Global switches to pass to any Hg command."
 126   :type '(choice (const :tag "None" nil)
 127          (string :tag "Argument String")
 128          (repeat :tag "Argument List" :value ("") string))
 129   :version "22.2"
 130   :group 'vc-hg)
 131
 132 (defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
 133   "String or list of strings specifying switches for Hg diff under VC.
 134 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
 135   :type '(choice (const :tag "Unspecified" nil)
 136                  (const :tag "None" t)
 137                  (string :tag "Argument String")
 138                  (repeat :tag "Argument List" :value ("") string))
 139   :version "23.1"
 140   :group 'vc-hg)
 141
 142 (defcustom vc-hg-program "hg"
 143   "Name of the Mercurial executable (excluding any arguments)."
 144   :type 'string
 145   :group 'vc-hg)
 146
 147 (defcustom vc-hg-root-log-format
 148   '("{rev}:{tags}: {author|person} {date|shortdate} {desc|firstline}\\n"
 149     "^\\([0-9]+\\):\\([^:]*\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
 150     ((1 'log-view-message-face)
 151      (2 'change-log-list)
 152      (3 'change-log-name)
 153      (4 'change-log-date)))
 154   "Mercurial log template for `vc-print-root-log'.
 155 This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE
 156 is the \"--template\" argument string to pass to Mercurial,
 157 REGEXP is a regular expression matching the resulting Mercurial
 158 output, and KEYWORDS is a list of `font-lock-keywords' for
 159 highlighting the Log View buffer."
 160   :type '(list string string (repeat sexp))
 161   :group 'vc-hg
 162   :version "24.1")
 163
 164 \f
 165 ;;; Properties of the backend
 166
 167 (defvar vc-hg-history nil)
 168
 169 (defun vc-hg-revision-granularity () 'repository)
 170 (defun vc-hg-checkout-model (files) 'implicit)
 171
 172 ;;; State querying functions
 173
 174 ;;;###autoload (defun vc-hg-registered (file)
 175 ;;;###autoload   "Return non-nil if FILE is registered with hg."
 176 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
 177 ;;;###autoload       (progn
 178 ;;;###autoload         (load "vc-hg")
 179 ;;;###autoload         (vc-hg-registered file))))
 180
 181 ;; Modeled after the similar function in vc-bzr.el
 182 (defun vc-hg-registered (file)
 183   "Return non-nil if FILE is registered with hg."
 184   (when (vc-hg-root file)           ; short cut
 185     (let ((state (vc-hg-state file)))  ; expensive
 186       (and state (not (memq state '(ignored unregistered)))))))
 187
 188 (defun vc-hg-state (file)
 189   "Hg-specific version of `vc-state'."
 190   (let*
 191       ((status nil)
 192        (default-directory (file-name-directory file))
 193        (out
 194         (with-output-to-string
 195           (with-current-buffer
 196               standard-output
 197             (setq status
 198                   (condition-case nil
 199                       ;; Ignore all errors.
 200                       (let ((process-environment
 201                              ;; Avoid localization of messages so we
 202                              ;; can parse the output.
 203                              (append (list "TERM=dumb" "LANGUAGE=C")
 204                                      process-environment)))
 205                         (process-file
 206                          vc-hg-program nil t nil
 207                          "--config" "alias.status=status"
 208                          "--config" "defaults.status="
 209                          "status" "-A" (file-relative-name file)))
 210                     ;; Some problem happened.  E.g. We can't find an `hg'
 211                     ;; executable.
 212                     (error nil)))))))
 213     (when (eq 0 status)
 214         (when (null (string-match ".*: No such file or directory$" out))
 215           (let ((state (aref out 0)))
 216             (cond
 217              ((eq state ?=) 'up-to-date)
 218              ((eq state ?A) 'added)
 219              ((eq state ?M) 'edited)
 220              ((eq state ?I) 'ignored)
 221              ((eq state ?R) 'removed)
 222              ((eq state ?!) 'missing)
 223              ((eq state ??) 'unregistered)
 224              ((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
 225              (t 'up-to-date)))))))
 226
 227 (defun vc-hg-working-revision (file)
 228   "Hg-specific version of `vc-working-revision'."
 229   (let ((default-directory (if (file-directory-p file)
 230                                (file-name-as-directory file)
 231                              (file-name-directory file))))
 232     (ignore-errors
 233       (with-output-to-string
 234         (process-file vc-hg-program nil standard-output nil
 235                       "log" "-l" "1" "--template" "{rev}"
 236                       (file-relative-name file))))))
 237
 238 ;;; History functions
 239
 240 (defcustom vc-hg-log-switches nil
 241   "String or list of strings specifying switches for hg log under VC."
 242   :type '(choice (const :tag "None" nil)
 243                  (string :tag "Argument String")
 244                  (repeat :tag "Argument List" :value ("") string))
 245   :group 'vc-hg)
 246
 247 (defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
 248   "Get change log associated with FILES."
 249   ;; `vc-do-command' creates the buffer, but we need it before running
 250   ;; the command.
 251   (vc-setup-buffer buffer)
 252   ;; If the buffer exists from a previous invocation it might be
 253   ;; read-only.
 254   (let ((inhibit-read-only t))
 255     (with-current-buffer
 256         buffer
 257       (apply 'vc-hg-command buffer 0 files "log"
 258              (nconc
 259               (when start-revision (list (format "-r%s:" start-revision)))
 260               (when limit (list "-l" (format "%s" limit)))
 261               (when shortlog (list "--template" (car vc-hg-root-log-format)))
 262               vc-hg-log-switches)))))
 263
 264 (defvar log-view-message-re)
 265 (defvar log-view-file-re)
 266 (defvar log-view-font-lock-keywords)
 267 (defvar log-view-per-file-logs)
 268 (defvar log-view-expanded-log-entry-function)
 269
 270 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
 271   (require 'add-log) ;; we need the add-log faces
 272   (set (make-local-variable 'log-view-file-re) "\\`a\\`")
 273   (set (make-local-variable 'log-view-per-file-logs) nil)
 274   (set (make-local-variable 'log-view-message-re)
 275        (if (eq vc-log-view-type 'short)
 276            (cadr vc-hg-root-log-format)
 277          "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
 278   ;; Allow expanding short log entries
 279   (when (eq vc-log-view-type 'short)
 280     (setq truncate-lines t)
 281     (set (make-local-variable 'log-view-expanded-log-entry-function)
 282          'vc-hg-expanded-log-entry))
 283   (set (make-local-variable 'log-view-font-lock-keywords)
 284        (if (eq vc-log-view-type 'short)
 285            (list (cons (nth 1 vc-hg-root-log-format)
 286                        (nth 2 vc-hg-root-log-format)))
 287          (append
 288           log-view-font-lock-keywords
 289           '(
 290             ;; Handle the case:
 291             ;; user: FirstName LastName <foo@bar>
 292             ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 293              (1 'change-log-name)
 294              (2 'change-log-email))
 295             ;; Handle the cases:
 296             ;; user: foo@bar
 297             ;; and
 298             ;; user: foo
 299             ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
 300              (1 'change-log-email))
 301             ("^date: \\(.+\\)" (1 'change-log-date))
 302             ("^tag: +\\([^ ]+\\)$" (1 'highlight))
 303             ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
 304
 305 (defun vc-hg-diff (files &optional oldvers newvers buffer)
 306   "Get a difference report using hg between two revisions of FILES."
 307   (let* ((firstfile (car files))
 308          (working (and firstfile (vc-working-revision firstfile))))
 309     (when (and (equal oldvers working) (not newvers))
 310       (setq oldvers nil))
 311     (when (and (not oldvers) newvers)
 312       (setq oldvers working))
 313     (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
 314            (append
 315             (vc-switches 'hg 'diff)
 316             (when oldvers
 317               (if newvers
 318                   (list "-r" oldvers "-r" newvers)
 319                 (list "-r" oldvers)))))))
 320
 321 (defun vc-hg-expanded-log-entry (revision)
 322   (with-temp-buffer
 323     (vc-hg-command t nil nil "log" "-r" revision)
 324     (goto-char (point-min))
 325     (unless (eobp)
 326       ;; Indent the expanded log entry.
 327       (indent-region (point-min) (point-max) 2)
 328       (goto-char (point-max))
 329       (buffer-string))))
 330
 331 (defun vc-hg-revision-table (files)
 332   (let ((default-directory (file-name-directory (car files))))
 333     (with-temp-buffer
 334       (vc-hg-command t nil files "log" "--template" "{rev} ")
 335       (split-string
 336        (buffer-substring-no-properties (point-min) (point-max))))))
 337
 338 ;; Modeled after the similar function in vc-cvs.el
 339 (defun vc-hg-revision-completion-table (files)
 340   (lexical-let ((files files)
 341                 table)
 342     (setq table (lazy-completion-table
 343                  table (lambda () (vc-hg-revision-table files))))
 344     table))
 345
 346 (defun vc-hg-annotate-command (file buffer &optional revision)
 347   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 348 Optional arg REVISION is a revision to annotate from."
 349   (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
 350                  (when revision (concat "-r" revision))))
 351
 352 (declare-function vc-annotate-convert-time "vc-annotate" (time))
 353
 354 ;; The format for one line output by "hg annotate -d -n" looks like this:
 355 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 356 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 357 ;; If the user has set the "--follow" option, the output looks like:
 358 ;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
 359 ;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
 360 (defconst vc-hg-annotate-re
 361   "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
 362
 363 (defun vc-hg-annotate-time ()
 364   (when (looking-at vc-hg-annotate-re)
 365     (goto-char (match-end 0))
 366     (vc-annotate-convert-time
 367      (date-to-time (match-string-no-properties 2)))))
 368
 369 (defun vc-hg-annotate-extract-revision-at-line ()
 370   (save-excursion
 371     (beginning-of-line)
 372     (when (looking-at vc-hg-annotate-re)
 373       (if (match-beginning 3)
 374           (match-string-no-properties 1)
 375         (cons (match-string-no-properties 1)
 376               (expand-file-name (match-string-no-properties 4)
 377                                 (vc-hg-root default-directory)))))))
 378
 379 (defun vc-hg-previous-revision (file rev)
 380   (let ((newrev (1- (string-to-number rev))))
 381     (when (>= newrev 0)
 382       (number-to-string newrev))))
 383
 384 (defun vc-hg-next-revision (file rev)
 385   (let ((newrev (1+ (string-to-number rev)))
 386         (tip-revision
 387          (with-temp-buffer
 388            (vc-hg-command t 0 nil "tip")
 389            (goto-char (point-min))
 390            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 391            (string-to-number (match-string-no-properties 1)))))
 392     ;; We don't want to exceed the maximum possible revision number, ie
 393     ;; the tip revision.
 394     (when (<= newrev tip-revision)
 395       (number-to-string newrev))))
 396
 397 ;; Modeled after the similar function in vc-bzr.el
 398 (defun vc-hg-delete-file (file)
 399   "Delete FILE and delete it in the hg repository."
 400   (condition-case ()
 401       (delete-file file)
 402     (file-error nil))
 403   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 404
 405 ;; Modeled after the similar function in vc-bzr.el
 406 (defun vc-hg-rename-file (old new)
 407   "Rename file from OLD to NEW using `hg mv'."
 408   (vc-hg-command nil 0 new "mv" old))
 409
 410 (defun vc-hg-register (files &optional rev comment)
 411   "Register FILES under hg.
 412 REV is ignored.
 413 COMMENT is ignored."
 414   (vc-hg-command nil 0 files "add"))
 415
 416 (defun vc-hg-create-repo ()
 417   "Create a new Mercurial repository."
 418   (vc-hg-command nil 0 nil "init"))
 419
 420 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 421
 422 ;; Modeled after the similar function in vc-bzr.el
 423 (defun vc-hg-could-register (file)
 424   "Return non-nil if FILE could be registered under hg."
 425   (and (vc-hg-responsible-p file)      ; shortcut
 426        (condition-case ()
 427            (with-temp-buffer
 428              (vc-hg-command t nil file "add" "--dry-run"))
 429              ;; The command succeeds with no output if file is
 430              ;; registered.
 431          (error))))
 432
 433 ;; FIXME: This would remove the file. Is that correct?
 434 ;; (defun vc-hg-unregister (file)
 435 ;;   "Unregister FILE from hg."
 436 ;;   (vc-hg-command nil nil file "remove"))
 437
 438 (declare-function log-edit-extract-headers "log-edit" (headers string))
 439
 440 (defun vc-hg-checkin (files rev comment)
 441   "Hg-specific version of `vc-backend-checkin'.
 442 REV is ignored."
 443   (apply 'vc-hg-command nil 0 files
 444          (nconc (list "commit" "-m")
 445                 (log-edit-extract-headers '(("Author" . "--user")
 446                                             ("Date" . "--date"))
 447                                           comment))))
 448
 449 (defun vc-hg-find-revision (file rev buffer)
 450   (let ((coding-system-for-read 'binary)
 451         (coding-system-for-write 'binary))
 452     (if rev
 453         (vc-hg-command buffer 0 file "cat" "-r" rev)
 454       (vc-hg-command buffer 0 file "cat"))))
 455
 456 ;; Modeled after the similar function in vc-bzr.el
 457 (defun vc-hg-checkout (file &optional editable rev)
 458   "Retrieve a revision of FILE.
 459 EDITABLE is ignored.
 460 REV is the revision to check out into WORKFILE."
 461   (let ((coding-system-for-read 'binary)
 462         (coding-system-for-write 'binary))
 463   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 464     (if rev
 465         (vc-hg-command t 0 file "cat" "-r" rev)
 466       (vc-hg-command t 0 file "cat")))))
 467
 468 ;; Modeled after the similar function in vc-bzr.el
 469 (defun vc-hg-workfile-unchanged-p (file)
 470   (eq 'up-to-date (vc-hg-state file)))
 471
 472 ;; Modeled after the similar function in vc-bzr.el
 473 (defun vc-hg-revert (file &optional contents-done)
 474   (unless contents-done
 475     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 476
 477 ;;; Hg specific functionality.
 478
 479 (defvar vc-hg-extra-menu-map
 480   (let ((map (make-sparse-keymap)))
 481     map))
 482
 483 (defun vc-hg-extra-menu () vc-hg-extra-menu-map)
 484
 485 (defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
 486
 487 (defvar log-view-vc-backend)
 488
 489 (defstruct (vc-hg-extra-fileinfo
 490             (:copier nil)
 491             (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
 492             (:conc-name vc-hg-extra-fileinfo->))
 493   rename-state        ;; rename or copy state
 494   extra-name)         ;; original name for copies and rename targets, new name for
 495
 496 (declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
 497
 498 (defun vc-hg-dir-printer (info)
 499   "Pretty-printer for the vc-dir-fileinfo structure."
 500   (let ((extra (vc-dir-fileinfo->extra info)))
 501     (vc-default-dir-printer 'Hg info)
 502     (when extra
 503       (insert (propertize
 504                (format "   (%s %s)"
 505                        (case (vc-hg-extra-fileinfo->rename-state extra)
 506                          (copied "copied from")
 507                          (renamed-from "renamed from")
 508                          (renamed-to "renamed to"))
 509                        (vc-hg-extra-fileinfo->extra-name extra))
 510                'face 'font-lock-comment-face)))))
 511
 512 (defun vc-hg-after-dir-status (update-function)
 513   (let ((status-char nil)
 514         (file nil)
 515         (translation '((?= . up-to-date)
 516                        (?C . up-to-date)
 517                        (?A . added)
 518                        (?R . removed)
 519                        (?M . edited)
 520                        (?I . ignored)
 521                        (?! . missing)
 522                        (?  . copy-rename-line)
 523                        (?? . unregistered)))
 524         (translated nil)
 525         (result nil)
 526         (last-added nil)
 527         (last-line-copy nil))
 528       (goto-char (point-min))
 529       (while (not (eobp))
 530         (setq translated (cdr (assoc (char-after) translation)))
 531         (setq file
 532               (buffer-substring-no-properties (+ (point) 2)
 533                                               (line-end-position)))
 534         (cond ((not translated)
 535                (setq last-line-copy nil))
 536               ((eq translated 'up-to-date)
 537                (setq last-line-copy nil))
 538               ((eq translated 'copy-rename-line)
 539                ;; For copied files the output looks like this:
 540                ;; A COPIED_FILE_NAME
 541                ;;   ORIGINAL_FILE_NAME
 542                (setf (nth 2 last-added)
 543                      (vc-hg-create-extra-fileinfo 'copied file))
 544                (setq last-line-copy t))
 545               ((and last-line-copy (eq translated 'removed))
 546                ;; For renamed files the output looks like this:
 547                ;; A NEW_FILE_NAME
 548                ;;   ORIGINAL_FILE_NAME
 549                ;; R ORIGINAL_FILE_NAME
 550                ;; We need to adjust the previous entry to not think it is a copy.
 551                (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
 552                      'renamed-from)
 553                (push (list file translated
 554                            (vc-hg-create-extra-fileinfo
 555                             'renamed-to (nth 0 last-added))) result)
 556                (setq last-line-copy nil))
 557               (t
 558                (setq last-added (list file translated nil))
 559                (push last-added result)
 560                (setq last-line-copy nil)))
 561         (forward-line))
 562       (funcall update-function result)))
 563
 564 (defun vc-hg-dir-status (dir update-function)
 565   (vc-hg-command (current-buffer) 'async dir "status" "-C")
 566   (vc-exec-after
 567    `(vc-hg-after-dir-status (quote ,update-function))))
 568
 569 (defun vc-hg-dir-status-files (dir files default-state update-function)
 570   (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
 571   (vc-exec-after
 572    `(vc-hg-after-dir-status (quote ,update-function))))
 573
 574 (defun vc-hg-dir-extra-header (name &rest commands)
 575   (concat (propertize name 'face 'font-lock-type-face)
 576           (propertize
 577            (with-temp-buffer
 578              (apply 'vc-hg-command (current-buffer) 0 nil commands)
 579              (buffer-substring-no-properties (point-min) (1- (point-max))))
 580            'face 'font-lock-variable-name-face)))
 581
 582 (defun vc-hg-dir-extra-headers (dir)
 583   "Generate extra status headers for a Mercurial tree."
 584   (let ((default-directory dir))
 585     (concat
 586      (vc-hg-dir-extra-header "Root       : " "root") "\n"
 587      (vc-hg-dir-extra-header "Branch     : " "id" "-b") "\n"
 588      (vc-hg-dir-extra-header "Tags       : " "id" "-t") ; "\n"
 589      ;; these change after each commit
 590      ;; (vc-hg-dir-extra-header "Local num  : " "id" "-n") "\n"
 591      ;; (vc-hg-dir-extra-header "Global id  : " "id" "-i")
 592      )))
 593
 594 (defun vc-hg-log-incoming (buffer remote-location)
 595   (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
 596                                                 remote-location)))
 597
 598 (defun vc-hg-log-outgoing (buffer remote-location)
 599   (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
 600                                                 remote-location)))
 601
 602 (declare-function log-view-get-marked "log-view" ())
 603
 604 ;; XXX maybe also add key bindings for these functions.
 605 (defun vc-hg-push ()
 606   (interactive)
 607   (let ((marked-list (log-view-get-marked)))
 608     (if marked-list
 609         (apply #'vc-hg-command
 610                nil 0 nil
 611                "push"
 612                (apply 'nconc
 613                       (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
 614       (error "No log entries selected for push"))))
 615
 616 (defun vc-hg-pull (prompt)
 617   "Issue a Mercurial pull command.
 618 If called interactively with a set of marked Log View buffers,
 619 call \"hg pull -r REVS\" to pull in the specified revisions REVS.
 620
 621 With a prefix argument or if PROMPT is non-nil, prompt for a
 622 specific Mercurial pull command.  The default is \"hg pull -u\",
 623 which fetches changesets from the default remote repository and
 624 then attempts to update the working directory."
 625   (interactive "P")
 626   (let (marked-list)
 627     ;; The `vc-hg-pull' command existed before the `pull' VC action
 628     ;; was implemented.  Keep it for backward compatibility.
 629     (if (and (called-interactively-p 'interactive)
 630              (setq marked-list (log-view-get-marked)))
 631         (apply #'vc-hg-command
 632                nil 0 nil
 633                "pull"
 634                (apply 'nconc
 635                       (mapcar (lambda (arg) (list "-r" arg))
 636                               marked-list)))
 637       (let* ((root (vc-hg-root default-directory))
 638              (buffer (format "*vc-hg : %s*" (expand-file-name root)))
 639              (command "pull")
 640              (hg-program vc-hg-program)
 641              ;; Fixme: before updating the working copy to the latest
 642              ;; state, should check if it's visiting an old revision.
 643              (args '("-u")))
 644         ;; If necessary, prompt for the exact command.
 645         (when prompt
 646           (setq args (split-string
 647                       (read-shell-command "Run Hg (like this): "
 648                                           (format "%s pull -u" hg-program)
 649                                           'vc-hg-history)
 650                       " " t))
 651           (setq hg-program (car  args)
 652                 command    (cadr args)
 653                 args       (cddr args)))
 654         (apply 'vc-do-async-command buffer root hg-program
 655                command args)
 656         (vc-set-async-update buffer)))))
 657
 658 (defun vc-hg-merge-branch ()
 659   "Merge incoming changes into the current working directory.
 660 This runs the command \"hg merge\"."
 661   (let* ((root (vc-hg-root default-directory))
 662          (buffer (format "*vc-hg : %s*" (expand-file-name root))))
 663     (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
 664     (vc-set-async-update buffer)))
 665
 666 ;;; Internal functions
 667
 668 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
 669   "A wrapper around `vc-do-command' for use in vc-hg.el.
 670 This function differs from vc-do-command in that it invokes
 671 `vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
 672   (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
 673          (if (stringp vc-hg-global-switches)
 674              (cons vc-hg-global-switches flags)
 675            (append vc-hg-global-switches
 676                    flags))))
 677
 678 (defun vc-hg-root (file)
 679   (vc-find-root file ".hg"))
 680
 681 (provide 'vc-hg)
 682
 683 ;;; vc-hg.el ends here