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

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
4

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

;; This file is part of GNU Emacs.

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

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

;;; Commentary:

;; This is a mercurial version control backend

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

;;; Bugs:

;;; Installation:

;;; Todo:

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

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

;;; Customization options

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

129 130 131 132 133 134 135 136 137 138 139 140 141 142
(defcustom vc-hg-diff-switches
  t                           ; Hg doesn't support common args like -u
  "String or list of strings specifying extra switches for Hg diff under VC.
If nil, use the value of `vc-diff-switches'.
If you want to force an empty list of arguments, use t."
  :type '(choice (const :tag "Unspecified" nil)
		 (const :tag "None" t)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :version "23.1"
  :group 'vc)

143 144 145

;;; Properties of the backend

146 147
(defun vc-hg-revision-granularity () 'repository)
(defun vc-hg-checkout-model (files) 'implicit)
148

Dan Nicolaescu's avatar
Dan Nicolaescu committed
149 150
;;; State querying functions

151 152 153 154 155 156 157
;;;###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
158
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
159
(defun vc-hg-registered (file)
160
  "Return non-nil if FILE is registered with hg."
161
  (when (vc-hg-root file)           ; short cut
162
    (let ((state (vc-hg-state file)))  ; expensive
163
      (and state (not (memq state '(ignored unregistered)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
164 165

(defun vc-hg-state (file)
166
  "Hg-specific version of `vc-state'."
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
167
  (let*
168 169 170 171 172 173 174 175 176
      ((status nil)
       (out
	(with-output-to-string
	  (with-current-buffer
	      standard-output
	    (setq status
		  (condition-case nil
		      ;; Ignore all errors.
		      (call-process
177
		       "hg" nil t nil "--cwd" (file-name-directory file)
178
		       "status" "-A" (file-name-nondirectory file))
179 180 181 182
		    ;; Some problem happened.  E.g. We can't find an `hg'
		    ;; executable.
		    (error nil)))))))
    (when (eq 0 status)
183 184 185
	(when (null (string-match ".*: No such file or directory$" out))
	  (let ((state (aref out 0)))
	    (cond
186
	     ((eq state ?=) 'up-to-date)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
187
	     ((eq state ?A) 'added)
188
	     ((eq state ?M) 'edited)
189
	     ((eq state ?I) 'ignored)
190
	     ((eq state ?R) 'removed)
191
	     ((eq state ?!) 'missing)
192
	     ((eq state ??) 'unregistered)
193
	     ((eq state ?C) 'up-to-date) ;; Older mercurials use this
194
	     (t 'up-to-date)))))))
195

Eric S. Raymond's avatar
Eric S. Raymond committed
196 197
(defun vc-hg-working-revision (file)
  "Hg-specific version of `vc-working-revision'."
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
198
  (let*
199 200 201 202 203 204 205 206 207
      ((status nil)
       (out
	(with-output-to-string
	  (with-current-buffer
	      standard-output
	    (setq status
		  (condition-case nil
		      ;; Ignore all errors.
		      (call-process
208
		       "hg" nil t nil "--cwd" (file-name-directory file)
209 210 211 212 213 214 215 216
		       "log" "-l1" (file-name-nondirectory file))
		    ;; Some problem happened.  E.g. We can't find an `hg'
		    ;; executable.
		    (error nil)))))))
    (when (eq 0 status)
      (if (string-match "changeset: *\\([0-9]*\\)" out)
	  (match-string 1 out)
	"0"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
217 218 219

;;; History functions

Eric S. Raymond's avatar
Eric S. Raymond committed
220
(defun vc-hg-print-log (files &optional buffer)
221
  "Get change log associated with FILES."
Eric S. Raymond's avatar
Eric S. Raymond committed
222
  ;; `log-view-mode' needs to have the file names in order to function
223 224 225 226 227 228 229 230 231
  ;; correctly. "hg log" does not print it, so we insert it here by
  ;; hand.

  ;; `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))
232 233 234
    (with-current-buffer
	buffer
      (vc-hg-command buffer 0 files "log"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
235

236 237 238
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
239
(defvar log-view-per-file-logs)
240

241
(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
242
  (require 'add-log) ;; we need the add-log faces
243 244
  (set (make-local-variable 'log-view-file-re) "\\`a\\`")
  (set (make-local-variable 'log-view-per-file-logs) nil)
245 246 247
  (set (make-local-variable 'log-view-message-re)
       "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
  (set (make-local-variable 'log-view-font-lock-keywords)
248
       (append
249
	log-view-font-lock-keywords
250
	'(
251 252 253 254 255
	  ;; 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))
256
	  ;; Handle the cases:
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
257 258
	  ;; user: foo@bar
	  ;; and
259 260 261
	  ;; user: foo
	  ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
	   (1 'change-log-email))
262
	  ("^date: \\(.+\\)" (1 'change-log-date))
263
	  ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
264

265
(defun vc-hg-diff (files &optional oldvers newvers buffer)
266
  "Get a difference report using hg between two revisions of FILES."
267 268
  (let* ((firstfile (car files))
	 (working (and firstfile (vc-working-revision firstfile))))
269 270 271 272
    (when (and (equal oldvers working) (not newvers))
      (setq oldvers nil))
    (when (and (not oldvers) newvers)
      (setq oldvers working))
273 274
    (apply #'vc-hg-command (or buffer "*vc-diff*") nil
	   (mapcar (lambda (file) (file-name-nondirectory file)) files)
275 276
	   "--cwd" (or (when firstfile (file-name-directory firstfile))
		       (expand-file-name default-directory))
277
	   "diff"
278
	   (append
279
	    (vc-switches 'hg 'diff)
280 281 282 283
	    (when oldvers
	      (if newvers
		  (list "-r" oldvers "-r" newvers)
		(list "-r" oldvers)))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
284

285 286
(defun vc-hg-revision-table (files)
  (let ((default-directory (file-name-directory (car files))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
287
    (with-temp-buffer
288
      (vc-hg-command t nil files "log" "--template" "{rev} ")
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
289
      (split-string
Dan Nicolaescu's avatar
Dan Nicolaescu committed
290 291
       (buffer-substring-no-properties (point-min) (point-max))))))

Glenn Morris's avatar
Glenn Morris committed
292
;; Modeled after the similar function in vc-cvs.el
293 294
(defun vc-hg-revision-completion-table (files)
  (lexical-let ((files files)
295 296
                table)
    (setq table (lazy-completion-table
297
                 table (lambda () (vc-hg-revision-table files))))
298
    table))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
299

300
(defun vc-hg-annotate-command (file buffer &optional revision)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
301
  "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
302
Optional arg REVISION is a revision to annotate from."
303
  (vc-hg-command buffer 0 file "annotate" "-d" "-n"
304
		 (when revision (concat "-r" revision)))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
305 306
  (with-current-buffer buffer
    (goto-char (point-min))
307 308
    (re-search-forward "^[ \t]*[0-9]")
    (delete-region (point-min) (match-beginning 0))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
309

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

312 313 314
;; 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
315 316 317 318 319
;; 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
  "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)[^:\n]*\\(:[^ \n][^:\n]*\\)*: ")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
320 321 322 323

(defun vc-hg-annotate-time ()
  (when (looking-at vc-hg-annotate-re)
    (goto-char (match-end 0))
324
    (vc-annotate-convert-time
Dan Nicolaescu's avatar
Dan Nicolaescu committed
325 326 327 328 329
     (date-to-time (match-string-no-properties 2)))))

(defun vc-hg-annotate-extract-revision-at-line ()
  (save-excursion
    (beginning-of-line)
330
    (when (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
331

332
(defun vc-hg-previous-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
333 334 335
  (let ((newrev (1- (string-to-number rev))))
    (when (>= newrev 0)
      (number-to-string newrev))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
336

337
(defun vc-hg-next-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
338
  (let ((newrev (1+ (string-to-number rev)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
339
	(tip-revision
Dan Nicolaescu's avatar
Dan Nicolaescu committed
340
	 (with-temp-buffer
Dan Nicolaescu's avatar
Dan Nicolaescu committed
341
	   (vc-hg-command t 0 nil "tip")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
342 343 344
	   (goto-char (point-min))
	   (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
	   (string-to-number (match-string-no-properties 1)))))
345 346 347
    ;; 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
348 349
      (number-to-string newrev))))

Glenn Morris's avatar
Glenn Morris committed
350
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
351 352 353 354 355
(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
356
  (vc-hg-command nil 0 file "remove" "--after" "--force"))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
357

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

363 364
(defun vc-hg-register (files &optional rev comment)
  "Register FILES under hg.
365 366
REV is ignored.
COMMENT is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
367
  (vc-hg-command nil 0 files "add"))
368 369 370

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

Dan Nicolaescu's avatar
Dan Nicolaescu committed
373 374
(defalias 'vc-hg-responsible-p 'vc-hg-root)

Glenn Morris's avatar
Glenn Morris committed
375
;; Modeled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
376 377 378 379 380 381 382 383 384 385
(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
386
;; FIXME: This would remove the file. Is that correct?
Dan Nicolaescu's avatar
Dan Nicolaescu committed
387 388 389 390
;; (defun vc-hg-unregister (file)
;;   "Unregister FILE from hg."
;;   (vc-hg-command nil nil file "remove"))

391
(defun vc-hg-checkin (files rev comment)
392
  "Hg-specific version of `vc-backend-checkin'.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
393
REV is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
394
  (vc-hg-command nil 0 files  "commit" "-m" comment))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
395

Eric S. Raymond's avatar
Eric S. Raymond committed
396
(defun vc-hg-find-revision (file rev buffer)
397 398 399
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
    (if rev
Dan Nicolaescu's avatar
Dan Nicolaescu committed
400 401
	(vc-hg-command buffer 0 file "cat" "-r" rev)
      (vc-hg-command buffer 0 file "cat"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
402

Glenn Morris's avatar
Glenn Morris committed
403
;; Modeled after the similar function in vc-bzr.el
404 405 406 407 408 409 410 411
(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
412 413
        (vc-hg-command t 0 file "cat" "-r" rev)
      (vc-hg-command t 0 file "cat")))))
414

Glenn Morris's avatar
Glenn Morris committed
415
;; Modeled after the similar function in vc-bzr.el
416 417 418
(defun vc-hg-workfile-unchanged-p (file)
  (eq 'up-to-date (vc-hg-state file)))

Glenn Morris's avatar
Glenn Morris committed
419
;; Modeled after the similar function in vc-bzr.el
420 421
(defun vc-hg-revert (file &optional contents-done)
  (unless contents-done
Dan Nicolaescu's avatar
Dan Nicolaescu committed
422
    (with-temp-buffer (vc-hg-command t 0 file "revert"))))
423

424 425 426 427 428 429 430 431 432 433
;;; Hg specific functionality.

(defvar vc-hg-extra-menu-map
  (let ((map (make-sparse-keymap)))
    (define-key map [incoming] '(menu-item "Show incoming" vc-hg-incoming))
    (define-key map [outgoing] '(menu-item "Show outgoing" vc-hg-outgoing))
    map))

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

434
(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
435

436 437 438 439
(define-derived-mode vc-hg-outgoing-mode vc-hg-log-view-mode "Hg-Outgoing")

(define-derived-mode vc-hg-incoming-mode vc-hg-log-view-mode "Hg-Incoming")

440 441 442 443 444
(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
445
  extra-name)         ;; original name for copies and rename targets, new name for
446

447
(declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
448

449
(defun vc-hg-dir-printer (info)
450 451
  "Pretty-printer for the vc-dir-fileinfo structure."
  (let ((extra (vc-dir-fileinfo->extra info)))
452
    (vc-default-dir-printer 'Hg info)
453 454 455 456 457 458 459 460 461 462
    (when extra
      (insert (propertize
	       (format "   (%s %s)"
		       (case (vc-hg-extra-fileinfo->rename-state extra)
			 ('copied "copied from")
			 ('renamed-from "renamed from")
			 ('renamed-to "renamed to"))
		       (vc-hg-extra-fileinfo->extra-name extra))
	       'face 'font-lock-comment-face)))))

463
(defun vc-hg-after-dir-status (update-function)
464 465 466 467 468 469 470 471
  (let ((status-char nil)
	(file nil)
	(translation '((?= . up-to-date)
		       (?C . up-to-date)
		       (?A . added)
		       (?R . removed)
		       (?M . edited)
		       (?I . ignored)
472
		       (?! . missing)
473
		       (?  . copy-rename-line)
474 475
		       (?? . unregistered)))
	(translated nil)
476 477 478
	(result nil)
	(last-added nil)
	(last-line-copy nil))
479
      (goto-char (point-min))
480
      (while (not (eobp))
481
	(setq translated (cdr (assoc (char-after) translation)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
482 483
	(setq file
	      (buffer-substring-no-properties (+ (point) 2)
484
					      (line-end-position)))
485 486 487 488 489 490 491 492
	(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
493
	       (setf (nth 2 last-added)
494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
		     (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)))
512
	(forward-line))
513
      (funcall update-function result)))
514

515
(defun vc-hg-dir-status (dir update-function)
516
  (vc-hg-command (current-buffer) 'async dir "status" "-C")
517
  (vc-exec-after
518
   `(vc-hg-after-dir-status (quote ,update-function))))
519

520 521 522 523 524
(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))))

525
(defun vc-hg-dir-extra-header (name &rest commands)
526 527 528 529 530 531 532
  (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)))

533
(defun vc-hg-dir-extra-headers (dir)
534 535 536
  "Generate extra status headers for a Mercurial tree."
  (let ((default-directory dir))
    (concat
537 538 539
     (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"
540
     ;; these change after each commit
541 542
     ;; (vc-hg-dir-extra-header "Local num  : " "id" "-n") "\n"
     ;; (vc-hg-dir-extra-header "Global id  : " "id" "-i")
543 544
     )))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
545
;; FIXME: this adds another top level menu, instead figure out how to
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570
;; replace the Log-View menu.
(easy-menu-define log-view-mode-menu vc-hg-outgoing-mode-map
  "Hg-outgoing Display Menu"
  `("Hg-outgoing"
    ["Push selected"  vc-hg-push]))

(easy-menu-define log-view-mode-menu vc-hg-incoming-mode-map
  "Hg-incoming Display Menu"
  `("Hg-incoming"
    ["Pull selected"  vc-hg-pull]))

(defun vc-hg-outgoing ()
  (interactive)
  (let ((bname "*Hg outgoing*"))
    (vc-hg-command bname 0 nil "outgoing" "-n")
    (pop-to-buffer bname)
    (vc-hg-outgoing-mode)))

(defun vc-hg-incoming ()
  (interactive)
  (let ((bname "*Hg incoming*"))
    (vc-hg-command bname 0 nil "incoming" "-n")
    (pop-to-buffer bname)
    (vc-hg-incoming-mode)))

571 572
(declare-function log-view-get-marked "log-view" ())

573 574 575 576 577
;; XXX maybe also add key bindings for these functions.
(defun vc-hg-push ()
  (interactive)
  (let ((marked-list (log-view-get-marked)))
    (if marked-list
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
578
	(vc-hg-command
579 580 581 582 583 584 585 586 587 588
	 nil 0 nil
	 (cons "push"
	       (apply 'nconc
		      (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
	 (error "No log entries selected for push"))))

(defun vc-hg-pull ()
  (interactive)
  (let ((marked-list (log-view-get-marked)))
    (if marked-list
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
589
	(vc-hg-command
590 591 592 593 594 595
	 nil 0 nil
	 (cons "pull"
	       (apply 'nconc
		      (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
      (error "No log entries selected for pull"))))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
596 597
;;; Internal functions

598
(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
599
  "A wrapper around `vc-do-command' for use in vc-hg.el.
600 601 602
The difference to vc-do-command is that this function always invokes `hg',
and that it passes `vc-hg-global-switches' to it before FLAGS."
  (apply 'vc-do-command (or buffer "*vc*") okstatus "hg" file-or-list
Dan Nicolaescu's avatar
Dan Nicolaescu committed
603 604 605 606 607
         (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
608 609 610
(defun vc-hg-root (file)
  (vc-find-root file ".hg"))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
611 612
(provide 'vc-hg)

Miles Bader's avatar
Miles Bader committed
613
;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
614
;;; vc-hg.el ends here