vc-hg.el 25.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-2012 Free Software Foundation, Inc.
4

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

;; This file is part of GNU Emacs.

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

;; 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
22
;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
24 25 26 27 28

;;; Commentary:

;; This is a mercurial version control backend

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

;;; Bugs:

;;; Installation:

;;; Todo:

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

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

98
;; 2) Implement Stefan Monnier's advice:
99 100
;; 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
101
;; unexpected circumstances. The reason this is important is that any error
102 103 104 105 106
;; 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
107

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

;;; Code:

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

;;; Customization options

120 121 122 123 124
(defgroup vc-hg nil
  "VC Mercurial (hg) backend."
  :version "24.1"
  :group 'vc)

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

Glenn Morris's avatar
Glenn Morris committed
133 134 135
(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."
136
  :type '(choice (const :tag "Unspecified" nil)
137 138 139
                 (const :tag "None" t)
                 (string :tag "Argument String")
                 (repeat :tag "Argument List" :value ("") string))
140
  :version "23.1"
141
  :group 'vc-hg)
142

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

(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))
162
  :group 'vc-hg
163 164
  :version "24.1")

165 166 167

;;; Properties of the backend

168 169
(defvar vc-hg-history nil)

170 171
(defun vc-hg-revision-granularity () 'repository)
(defun vc-hg-checkout-model (files) 'implicit)
172

Dan Nicolaescu's avatar
Dan Nicolaescu committed
173 174
;;; State querying functions

175 176 177 178 179 180 181
;;;###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
182
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
183
(defun vc-hg-registered (file)
184
  "Return non-nil if FILE is registered with hg."
185
  (when (vc-hg-root file)           ; short cut
186
    (let ((state (vc-hg-state file)))  ; expensive
187
      (and state (not (memq state '(ignored unregistered)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
188 189

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

Eric S. Raymond's avatar
Eric S. Raymond committed
228 229
(defun vc-hg-working-revision (file)
  "Hg-specific version of `vc-working-revision'."
230 231 232 233 234 235 236 237
  (let ((default-directory (if (file-directory-p file)
                               (file-name-as-directory file)
                             (file-name-directory file))))
    (ignore-errors
      (with-output-to-string
        (process-file vc-hg-program nil standard-output nil
                      "log" "-l" "1" "--template" "{rev}"
                      (file-relative-name file))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
238 239 240

;;; History functions

241 242 243 244 245 246 247
(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)

248
(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
249
  "Get change log associated with FILES."
250 251 252 253 254 255
  ;; `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))
256 257
    (with-current-buffer
	buffer
258
      (apply 'vc-hg-command buffer 0 files "log"
259
	     (nconc
260
	      (when start-revision (list (format "-r%s:" start-revision)))
261
	      (when limit (list "-l" (format "%s" limit)))
262
	      (when shortlog (list "--template" (car vc-hg-root-log-format)))
263
	      vc-hg-log-switches)))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
264

265 266 267
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
268
(defvar log-view-per-file-logs)
269
(defvar log-view-expanded-log-entry-function)
270

271
(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
272
  (require 'add-log) ;; we need the add-log faces
273 274
  (set (make-local-variable 'log-view-file-re) "\\`a\\`")
  (set (make-local-variable 'log-view-per-file-logs) nil)
275
  (set (make-local-variable 'log-view-message-re)
276
       (if (eq vc-log-view-type 'short)
277
	   (cadr vc-hg-root-log-format)
278
         "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
279 280 281 282 283
  ;; 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))
284
  (set (make-local-variable 'log-view-font-lock-keywords)
285
       (if (eq vc-log-view-type 'short)
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304
	   (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)))))))
305

306
(defun vc-hg-diff (files &optional oldvers newvers buffer)
307
  "Get a difference report using hg between two revisions of FILES."
308
  (let* ((firstfile (car files))
309
         (working (and firstfile (vc-working-revision firstfile))))
310 311 312 313
    (when (and (equal oldvers working) (not newvers))
      (setq oldvers nil))
    (when (and (not oldvers) newvers)
      (setq oldvers working))
314
    (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
315 316 317 318 319 320
           (append
            (vc-switches 'hg 'diff)
            (when oldvers
              (if newvers
                  (list "-r" oldvers "-r" newvers)
                (list "-r" oldvers)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
321

322 323 324 325 326 327 328 329 330 331
(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))))

332 333
(defun vc-hg-revision-table (files)
  (let ((default-directory (file-name-directory (car files))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
334
    (with-temp-buffer
335
      (vc-hg-command t nil files "log" "--template" "{rev} ")
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
336
      (split-string
Dan Nicolaescu's avatar
Dan Nicolaescu committed
337 338
       (buffer-substring-no-properties (point-min) (point-max))))))

Glenn Morris's avatar
Glenn Morris committed
339
;; Modeled after the similar function in vc-cvs.el
340 341
(defun vc-hg-revision-completion-table (files)
  (lexical-let ((files files)
342 343
                table)
    (setq table (lazy-completion-table
344
                 table (lambda () (vc-hg-revision-table files))))
345
    table))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
346

347
(defun vc-hg-annotate-command (file buffer &optional revision)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
348
  "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
349
Optional arg REVISION is a revision to annotate from."
350 351
  (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
                 (when revision (concat "-r" revision))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
352

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

355 356 357
;; 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
358 359 360 361
;; 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
362
  "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
363 364 365 366

(defun vc-hg-annotate-time ()
  (when (looking-at vc-hg-annotate-re)
    (goto-char (match-end 0))
367
    (vc-annotate-convert-time
Dan Nicolaescu's avatar
Dan Nicolaescu committed
368 369 370 371 372
     (date-to-time (match-string-no-properties 2)))))

(defun vc-hg-annotate-extract-revision-at-line ()
  (save-excursion
    (beginning-of-line)
373 374 375 376
    (when (looking-at vc-hg-annotate-re)
      (if (match-beginning 3)
	  (match-string-no-properties 1)
	(cons (match-string-no-properties 1)
377 378
	      (expand-file-name (match-string-no-properties 4)
				(vc-hg-root default-directory)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
379

380
(defun vc-hg-previous-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
381 382 383
  (let ((newrev (1- (string-to-number rev))))
    (when (>= newrev 0)
      (number-to-string newrev))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
384

385
(defun vc-hg-next-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
386
  (let ((newrev (1+ (string-to-number rev)))
387 388 389 390 391 392
        (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)))))
393 394 395
    ;; 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
396 397
      (number-to-string newrev))))

Glenn Morris's avatar
Glenn Morris committed
398
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
399 400 401 402 403
(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
404
  (vc-hg-command nil 0 file "remove" "--after" "--force"))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
405

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

411 412
(defun vc-hg-register (files &optional rev comment)
  "Register FILES under hg.
413 414
REV is ignored.
COMMENT is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
415
  (vc-hg-command nil 0 files "add"))
416 417 418

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

Dan Nicolaescu's avatar
Dan Nicolaescu committed
421 422
(defalias 'vc-hg-responsible-p 'vc-hg-root)

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 429 430 431 432 433
(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
434
;; FIXME: This would remove the file. Is that correct?
Dan Nicolaescu's avatar
Dan Nicolaescu committed
435 436 437 438
;; (defun vc-hg-unregister (file)
;;   "Unregister FILE from hg."
;;   (vc-hg-command nil nil file "remove"))

439 440 441
(declare-function log-edit-extract-headers "log-edit" (headers string))

(defun vc-hg-checkin (files rev comment)
442
  "Hg-specific version of `vc-backend-checkin'.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
443
REV is ignored."
444
  (apply 'vc-hg-command nil 0 files
445
         (nconc (list "commit" "-m")
446 447
                (log-edit-extract-headers '(("Author" . "--user")
					    ("Date" . "--date"))
448
                                          comment))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
449

Eric S. Raymond's avatar
Eric S. Raymond committed
450
(defun vc-hg-find-revision (file rev buffer)
451 452 453
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
    (if rev
454
        (vc-hg-command buffer 0 file "cat" "-r" rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
455
      (vc-hg-command buffer 0 file "cat"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
456

Glenn Morris's avatar
Glenn Morris committed
457
;; Modeled after the similar function in vc-bzr.el
458 459 460 461 462 463 464 465
(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
466 467
        (vc-hg-command t 0 file "cat" "-r" rev)
      (vc-hg-command t 0 file "cat")))))
468

Glenn Morris's avatar
Glenn Morris committed
469
;; Modeled after the similar function in vc-bzr.el
470 471 472
(defun vc-hg-workfile-unchanged-p (file)
  (eq 'up-to-date (vc-hg-state file)))

Glenn Morris's avatar
Glenn Morris committed
473
;; Modeled after the similar function in vc-bzr.el
474 475
(defun vc-hg-revert (file &optional contents-done)
  (unless contents-done
Dan Nicolaescu's avatar
Dan Nicolaescu committed
476
    (with-temp-buffer (vc-hg-command t 0 file "revert"))))
477

478 479 480 481 482 483 484 485
;;; 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)

486
(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
487

488
(defvar log-view-vc-backend)
489

490 491 492 493 494
(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
495
  extra-name)         ;; original name for copies and rename targets, new name for
496

497
(declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
498

499
(defun vc-hg-dir-printer (info)
500 501
  "Pretty-printer for the vc-dir-fileinfo structure."
  (let ((extra (vc-dir-fileinfo->extra info)))
502
    (vc-default-dir-printer 'Hg info)
503 504
    (when extra
      (insert (propertize
505 506
               (format "   (%s %s)"
                       (case (vc-hg-extra-fileinfo->rename-state extra)
507 508 509
                         (copied "copied from")
                         (renamed-from "renamed from")
                         (renamed-to "renamed to"))
510 511
                       (vc-hg-extra-fileinfo->extra-name extra))
               'face 'font-lock-comment-face)))))
512

513
(defun vc-hg-after-dir-status (update-function)
514
  (let ((status-char nil)
515 516 517 518 519 520 521 522 523 524 525 526 527 528
        (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))
529
      (goto-char (point-min))
530
      (while (not (eobp))
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562
        (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))
563
      (funcall update-function result)))
564

565
(defun vc-hg-dir-status (dir update-function)
566
  (vc-hg-command (current-buffer) 'async dir "status" "-C")
567
  (vc-exec-after
568
   `(vc-hg-after-dir-status (quote ,update-function))))
569

570 571 572 573 574
(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))))

575
(defun vc-hg-dir-extra-header (name &rest commands)
576 577 578 579 580 581 582
  (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)))

583
(defun vc-hg-dir-extra-headers (dir)
584 585 586
  "Generate extra status headers for a Mercurial tree."
  (let ((default-directory dir))
    (concat
587 588 589
     (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"
590
     ;; these change after each commit
591 592
     ;; (vc-hg-dir-extra-header "Local num  : " "id" "-n") "\n"
     ;; (vc-hg-dir-extra-header "Global id  : " "id" "-i")
593 594
     )))

595 596 597
(defun vc-hg-log-incoming (buffer remote-location)
  (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
						remote-location)))
598

599 600 601
(defun vc-hg-log-outgoing (buffer remote-location)
  (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
						remote-location)))
602

603 604
(declare-function log-view-get-marked "log-view" ())

605 606 607 608 609
;; XXX maybe also add key bindings for these functions.
(defun vc-hg-push ()
  (interactive)
  (let ((marked-list (log-view-get-marked)))
    (if marked-list
610 611 612
        (apply #'vc-hg-command
               nil 0 nil
               "push"
613
               (apply 'nconc
614 615
                      (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
      (error "No log entries selected for push"))))
616

617
(defun vc-hg-pull (prompt)
618 619 620 621 622 623 624 625
  "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."
626 627
  (interactive "P")
  (let (marked-list)
628 629
    ;; The `vc-hg-pull' command existed before the `pull' VC action
    ;; was implemented.  Keep it for backward compatibility.
630 631 632 633 634 635 636 637 638 639 640
    (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")
641
	     (hg-program vc-hg-program)
642 643
	     ;; Fixme: before updating the working copy to the latest
	     ;; state, should check if it's visiting an old revision.
644 645 646 647
	     (args '("-u")))
	;; If necessary, prompt for the exact command.
	(when prompt
	  (setq args (split-string
648 649
		      (read-shell-command "Run Hg (like this): "
					  (format "%s pull -u" hg-program)
650 651 652 653 654 655
					  'vc-hg-history)
		      " " t))
	  (setq hg-program (car  args)
		command    (cadr args)
		args       (cddr args)))
	(apply 'vc-do-async-command buffer root hg-program
656 657
	       command args)
	(vc-set-async-update buffer)))))
658 659

(defun vc-hg-merge-branch ()
660 661
  "Merge incoming changes into the current working directory.
This runs the command \"hg merge\"."
662 663
  (let* ((root (vc-hg-root default-directory))
	 (buffer (format "*vc-hg : %s*" (expand-file-name root))))
664
    (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
665
    (vc-set-async-update buffer)))
666

Dan Nicolaescu's avatar
Dan Nicolaescu committed
667 668
;;; Internal functions

669
(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
670
  "A wrapper around `vc-do-command' for use in vc-hg.el.
671 672
This function differs from vc-do-command in that it invokes
`vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
673
  (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
Dan Nicolaescu's avatar
Dan Nicolaescu committed
674 675 676 677 678
         (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
679 680 681
(defun vc-hg-root (file)
  (vc-find-root file ".hg"))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
682 683
(provide 'vc-hg)

684
;;; vc-hg.el ends here