vc-hg.el 26.1 KB
Newer Older
Dan Nicolaescu's avatar
Dan Nicolaescu committed
1 2
;;; vc-hg.el --- VC backend for the mercurial version control system

3
;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
4

Dan Nicolaescu's avatar
Dan Nicolaescu committed
5
;; Author: Ivan Kanis
6
;; Keywords: vc tools
7
;; Package: vc
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Dan Nicolaescu's avatar
Dan Nicolaescu committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
15 16 17 18 19 20

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

Dan Nicolaescu's avatar
Dan Nicolaescu committed
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/>.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
23 24 25 26 27

;;; Commentary:

;; This is a mercurial version control backend

28 29 30 31 32 33 34 35
;;; Thanks:

;;; Bugs:

;;; Installation:

;;; Todo:

36
;; 1) Implement the rest of the vc interface. See the comment at the
Dan Nicolaescu's avatar
Dan Nicolaescu committed
37 38 39
;; beginning of vc.el. The current status is:

;; FUNCTION NAME                               STATUS
40 41 42
;; BACKEND PROPERTIES
;; * revision-granularity                      OK
;; STATE-QUERYING FUNCTIONS
Dan Nicolaescu's avatar
Dan Nicolaescu committed
43 44
;; * registered (file)                         OK
;; * state (file)                              OK
45
;; - state-heuristic (file)                    NOT NEEDED
46 47
;; - dir-status (dir update-function)          OK
;; - dir-status-files (dir files ds uf)        OK
48 49
;; - dir-extra-headers (dir)                   OK
;; - dir-printer (fileinfo)                    OK
Eric S. Raymond's avatar
Eric S. Raymond committed
50
;; * working-revision (file)                   OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
51
;; - latest-on-branch-p (file)                 ??
52
;; * checkout-model (files)                    OK
53
;; - workfile-unchanged-p (file)               OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
54 55
;; - mode-line-string (file)                   NOT NEEDED
;; STATE-CHANGING FUNCTIONS
56
;; * register (files &optional rev comment)    OK
57
;; * create-repo ()                            OK
58
;; - init-revision ()                          NOT NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
59 60 61 62
;; - responsible-p (file)                      OK
;; - could-register (file)                     OK
;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
;; - 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
Dan Nicolaescu's avatar
Dan Nicolaescu committed
66
;; * revert (file &optional contents-done)     OK
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
67
;; - rollback (files)                          ?? PROBABLY NOT NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
68 69
;; - merge (file rev1 rev2)                    NEEDED
;; - merge-news (file)                         NEEDED
70
;; - steal-lock (file &optional revision)      NOT NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
71
;; HISTORY FUNCTIONS
72
;; * print-log (files buffer &optional shortlog start-revision limit) OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
73
;; - log-view-mode ()                          OK
74
;; - show-log-entry (revision)                 NOT NEEDED, DEFAULT IS GOOD
Dan Nicolaescu's avatar
Dan Nicolaescu committed
75 76
;; - comment-history (file)                    NOT NEEDED
;; - update-changelog (files)                  NOT NEEDED
77
;; * diff (files &optional rev1 rev2 buffer)   OK
78
;; - revision-completion-table (files)         OK?
Dan Nicolaescu's avatar
Dan Nicolaescu committed
79 80
;; - annotate-command (file buf &optional rev) OK
;; - annotate-time ()                          OK
81
;; - annotate-current-time ()                  NOT NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
82
;; - annotate-extract-revision-at-line ()      OK
83
;; TAG SYSTEM
84 85
;; - create-tag (dir name branchp)             NEEDED
;; - retrieve-tag (dir name update)            NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
86 87
;; MISCELLANEOUS
;; - make-version-backups-p (file)             ??
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
88
;; - repository-hostname (dirname)             ??
89 90
;; - previous-revision (file rev)              OK
;; - next-revision (file rev)                  OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
91 92 93 94 95
;; - check-headers ()                          ??
;; - clear-headers ()                          ??
;; - delete-file (file)                        TEST IT
;; - rename-file (old new)                     OK
;; - find-file-hook ()                         PROBABLY NOT NEEDED
Dan Nicolaescu's avatar
Dan Nicolaescu committed
96

