lisp/vc/vc-hg.el

   1 ;;; vc-hg.el --- VC backend for the mercurial version control system
   2
   3 ;; Copyright (C) 2006-2011 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 (defcustom vc-hg-global-switches nil
 120   "Global switches to pass to any Hg command."
 121   :type '(choice (const :tag "None" nil)
 122          (string :tag "Argument String")
 123          (repeat :tag "Argument List" :value ("") string))
 124   :version "22.2"
 125   :group 'vc)
 126
 127 (defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
 128   "String or list of strings specifying switches for Hg diff under VC.
 129 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
 130   :type '(choice (const :tag "Unspecified" nil)
 131                  (const :tag "None" t)
 132                  (string :tag "Argument String")
 133                  (repeat :tag "Argument List" :value ("") string))
 134   :version "23.1"
 135   :group 'vc)
 136
 137 (defcustom vc-hg-program "hg"
 138   "Name of the Mercurial executable (excluding any arguments)."
 139   :type 'string
 140   :group 'vc)
 141
 142 (defcustom vc-hg-root-log-format
 143   '("{rev}:{tags}: {author|person} {date|shortdate} {desc|firstline}\\n"
 144     "^\\([0-9]+\\):\\([^:]*\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
 145     ((1 'log-view-message-face)
 146      (2 'change-log-list)
 147      (3 'change-log-name)
 148      (4 'change-log-date)))
 149   "Mercurial log template for `vc-print-root-log'.
 150 This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE
 151 is the \"--template\" argument string to pass to Mercurial,
 152 REGEXP is a regular expression matching the resulting Mercurial
 153 output, and KEYWORDS is a list of `font-lock-keywords' for
 154 highlighting the Log View buffer."
 155   :type '(list string string (repeat sexp))
 156   :group 'vc
 157   :version "24.1")
 158
 159 \f
 160 ;;; Properties of the backend
 161
 162 (defvar vc-hg-history nil)
 163
 164 (defun vc-hg-revision-granularity () 'repository)
 165 (defun vc-hg-checkout-model (files) 'implicit)
 166
 167 ;;; State querying functions
 168
 169 ;;;###autoload (defun vc-hg-registered (file)
 170 ;;;###autoload   "Return non-nil if FILE is registered with hg."
 171 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
 172 ;;;###autoload       (progn
 173 ;;;###autoload         (load "vc-hg")
 174 ;;;###autoload         (vc-hg-registered file))))
 175
 176 ;; Modeled after the similar function in vc-bzr.el
 177 (defun vc-hg-registered (file)
 178   "Return non-nil if FILE is registered with hg."
 179   (when (vc-hg-root file)           ; short cut
 180     (let ((state (vc-hg-state file)))  ; expensive
 181       (and state (not (memq state '(ignored unregistered)))))))
 182
 183 (defun vc-hg-state (file)
 184   "Hg-specific version of `vc-state'."
 185   (let*
 186       ((status nil)
 187        (default-directory (file-name-directory file))
 188        (out
 189         (with-output-to-string
 190           (with-current-buffer
 191               standard-output
 192             (setq status
 193                   (condition-case nil
 194                       ;; Ignore all errors.
 195                       (let ((process-environment
 196                              ;; Avoid localization of messages so we
 197                              ;; can parse the output.
 198                              (append (list "TERM=dumb" "LANGUAGE=C")
 199                                      process-environment)))
 200                         (process-file
 201                          vc-hg-program nil t nil
 202                          "--config" "alias.status=status"
 203                          "--config" "defaults.status="
 204                          "status" "-A" (file-relative-name file)))
 205                     ;; Some problem happened.  E.g. We can't find an `hg'
 206                     ;; executable.
 207                     (error nil)))))))
 208     (when (eq 0 status)
 209         (when (null (string-match ".*: No such file or directory$" out))
 210           (let ((state (aref out 0)))
 211             (cond
 212              ((eq state ?=) 'up-to-date)
 213              ((eq state ?A) 'added)
 214              ((eq state ?M) 'edited)
 215              ((eq state ?I) 'ignored)
 216              ((eq state ?R) 'removed)
 217              ((eq state ?!) 'missing)
 218              ((eq state ??) 'unregistered)
 219              ((eq state ?C) 'up-to-date) ;; Older mercurials use this
 220              (t 'up-to-date)))))))
 221
 222 (defun vc-hg-working-revision (file)
 223   "Hg-specific version of `vc-working-revision'."
 224   (let*
 225       ((status nil)
 226        (default-directory (file-name-directory file))
 227        ;; Avoid localization of messages so we can parse the output.
 228        (avoid-local-env (append (list "TERM=dumb" "LANGUAGE=C")
 229                                      process-environment))
 230        (out
 231         (with-output-to-string
 232           (with-current-buffer
 233               standard-output
 234             (setq status
 235                   (condition-case nil
 236                       (let ((process-environment avoid-local-env))
 237                         ;; Ignore all errors.
 238                         (process-file
 239                          vc-hg-program nil t nil
 240                          "--config" "alias.parents=parents"
 241                          "--config" "defaults.parents="
 242                          "parents" "--template" "{rev}" (file-relative-name file)))
 243                     ;; Some problem happened.  E.g. We can't find an `hg'
 244                     ;; executable.
 245                     (error nil)))))))
 246     (if (eq 0 status)
 247         out
 248       ;; Check if the file is in the 'added state, the above hg
 249       ;; command does not distinguish between 'added and 'unregistered.
 250       (setq status
 251             (condition-case nil
 252                 (let ((process-environment avoid-local-env))
 253                   (process-file
 254                    vc-hg-program nil nil nil
 255                    ;; We use "log" here, if there's a faster command
 256                    ;; that returns true for an 'added file and false
 257                    ;; for an 'unregistered one, we could use that.
 258                    "log" "-l1" (file-relative-name file)))
 259               ;; Some problem happened.  E.g. We can't find an `hg'
 260               ;; executable.
 261               (error nil)))
 262       (when (eq 0 status) "0"))))
 263
 264 ;;; History functions
 265
 266 (defcustom vc-hg-log-switches nil
 267   "String or list of strings specifying switches for hg log under VC."
 268   :type '(choice (const :tag "None" nil)
 269                  (string :tag "Argument String")
 270                  (repeat :tag "Argument List" :value ("") string))
 271   :group 'vc-hg)
 272
 273 (defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
 274   "Get change log associated with FILES."
 275   ;; `vc-do-command' creates the buffer, but we need it before running
 276   ;; the command.
 277   (vc-setup-buffer buffer)
 278   ;; If the buffer exists from a previous invocation it might be
 279   ;; read-only.
 280   (let ((inhibit-read-only t))
 281     (with-current-buffer
 282         buffer
 283       (apply 'vc-hg-command buffer 0 files "log"
 284              (nconc
 285               (when start-revision (list (format "-r%s:" start-revision)))
 286               (when limit (list "-l" (format "%s" limit)))
 287               (when shortlog (list "--template" (car vc-hg-root-log-format)))
 288               vc-hg-log-switches)))))
 289
 290 (defvar log-view-message-re)
 291 (defvar log-view-file-re)
 292 (defvar log-view-font-lock-keywords)
 293 (defvar log-view-per-file-logs)
 294 (defvar log-view-expanded-log-entry-function)
 295
 296 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
 297   (require 'add-log) ;; we need the add-log faces
 298   (set (make-local-variable 'log-view-file-re) "\\`a\\`")
 299   (set (make-local-variable 'log-view-per-file-logs) nil)
 300   (set (make-local-variable 'log-view-message-re)
 301        (if (eq vc-log-view-type 'short)
 302            (cadr vc-hg-root-log-format)
 303          "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
 304   ;; Allow expanding short log entries
 305   (when (eq vc-log-view-type 'short)
 306     (setq truncate-lines t)
 307     (set (make-local-variable 'log-view-expanded-log-entry-function)
 308          'vc-hg-expanded-log-entry))
 309   (set (make-local-variable 'log-view-font-lock-keywords)
 310        (if (eq vc-log-view-type 'short)
 311            (list (cons (nth 1 vc-hg-root-log-format)
 312                        (nth 2 vc-hg-root-log-format)))
 313          (append
 314           log-view-font-lock-keywords
 315           '(
 316             ;; Handle the case:
 317             ;; user: FirstName LastName <foo@bar>
 318             ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 319              (1 'change-log-name)
 320              (2 'change-log-email))
 321             ;; Handle the cases:
 322             ;; user: foo@bar
 323             ;; and
 324             ;; user: foo
 325             ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
 326              (1 'change-log-email))
 327             ("^date: \\(.+\\)" (1 'change-log-date))
 328             ("^tag: +\\([^ ]+\\)$" (1 'highlight))
 329             ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
 330
 331 (defun vc-hg-diff (files &optional oldvers newvers buffer)
 332   "Get a difference report using hg between two revisions of FILES."
 333   (let* ((firstfile (car files))
 334          (working (and firstfile (vc-working-revision firstfile))))
 335     (when (and (equal oldvers working) (not newvers))
 336       (setq oldvers nil))
 337     (when (and (not oldvers) newvers)
 338       (setq oldvers working))
 339     (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
 340            (append
 341             (vc-switches 'hg 'diff)
 342             (when oldvers
 343               (if newvers
 344                   (list "-r" oldvers "-r" newvers)
 345                 (list "-r" oldvers)))))))
 346
 347 (defun vc-hg-expanded-log-entry (revision)
 348   (with-temp-buffer
 349     (vc-hg-command t nil nil "log" "-r" revision)
 350     (goto-char (point-min))
 351     (unless (eobp)
 352       ;; Indent the expanded log entry.
 353       (indent-region (point-min) (point-max) 2)
 354       (goto-char (point-max))
 355       (buffer-string))))
 356
 357 (defun vc-hg-revision-table (files)
 358   (let ((default-directory (file-name-directory (car files))))
 359     (with-temp-buffer
 360       (vc-hg-command t nil files "log" "--template" "{rev} ")
 361       (split-string
 362        (buffer-substring-no-properties (point-min) (point-max))))))
 363
 364 ;; Modeled after the similar function in vc-cvs.el
 365 (defun vc-hg-revision-completion-table (files)
 366   (lexical-let ((files files)
 367                 table)
 368     (setq table (lazy-completion-table
 369                  table (lambda () (vc-hg-revision-table files))))
 370     table))
 371
 372 (defun vc-hg-annotate-command (file buffer &optional revision)
 373   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 374 Optional arg REVISION is a revision to annotate from."
 375   (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
 376                  (when revision (concat "-r" revision))))
 377
 378 (declare-function vc-annotate-convert-time "vc-annotate" (time))
 379
 380 ;; The format for one line output by "hg annotate -d -n" looks like this:
 381 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 382 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 383 ;; If the user has set the "--follow" option, the output looks like:
 384 ;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
 385 ;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
 386 (defconst vc-hg-annotate-re
 387   "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
 388
 389 (defun vc-hg-annotate-time ()
 390   (when (looking-at vc-hg-annotate-re)
 391     (goto-char (match-end 0))
 392     (vc-annotate-convert-time
 393      (date-to-time (match-string-no-properties 2)))))
 394
 395 (defun vc-hg-annotate-extract-revision-at-line ()
 396   (save-excursion
 397     (beginning-of-line)
 398     (when (looking-at vc-hg-annotate-re)
 399       (if (match-beginning 3)
 400           (match-string-no-properties 1)
 401         (cons (match-string-no-properties 1)
 402               (expand-file-name (match-string-no-properties 4)
 403                                 (vc-hg-root default-directory)))))))
 404
 405 (defun vc-hg-previous-revision (file rev)
 406   (let ((newrev (1- (string-to-number rev))))
 407     (when (>= newrev 0)
 408       (number-to-string newrev))))
 409
 410 (defun vc-hg-next-revision (file rev)
 411   (let ((newrev (1+ (string-to-number rev)))
 412         (tip-revision
 413          (with-temp-buffer
 414            (vc-hg-command t 0 nil "tip")
 415            (goto-char (point-min))
 416            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 417            (string-to-number (match-string-no-properties 1)))))
 418     ;; We don't want to exceed the maximum possible revision number, ie
 419     ;; the tip revision.
 420     (when (<= newrev tip-revision)
 421       (number-to-string newrev))))
 422
 423 ;; Modeled after the similar function in vc-bzr.el
 424 (defun vc-hg-delete-file (file)
 425   "Delete FILE and delete it in the hg repository."
 426   (condition-case ()
 427       (delete-file file)
 428     (file-error nil))
 429   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 430
 431 ;; Modeled after the similar function in vc-bzr.el
 432 (defun vc-hg-rename-file (old new)
 433   "Rename file from OLD to NEW using `hg mv'."
 434   (vc-hg-command nil 0 new "mv" old))
 435
 436 (defun vc-hg-register (files &optional rev comment)
 437   "Register FILES under hg.
 438 REV is ignored.
 439 COMMENT is ignored."
 440   (vc-hg-command nil 0 files "add"))
 441
 442 (defun vc-hg-create-repo ()
 443   "Create a new Mercurial repository."
 444   (vc-hg-command nil 0 nil "init"))
 445
 446 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 447
 448 ;; Modeled after the similar function in vc-bzr.el
 449 (defun vc-hg-could-register (file)
 450   "Return non-nil if FILE could be registered under hg."
 451   (and (vc-hg-responsible-p file)      ; shortcut
 452        (condition-case ()
 453            (with-temp-buffer
 454              (vc-hg-command t nil file "add" "--dry-run"))
 455              ;; The command succeeds with no output if file is
 456              ;; registered.
 457          (error))))
 458
 459 ;; FIXME: This would remove the file. Is that correct?
 460 ;; (defun vc-hg-unregister (file)
 461 ;;   "Unregister FILE from hg."
 462 ;;   (vc-hg-command nil nil file "remove"))
 463
 464 (declare-function log-edit-extract-headers "log-edit" (headers string))
 465
 466 (defun vc-hg-checkin (files rev comment)
 467   "Hg-specific version of `vc-backend-checkin'.
 468 REV is ignored."
 469   (apply 'vc-hg-command nil 0 files
 470          (nconc (list "commit" "-m")
 471                 (log-edit-extract-headers '(("Author" . "--user")
 472                                             ("Date" . "--date"))
 473                                           comment))))
 474
 475 (defun vc-hg-find-revision (file rev buffer)
 476   (let ((coding-system-for-read 'binary)
 477         (coding-system-for-write 'binary))
 478     (if rev
 479         (vc-hg-command buffer 0 file "cat" "-r" rev)
 480       (vc-hg-command buffer 0 file "cat"))))
 481
 482 ;; Modeled after the similar function in vc-bzr.el
 483 (defun vc-hg-checkout (file &optional editable rev)
 484   "Retrieve a revision of FILE.
 485 EDITABLE is ignored.
 486 REV is the revision to check out into WORKFILE."
 487   (let ((coding-system-for-read 'binary)
 488         (coding-system-for-write 'binary))
 489   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 490     (if rev
 491         (vc-hg-command t 0 file "cat" "-r" rev)
 492       (vc-hg-command t 0 file "cat")))))
 493
 494 ;; Modeled after the similar function in vc-bzr.el
 495 (defun vc-hg-workfile-unchanged-p (file)
 496   (eq 'up-to-date (vc-hg-state file)))
 497
 498 ;; Modeled after the similar function in vc-bzr.el
 499 (defun vc-hg-revert (file &optional contents-done)
 500   (unless contents-done
 501     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 502
 503 ;;; Hg specific functionality.
 504
 505 (defvar vc-hg-extra-menu-map
 506   (let ((map (make-sparse-keymap)))
 507     map))
 508
 509 (defun vc-hg-extra-menu () vc-hg-extra-menu-map)
 510
 511 (defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
 512
 513 (defvar log-view-vc-backend)
 514
 515 (defstruct (vc-hg-extra-fileinfo
 516             (:copier nil)
 517             (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
 518             (:conc-name vc-hg-extra-fileinfo->))
 519   rename-state        ;; rename or copy state
 520   extra-name)         ;; original name for copies and rename targets, new name for
 521
 522 (declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
 523
 524 (defun vc-hg-dir-printer (info)
 525   "Pretty-printer for the vc-dir-fileinfo structure."
 526   (let ((extra (vc-dir-fileinfo->extra info)))
 527     (vc-default-dir-printer 'Hg info)
 528     (when extra
 529       (insert (propertize
 530                (format "   (%s %s)"
 531                        (case (vc-hg-extra-fileinfo->rename-state extra)
 532                          (copied "copied from")
 533                          (renamed-from "renamed from")
 534                          (renamed-to "renamed to"))
 535                        (vc-hg-extra-fileinfo->extra-name extra))
 536                'face 'font-lock-comment-face)))))
 537
 538 (defun vc-hg-after-dir-status (update-function)
 539   (let ((status-char nil)
 540         (file nil)
 541         (translation '((?= . up-to-date)
 542                        (?C . up-to-date)
 543                        (?A . added)
 544                        (?R . removed)
 545                        (?M . edited)
 546                        (?I . ignored)
 547                        (?! . missing)
 548                        (?  . copy-rename-line)
 549                        (?? . unregistered)))
 550         (translated nil)
 551         (result nil)
 552         (last-added nil)
 553         (last-line-copy nil))
 554       (goto-char (point-min))
 555       (while (not (eobp))
 556         (setq translated (cdr (assoc (char-after) translation)))
 557         (setq file
 558               (buffer-substring-no-properties (+ (point) 2)
 559                                               (line-end-position)))
 560         (cond ((not translated)
 561                (setq last-line-copy nil))
 562               ((eq translated 'up-to-date)
 563                (setq last-line-copy nil))
 564               ((eq translated 'copy-rename-line)
 565                ;; For copied files the output looks like this:
 566                ;; A COPIED_FILE_NAME
 567                ;;   ORIGINAL_FILE_NAME
 568                (setf (nth 2 last-added)
 569                      (vc-hg-create-extra-fileinfo 'copied file))
 570                (setq last-line-copy t))
 571               ((and last-line-copy (eq translated 'removed))
 572                ;; For renamed files the output looks like this:
 573                ;; A NEW_FILE_NAME
 574                ;;   ORIGINAL_FILE_NAME
 575                ;; R ORIGINAL_FILE_NAME
 576                ;; We need to adjust the previous entry to not think it is a copy.
 577                (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
 578                      'renamed-from)
 579                (push (list file translated
 580                            (vc-hg-create-extra-fileinfo
 581                             'renamed-to (nth 0 last-added))) result)
 582                (setq last-line-copy nil))
 583               (t
 584                (setq last-added (list file translated nil))
 585                (push last-added result)
 586                (setq last-line-copy nil)))
 587         (forward-line))
 588       (funcall update-function result)))
 589
 590 (defun vc-hg-dir-status (dir update-function)
 591   (vc-hg-command (current-buffer) 'async dir "status" "-C")
 592   (vc-exec-after
 593    `(vc-hg-after-dir-status (quote ,update-function))))
 594
 595 (defun vc-hg-dir-status-files (dir files default-state update-function)
 596   (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
 597   (vc-exec-after
 598    `(vc-hg-after-dir-status (quote ,update-function))))
 599
 600 (defun vc-hg-dir-extra-header (name &rest commands)
 601   (concat (propertize name 'face 'font-lock-type-face)
 602           (propertize
 603            (with-temp-buffer
 604              (apply 'vc-hg-command (current-buffer) 0 nil commands)
 605              (buffer-substring-no-properties (point-min) (1- (point-max))))
 606            'face 'font-lock-variable-name-face)))
 607
 608 (defun vc-hg-dir-extra-headers (dir)
 609   "Generate extra status headers for a Mercurial tree."
 610   (let ((default-directory dir))
 611     (concat
 612      (vc-hg-dir-extra-header "Root       : " "root") "\n"
 613      (vc-hg-dir-extra-header "Branch     : " "id" "-b") "\n"
 614      (vc-hg-dir-extra-header "Tags       : " "id" "-t") ; "\n"
 615      ;; these change after each commit
 616      ;; (vc-hg-dir-extra-header "Local num  : " "id" "-n") "\n"
 617      ;; (vc-hg-dir-extra-header "Global id  : " "id" "-i")
 618      )))
 619
 620 (defun vc-hg-log-incoming (buffer remote-location)
 621   (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
 622                                                 remote-location)))
 623
 624 (defun vc-hg-log-outgoing (buffer remote-location)
 625   (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
 626                                                 remote-location)))
 627
 628 (declare-function log-view-get-marked "log-view" ())
 629
 630 ;; XXX maybe also add key bindings for these functions.
 631 (defun vc-hg-push ()
 632   (interactive)
 633   (let ((marked-list (log-view-get-marked)))
 634     (if marked-list
 635         (apply #'vc-hg-command
 636                nil 0 nil
 637                "push"
 638                (apply 'nconc
 639                       (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
 640       (error "No log entries selected for push"))))
 641
 642 (defun vc-hg-pull (prompt)
 643   "Issue a Mercurial pull command.
 644 If called interactively with a set of marked Log View buffers,
 645 call \"hg pull -r REVS\" to pull in the specified revisions REVS.
 646
 647 With a prefix argument or if PROMPT is non-nil, prompt for a
 648 specific Mercurial pull command.  The default is \"hg pull -u\",
 649 which fetches changesets from the default remote repository and
 650 then attempts to update the working directory."
 651   (interactive "P")
 652   (let (marked-list)
 653     ;; The `vc-hg-pull' command existed before the `pull' VC action
 654     ;; was implemented.  Keep it for backward compatibility.
 655     (if (and (called-interactively-p 'interactive)
 656              (setq marked-list (log-view-get-marked)))
 657         (apply #'vc-hg-command
 658                nil 0 nil
 659                "pull"
 660                (apply 'nconc
 661                       (mapcar (lambda (arg) (list "-r" arg))
 662                               marked-list)))
 663       (let* ((root (vc-hg-root default-directory))
 664              (buffer (format "*vc-hg : %s*" (expand-file-name root)))
 665              (command "pull")
 666              (hg-program vc-hg-program)
 667              ;; Fixme: before updating the working copy to the latest
 668              ;; state, should check if it's visiting an old revision.
 669              (args '("-u")))
 670         ;; If necessary, prompt for the exact command.
 671         (when prompt
 672           (setq args (split-string
 673                       (read-shell-command "Run Hg (like this): "
 674                                           (format "%s pull -u" hg-program)
 675                                           'vc-hg-history)
 676                       " " t))
 677           (setq hg-program (car  args)
 678                 command    (cadr args)
 679                 args       (cddr args)))
 680         (apply 'vc-do-async-command buffer root hg-program
 681                command args)
 682         (vc-set-async-update buffer)))))
 683
 684 (defun vc-hg-merge-branch ()
 685   "Merge incoming changes into the current working directory.
 686 This runs the command \"hg merge\"."
 687   (let* ((root (vc-hg-root default-directory))
 688          (buffer (format "*vc-hg : %s*" (expand-file-name root))))
 689     (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
 690     (vc-set-async-update buffer)))
 691
 692 ;;; Internal functions
 693
 694 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
 695   "A wrapper around `vc-do-command' for use in vc-hg.el.
 696 This function differs from vc-do-command in that it invokes
 697 `vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
 698   (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
 699          (if (stringp vc-hg-global-switches)
 700              (cons vc-hg-global-switches flags)
 701            (append vc-hg-global-switches
 702                    flags))))
 703
 704 (defun vc-hg-root (file)
 705   (vc-find-root file ".hg"))
 706
 707 (provide 'vc-hg)
 708
 709 ;;; vc-hg.el ends here