97
;; 2) Implement Stefan Monnier's advice:
98 99
;; vc-hg-registered and vc-hg-state
;; Both of those functions should be super extra careful to fail gracefully in
Dan Nicolaescu's avatar
Dan Nicolaescu committed
100
;; unexpected circumstances. The reason this is important is that any error
101 102 103 104 105
;; there will prevent the user from even looking at the file :-(
;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
;; mercurial's control and extracting the current revision should be done
;; without even using `hg' (this way even if you don't have `hg' installed,
;; Emacs is able to tell you this file is under mercurial's control).
Dan Nicolaescu's avatar
Dan Nicolaescu committed
106

107
;;; History:
108
;;
Dan Nicolaescu's avatar
Dan Nicolaescu committed
109 110 111 112

;;; Code:

(eval-when-compile
Dan Nicolaescu's avatar
Dan Nicolaescu committed
113
  (require 'cl)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
114 115
  (require 'vc)
  (require 'vc-dir))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
116 117 118 119

;;; Customization options

(defcustom vc-hg-global-switches nil
Lute Kamstra's avatar
Lute Kamstra committed
120
  "Global switches to pass to any Hg command."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
121 122
  :type '(choice (const :tag "None" nil)
         (string :tag "Argument String")
Glenn Morris's avatar
Glenn Morris committed
123
         (repeat :tag "Argument List" :value ("") string))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
124
  :version "22.2"
Dan Nicolaescu's avatar
Dan Nicolaescu committed
125 126
  :group 'vc)

Glenn Morris's avatar
Glenn Morris committed
127 128 129
(defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
  "String or list of strings specifying switches for Hg diff under VC.
If nil, use the value of `vc-diff-switches'.  If t, use no switches."
130
  :type '(choice (const :tag "Unspecified" nil)
131 132 133
                 (const :tag "None" t)
                 (string :tag "Argument String")
                 (repeat :tag "Argument List" :value ("") string))
134 135 136
  :version "23.1"
  :group 'vc)

137 138 139 140
(defcustom vc-hg-program "hg"
  "Name of the Mercurial executable (excluding any arguments)."
  :type 'string
  :group 'vc)
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158

(defcustom vc-hg-root-log-format
  '("{rev}:{tags}: {author|person} {date|shortdate} {desc|firstline}\\n"
    "^\\([0-9]+\\):\\([^:]*\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
    ((1 'log-view-message-face)
     (2 'change-log-list)
     (3 'change-log-name)
     (4 'change-log-date)))
  "Mercurial log template for `vc-print-root-log'.
This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE
is the \"--template\" argument string to pass to Mercurial,
REGEXP is a regular expression matching the resulting Mercurial
output, and KEYWORDS is a list of `font-lock-keywords' for
highlighting the Log View buffer."
  :type '(list string string (repeat sexp))
  :group 'vc
  :version "24.1")

159 160 161

;;; Properties of the backend

162 163
(defvar vc-hg-history nil)

164 165
(defun vc-hg-revision-granularity () 'repository)
(defun vc-hg-checkout-model (files) 'implicit)
166

Dan Nicolaescu's avatar
Dan Nicolaescu committed
167 168
;;; State querying functions

169 170 171 172 173 174 175
;;;###autoload (defun vc-hg-registered (file)
;;;###autoload   "Return non-nil if FILE is registered with hg."
;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
;;;###autoload       (progn
;;;###autoload         (load "vc-hg")
;;;###autoload         (vc-hg-registered file))))

Glenn Morris's avatar
Glenn Morris committed
176
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
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)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
182 183

(defun vc-hg-state (file)
184
  "Hg-specific version of `vc-state'."
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
185
  (let*
186
      ((status nil)
187
       (default-directory (file-name-directory file))
188
       (out
189 190 191 192 193 194
        (with-output-to-string
          (with-current-buffer
              standard-output
            (setq status
                  (condition-case nil
                      ;; Ignore all errors.
195
		      (let ((process-environment
196 197
			     ;; Avoid localization of messages so we
			     ;; can parse the output.
198
			     (append (list "TERM=dumb" "LANGUAGE=C")
199 200
				     process-environment)))
			(process-file
201
			 vc-hg-program nil t nil
202 203
			 "--config" "alias.status=status"
			 "--config" "defaults.status="
204
			 "status" "-A" (file-relative-name file)))
205 206 207
                    ;; Some problem happened.  E.g. We can't find an `hg'
                    ;; executable.
                    (error nil)))))))
208
    (when (eq 0 status)
209 210 211 212 213 214 215 216 217 218
        (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)
Paul Eggert's avatar
Paul Eggert committed
219
             ((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
220
             (t 'up-to-date)))))))
221

Eric S. Raymond's avatar
Eric S. Raymond committed
222 223
(defun vc-hg-working-revision (file)
  "Hg-specific version of `vc-working-revision'."
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
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 232 233 234 235
        (with-output-to-string
          (with-current-buffer
              standard-output
            (setq status
                  (condition-case nil
236
		      (let ((process-environment avoid-local-env))
237 238
			;; Ignore all errors.
			(process-file
239
			 vc-hg-program nil t nil
240 241
			 "--config" "alias.parents=parents"
			 "--config" "defaults.parents="
242
			 "parents" "--template" "{rev}" (file-relative-name file)))
243 244 245
                    ;; Some problem happened.  E.g. We can't find an `hg'
                    ;; executable.
                    (error nil)))))))
246 247 248 249 250 251 252 253
    (if (eq 0 status)
	out
      ;; Check if the file is in the 'added state, the above hg
      ;; command does not distinguish between 'added and 'unregistered.
      (setq status
	    (condition-case nil
		(let ((process-environment avoid-local-env))
		  (process-file
254
		   vc-hg-program nil nil nil
255 256 257 258 259 260 261 262
		   ;; We use "log" here, if there's a faster command
		   ;; that returns true for an 'added file and false
		   ;; for an 'unregistered one, we could use that.
		   "log" "-l1" (file-relative-name file)))
	      ;; Some problem happened.  E.g. We can't find an `hg'
	      ;; executable.
	      (error nil)))
      (when (eq 0 status) "0"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
263 264 265

;;; History functions

266 267 268 269 270 271 272
(defcustom vc-hg-log-switches nil
  "String or list of strings specifying switches for hg log under VC."
  :type '(choice (const :tag "None" nil)
                 (string :tag "Argument String")
                 (repeat :tag "Argument List" :value ("") string))
  :group 'vc-hg)

273
(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
274
  "Get change log associated with FILES."
275 276 277 278 279 280
  ;; `vc-do-command' creates the buffer, but we need it before running
  ;; the command.
  (vc-setup-buffer buffer)
  ;; If the buffer exists from a previous invocation it might be
  ;; read-only.
  (let ((inhibit-read-only t))
281 282
    (with-current-buffer
	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)))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
289

290 291 292
(defvar log-view-message-re)
(defvar log-view-file-re)
(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 299
  (set (make-local-variable 'log-view-file-re) "\\`a\\`")
  (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 305 306 307 308
  ;; Allow expanding short log entries
  (when (eq vc-log-view-type 'short)
    (setq truncate-lines t)
    (set (make-local-variable 'log-view-expanded-log-entry-function)
	 'vc-hg-expanded-log-entry))
309
  (set (make-local-variable 'log-view-font-lock-keywords)
310
       (if (eq vc-log-view-type 'short)
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
	   (list (cons (nth 1 vc-hg-root-log-format)
		       (nth 2 vc-hg-root-log-format)))
	 (append
	  log-view-font-lock-keywords
	  '(
	    ;; Handle the case:
	    ;; user: FirstName LastName <foo@bar>
	    ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
	     (1 'change-log-name)
	     (2 'change-log-email))
	    ;; Handle the cases:
	    ;; user: foo@bar
	    ;; and
	    ;; user: foo
	    ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
	     (1 'change-log-email))
	    ("^date: \\(.+\\)" (1 'change-log-date))
	    ("^tag: +\\([^ ]+\\)$" (1 'highlight))
	    ("^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 336 337 338
    (when (and (equal oldvers working) (not newvers))
      (setq oldvers nil))
    (when (and (not oldvers) newvers)
      (setq oldvers working))
339
    (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
340 341 342 343 344 345
           (append
            (vc-switches 'hg 'diff)
            (when oldvers
              (if newvers
                  (list "-r" oldvers "-r" newvers)
                (list "-r" oldvers)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
346

347 348 349 350 351 352 353 354 355 356
(defun vc-hg-expanded-log-entry (revision)
  (with-temp-buffer
    (vc-hg-command t nil nil "log" "-r" revision)
    (goto-char (point-min))
    (unless (eobp)
      ;; Indent the expanded log entry.
      (indent-region (point-min) (point-max) 2)
      (goto-char (point-max))
      (buffer-string))))

357 358
(defun vc-hg-revision-table (files)
  (let ((default-directory (file-name-directory (car files))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
359
    (with-temp-buffer
360
      (vc-hg-command t nil files "log" "--template" "{rev} ")
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
361
      (split-string
Dan Nicolaescu's avatar
Dan Nicolaescu committed
362 363
       (buffer-substring-no-properties (point-min) (point-max))))))

Glenn Morris's avatar
Glenn Morris committed
364
;; Modeled after the similar function in vc-cvs.el
365 366
(defun vc-hg-revision-completion-table (files)
  (lexical-let ((files files)
367 368
                table)
    (setq table (lazy-completion-table
369
                 table (lambda () (vc-hg-revision-table files))))
370
    table))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
371

372
(defun vc-hg-annotate-command (file buffer &optional revision)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
373
  "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
374
Optional arg REVISION is a revision to annotate from."
375 376
  (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
                 (when revision (concat "-r" revision))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
377

378
(declare-function vc-annotate-convert-time "vc-annotate" (time))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
379

380 381 382
;; The format for one line output by "hg annotate -d -n" looks like this:
;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
;; i.e: VERSION_NUMBER DATE: CONTENTS
383 384 385 386
;; If the user has set the "--follow" option, the output looks like:
;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
(defconst vc-hg-annotate-re
387
  "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
388 389 390 391

(defun vc-hg-annotate-time ()
  (when (looking-at vc-hg-annotate-re)
    (goto-char (match-end 0))
392
    (vc-annotate-convert-time
Dan Nicolaescu's avatar
Dan Nicolaescu committed
393 394 395 396 397
     (date-to-time (match-string-no-properties 2)))))

(defun vc-hg-annotate-extract-revision-at-line ()
  (save-excursion
    (beginning-of-line)
398 399 400 401
    (when (looking-at vc-hg-annotate-re)
      (if (match-beginning 3)
	  (match-string-no-properties 1)
	(cons (match-string-no-properties 1)
402 403
	      (expand-file-name (match-string-no-properties 4)
				(vc-hg-root default-directory)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
404

405
(defun vc-hg-previous-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
406 407 408
  (let ((newrev (1- (string-to-number rev))))
    (when (>= newrev 0)
      (number-to-string newrev))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
409

410
(defun vc-hg-next-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
411
  (let ((newrev (1+ (string-to-number rev)))
412 413 414 415 416 417
        (tip-revision
         (with-temp-buffer
           (vc-hg-command t 0 nil "tip")
           (goto-char (point-min))
           (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
           (string-to-number (match-string-no-properties 1)))))
418 419 420
    ;; We don't want to exceed the maximum possible revision number, ie
    ;; the tip revision.
    (when (<= newrev tip-revision)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
421 422
      (number-to-string newrev))))

Glenn Morris's avatar
Glenn Morris committed
423
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
424 425 426 427 428
(defun vc-hg-delete-file (file)
  "Delete FILE and delete it in the hg repository."
  (condition-case ()
      (delete-file file)
    (file-error nil))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
429
  (vc-hg-command nil 0 file "remove" "--after" "--force"))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
430

Glenn Morris's avatar
Glenn Morris committed
431
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
432 433
(defun vc-hg-rename-file (old new)
  "Rename file from OLD to NEW using `hg mv'."
434
  (vc-hg-command nil 0 new "mv" old))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
435

436 437
(defun vc-hg-register (files &optional rev comment)
  "Register FILES under hg.
438 439
REV is ignored.
COMMENT is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
440
  (vc-hg-command nil 0 files "add"))
441 442 443

(defun vc-hg-create-repo ()
  "Create a new Mercurial repository."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
444
  (vc-hg-command nil 0 nil "init"))
445

Dan Nicolaescu's avatar
Dan Nicolaescu committed
446 447
(defalias 'vc-hg-responsible-p 'vc-hg-root)

Glenn Morris's avatar
Glenn Morris committed
448
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
449 450 451 452 453 454 455 456 457 458
(defun vc-hg-could-register (file)
  "Return non-nil if FILE could be registered under hg."
  (and (vc-hg-responsible-p file)      ; shortcut
       (condition-case ()
           (with-temp-buffer
             (vc-hg-command t nil file "add" "--dry-run"))
             ;; The command succeeds with no output if file is
             ;; registered.
         (error))))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
459
;; FIXME: This would remove the file. Is that correct?
Dan Nicolaescu's avatar
Dan Nicolaescu committed
460 461 462 463
;; (defun vc-hg-unregister (file)
;;   "Unregister FILE from hg."
;;   (vc-hg-command nil nil file "remove"))

464 465 466
(declare-function log-edit-extract-headers "log-edit" (headers string))

(defun vc-hg-checkin (files rev comment)
467
  "Hg-specific version of `vc-backend-checkin'.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
468
REV is ignored."
469
  (apply 'vc-hg-command nil 0 files
470
         (nconc (list "commit" "-m")
471 472
                (log-edit-extract-headers '(("Author" . "--user")
					    ("Date" . "--date"))
473
                                          comment))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
474

Eric S. Raymond's avatar
Eric S. Raymond committed
475
(defun vc-hg-find-revision (file rev buffer)
476 477 478
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
    (if rev
479
        (vc-hg-command buffer 0 file "cat" "-r" rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
480
      (vc-hg-command buffer 0 file "cat"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
481

Glenn Morris's avatar
Glenn Morris committed
482
;; Modeled after the similar function in vc-bzr.el
483 484 485 486 487 488 489 490
(defun vc-hg-checkout (file &optional editable rev)
  "Retrieve a revision of FILE.
EDITABLE is ignored.
REV is the revision to check out into WORKFILE."
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
  (with-current-buffer (or (get-file-buffer file) (current-buffer))
    (if rev
Dan Nicolaescu's avatar
Dan Nicolaescu committed
491 492
        (vc-hg-command t 0 file "cat" "-r" rev)
      (vc-hg-command t 0 file "cat")))))
493

Glenn Morris's avatar
Glenn Morris committed
494
;; Modeled after the similar function in vc-bzr.el
495 496 497
(defun vc-hg-workfile-unchanged-p (file)
  (eq 'up-to-date (vc-hg-state file)))

Glenn Morris's avatar
Glenn Morris committed
498
;; Modeled after the similar function in vc-bzr.el
499 500
(defun vc-hg-revert (file &optional contents-done)
  (unless contents-done
Dan Nicolaescu's avatar
Dan Nicolaescu committed
501
    (with-temp-buffer (vc-hg-command t 0 file "revert"))))
502

503 504 505 506 507 508 509 510
;;; Hg specific functionality.

(defvar vc-hg-extra-menu-map
  (let ((map (make-sparse-keymap)))
    map))

(defun vc-hg-extra-menu () vc-hg-extra-menu-map)

511
(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
512

513
(defvar log-view-vc-backend)
514

515 516 517 518 519
(defstruct (vc-hg-extra-fileinfo
            (:copier nil)
            (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
            (:conc-name vc-hg-extra-fileinfo->))
  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 526
  "Pretty-printer for the vc-dir-fileinfo structure."
  (let ((extra (vc-dir-fileinfo->extra info)))
527
    (vc-default-dir-printer 'Hg info)
528 529
    (when extra
      (insert (propertize
530 531
               (format "   (%s %s)"
                       (case (vc-hg-extra-fileinfo->rename-state extra)
532 533 534
                         (copied "copied from")
                         (renamed-from "renamed from")
                         (renamed-to "renamed to"))
535 536
                       (vc-hg-extra-fileinfo->extra-name extra))
               'face 'font-lock-comment-face)))))
537

538
(defun vc-hg-after-dir-status (update-function)
539
  (let ((status-char nil)
540 541 542 543 544 545 546 547 548 549 550 551 552 553
        (file nil)
        (translation '((?= . up-to-date)
                       (?C . up-to-date)
                       (?A . added)
                       (?R . removed)
                       (?M . edited)
                       (?I . ignored)
                       (?! . missing)
                       (?  . copy-rename-line)
                       (?? . unregistered)))
        (translated nil)
        (result nil)
        (last-added nil)
        (last-line-copy nil))
554
      (goto-char (point-min))
555
      (while (not (eobp))
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587
        (setq translated (cdr (assoc (char-after) translation)))
        (setq file
              (buffer-substring-no-properties (+ (point) 2)
                                              (line-end-position)))
        (cond ((not translated)
               (setq last-line-copy nil))
              ((eq translated 'up-to-date)
               (setq last-line-copy nil))
              ((eq translated 'copy-rename-line)
               ;; For copied files the output looks like this:
               ;; A COPIED_FILE_NAME
               ;;   ORIGINAL_FILE_NAME
               (setf (nth 2 last-added)
                     (vc-hg-create-extra-fileinfo 'copied file))
               (setq last-line-copy t))
              ((and last-line-copy (eq translated 'removed))
               ;; For renamed files the output looks like this:
               ;; A NEW_FILE_NAME
               ;;   ORIGINAL_FILE_NAME
               ;; R ORIGINAL_FILE_NAME
               ;; We need to adjust the previous entry to not think it is a copy.
               (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
                     'renamed-from)
               (push (list file translated
                           (vc-hg-create-extra-fileinfo
                            'renamed-to (nth 0 last-added))) result)
               (setq last-line-copy nil))
              (t
               (setq last-added (list file translated nil))
               (push last-added result)
               (setq last-line-copy nil)))
        (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 596 597 598 599
(defun vc-hg-dir-status-files (dir files default-state update-function)
  (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
  (vc-exec-after
   `(vc-hg-after-dir-status (quote ,update-function))))

600
(defun vc-hg-dir-extra-header (name &rest commands)
601 602 603 604 605 606 607
  (concat (propertize name 'face 'font-lock-type-face)
          (propertize
           (with-temp-buffer
             (apply 'vc-hg-command (current-buffer) 0 nil commands)
             (buffer-substring-no-properties (point-min) (1- (point-max))))
           'face 'font-lock-variable-name-face)))

608
(defun vc-hg-dir-extra-headers (dir)
609 610 611
  "Generate extra status headers for a Mercurial tree."
  (let ((default-directory dir))
    (concat
612 613 614
     (vc-hg-dir-extra-header "Root       : " "root") "\n"
     (vc-hg-dir-extra-header "Branch     : " "id" "-b") "\n"
     (vc-hg-dir-extra-header "Tags       : " "id" "-t") ; "\n"
615
     ;; these change after each commit
616 617
     ;; (vc-hg-dir-extra-header "Local num  : " "id" "-n") "\n"
     ;; (vc-hg-dir-extra-header "Global id  : " "id" "-i")
618 619
     )))

620 621 622
(defun vc-hg-log-incoming (buffer remote-location)
  (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
						remote-location)))
623

624 625 626
(defun vc-hg-log-outgoing (buffer remote-location)
  (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
						remote-location)))
627

628 629
(declare-function log-view-get-marked "log-view" ())

630 631 632 633 634
;; XXX maybe also add key bindings for these functions.
(defun vc-hg-push ()
  (interactive)
  (let ((marked-list (log-view-get-marked)))
    (if marked-list
635 636 637
        (apply #'vc-hg-command
               nil 0 nil
               "push"
638
               (apply 'nconc
639 640
                      (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
      (error "No log entries selected for push"))))
641

642
(defun vc-hg-pull (prompt)
643 644 645 646 647 648 649 650
  "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."
651 652
  (interactive "P")
  (let (marked-list)
653 654
    ;; The `vc-hg-pull' command existed before the `pull' VC action
    ;; was implemented.  Keep it for backward compatibility.
655 656 657 658 659 660 661 662 663 664 665
    (if (and (called-interactively-p 'interactive)
	     (setq marked-list (log-view-get-marked)))
	(apply #'vc-hg-command
	       nil 0 nil
	       "pull"
	       (apply 'nconc
		      (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")
666
	     (hg-program vc-hg-program)
667 668
	     ;; Fixme: before updating the working copy to the latest
	     ;; state, should check if it's visiting an old revision.
669 670 671 672
	     (args '("-u")))
	;; If necessary, prompt for the exact command.
	(when prompt
	  (setq args (split-string
673 674
		      (read-shell-command "Run Hg (like this): "
					  (format "%s pull -u" hg-program)
675 676 677 678 679 680
					  'vc-hg-history)
		      " " t))
	  (setq hg-program (car  args)
		command    (cadr args)
		args       (cddr args)))
	(apply 'vc-do-async-command buffer root hg-program
681 682
	       command args)
	(vc-set-async-update buffer)))))
683 684

(defun vc-hg-merge-branch ()
685 686
  "Merge incoming changes into the current working directory.
This runs the command \"hg merge\"."
687 688
  (let* ((root (vc-hg-root default-directory))
	 (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

Dan Nicolaescu's avatar
Dan Nicolaescu committed
692 693
;;; Internal functions

694
(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
695
  "A wrapper around `vc-do-command' for use in vc-hg.el.
696 697
This function differs from vc-do-command in that it invokes
`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
Dan Nicolaescu's avatar
Dan Nicolaescu committed
699 700 701 702 703
         (if (stringp vc-hg-global-switches)
             (cons vc-hg-global-switches flags)
           (append vc-hg-global-switches
                   flags))))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
704 705 706
(defun vc-hg-root (file)
  (vc-find-root file ".hg"))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
707 708
(provide 'vc-hg)

709
;;; vc-hg.el ends here