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

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

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

;; This file is part of GNU Emacs.

;; 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
;; the Free Software Foundation; either version 3, or (at your option)
13 14 15 16 17 18 19
;; any later version.

;; 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 22 23
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
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:

Dan Nicolaescu's avatar
Dan Nicolaescu committed
37 38 39 40
;; Implement the rest of the vc interface. See the comment at the
;; 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 46
;; * registered (file)                         OK
;; * state (file)                              OK
;; - state-heuristic (file)                    ?? PROBABLY NOT NEEDED
47
;; - dir-state (dir)                           OK
Eric S. Raymond's avatar
Eric S. Raymond committed
48
;; * working-revision (file)                   OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
49 50
;; - latest-on-branch-p (file)                 ??
;; * checkout-model (file)                     OK
51
;; - workfile-unchanged-p (file)               OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
52
;; - mode-line-string (file)                   NOT NEEDED
53
;; - dired-state-info (file)                   OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
54
;; STATE-CHANGING FUNCTIONS
55
;; * register (files &optional rev comment)    OK
56
;; * create-repo ()                            OK
Eric S. Raymond's avatar
Eric S. Raymond committed
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
Eric S. Raymond's avatar
Eric S. Raymond committed
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
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 76 77
;; - wash-log (file)                           ??
;; - logentry-check ()                         NOT NEEDED
;; - 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 82 83 84 85 86 87 88 89 90
;; - annotate-command (file buf &optional rev) OK
;; - annotate-time ()                          OK
;; - annotate-current-time ()                  ?? NOT NEEDED
;; - annotate-extract-revision-at-line ()      OK
;; SNAPSHOT SYSTEM
;; - create-snapshot (dir name branchp)        NEEDED (probably branch?)
;; - assign-name (file name)                   NOT NEEDED
;; - retrieve-snapshot (dir name update)       ?? NEEDED??
;; MISCELLANEOUS
;; - make-version-backups-p (file)             ??
;; - repository-hostname (dirname)             ?? 
91 92
;; - previous-revision (file rev)               OK
;; - next-revision (file rev)                   OK
Dan Nicolaescu's avatar
Dan Nicolaescu committed
93 94 95 96 97 98
;; - 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
99

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

110
;;; History:
111
;;
Dan Nicolaescu's avatar
Dan Nicolaescu committed
112 113 114 115

;;; Code:

(eval-when-compile
Dan Nicolaescu's avatar
Dan Nicolaescu committed
116
  (require 'cl)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
117 118 119 120 121 122 123 124 125 126 127
  (require 'vc))

;;; 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
128
  :version "22.2"
Dan Nicolaescu's avatar
Dan Nicolaescu committed
129 130
  :group 'vc)

131 132 133 134 135 136

;;; Properties of the backend

(defun vc-hg-revision-granularity ()
     'repository)

Dan Nicolaescu's avatar
Dan Nicolaescu committed
137 138
;;; State querying functions

139 140 141 142 143 144 145 146
;;;###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))))

;; Modelled after the similar function in vc-bzr.el
Dan Nicolaescu's avatar
Dan Nicolaescu committed
147
(defun vc-hg-registered (file)
148
  "Return non-nil if FILE is registered with hg."
149
  (when (vc-hg-root file)           ; short cut
150 151 152
    (let ((state (vc-hg-state file)))  ; expensive
      (vc-file-setprop file 'vc-state state)
      (not (memq state '(ignored unregistered))))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
153 154

(defun vc-hg-state (file)
155
  "Hg-specific version of `vc-state'."
156 157 158 159 160 161 162 163 164 165 166
  (let* 
      ((status nil)
       (out
	(with-output-to-string
	  (with-current-buffer
	      standard-output
	    (setq status
		  (condition-case nil
		      ;; Ignore all errors.
		      (call-process
		       "hg" nil t nil "--cwd" (file-name-directory file)
167
		       "status" "-A" (file-name-nondirectory file))
168 169 170 171
		    ;; Some problem happened.  E.g. We can't find an `hg'
		    ;; executable.
		    (error nil)))))))
    (when (eq 0 status)
172 173 174
	(when (null (string-match ".*: No such file or directory$" out))
	  (let ((state (aref out 0)))
	    (cond
175
	     ((eq state ?=) 'up-to-date)
176 177
	     ((eq state ?A) 'edited)
	     ((eq state ?M) 'edited)
178 179 180
	     ((eq state ?I) 'ignored)
	     ((eq state ?R) 'unregistered)
	     ((eq state ??) 'unregistered)
181
	     ((eq state ?C) 'up-to-date) ;; Older mercurials use this
182
	     (t 'up-to-date)))))))
183 184 185

(defun vc-hg-dir-state (dir)
  (with-temp-buffer
186
    (buffer-disable-undo)		;; Because these buffers can get huge
187
    (vc-hg-command (current-buffer) nil dir "status" "-A")
188 189 190
    (goto-char (point-min))
    (let ((status-char nil)
	  (file nil))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
191
      (while (not (eobp))
192 193 194
	(setq status-char (char-after))
	(setq file 
	      (expand-file-name
Dan Nicolaescu's avatar
Dan Nicolaescu committed
195 196
	       (buffer-substring-no-properties (+ (point) 2) 
					       (line-end-position))))
197
	(cond
198
	 ;; State flag for a clean file is now C, might change to =.
199 200 201 202
	 ;; The rest of the possible states in "hg status" output:
	 ;; 	 ! = deleted, but still tracked
	 ;; should not show up in vc-dired, so don't deal with them
	 ;; here.
203 204 205

	 ;; Mercurial up to 0.9.5 used C, = is used now.
 	 ((or (eq status-char ?=) (eq status-char ?C))
206
	  (vc-file-setprop file 'vc-backend 'Hg)
207
 	  (vc-file-setprop file 'vc-state 'up-to-date))
208
	 ((eq status-char ?A)
209
	  (vc-file-setprop file 'vc-backend 'Hg)
Eric S. Raymond's avatar
Eric S. Raymond committed
210
	  (vc-file-setprop file 'vc-working-revision "0")
211 212
	  (vc-file-setprop file 'vc-state 'added))
	 ((eq status-char ?R)
213
	  (vc-file-setprop file 'vc-backend 'Hg)
214
	  (vc-file-setprop file 'vc-state 'removed))
215
	 ((eq status-char ?M)
216
	  (vc-file-setprop file 'vc-backend 'Hg)
217
	  (vc-file-setprop file 'vc-state 'edited))
218
	 ((eq status-char ?I)
219
	  (vc-file-setprop file 'vc-backend 'Hg)
220
	  (vc-file-setprop file 'vc-state 'ignored))
221 222
	 ((eq status-char ??)
	  (vc-file-setprop file 'vc-backend 'none)
223 224 225 226
	  (vc-file-setprop file 'vc-state 'unregistered))
	 ((eq status-char ?!)
	  nil)
	 (t	;; Presently C, might change to = in 0.9.6
227
	  (vc-file-setprop file 'vc-backend 'Hg)
228
	  (vc-file-setprop file 'vc-state 'up-to-date)))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
229
	(forward-line)))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
230

Eric S. Raymond's avatar
Eric S. Raymond committed
231 232
(defun vc-hg-working-revision (file)
  "Hg-specific version of `vc-working-revision'."
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
  (let* 
      ((status nil)
       (out
	(with-output-to-string
	  (with-current-buffer
	      standard-output
	    (setq status
		  (condition-case nil
		      ;; Ignore all errors.
		      (call-process
		       "hg" nil t nil "--cwd" (file-name-directory file)
		       "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
252 253 254

;;; History functions

Eric S. Raymond's avatar
Eric S. Raymond committed
255
(defun vc-hg-print-log (files &optional buffer)
256
  "Get change log associated with FILES."
Eric S. Raymond's avatar
Eric S. Raymond committed
257
  ;; `log-view-mode' needs to have the file names in order to function
258 259 260 261 262 263 264 265 266
  ;; 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))
267 268
    ;; We need to loop and call "hg log" on each file separately. 
    ;; "hg log" with multiple file arguments mashes all the logs
Eric S. Raymond's avatar
Eric S. Raymond committed
269 270
    ;; together.  Ironically enough, this puts us back near CVS
    ;; which can't generate proper fileset logs either.
271 272 273
    (dolist (file files)
      (with-current-buffer
	  buffer
Eric S. Raymond's avatar
Eric S. Raymond committed
274
	(insert "Working file: " file "\n"))	;; Like RCS/CVS.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
275
      (vc-hg-command buffer 0 file "log"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
276

277 278 279 280
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)

281
(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
282
  (require 'add-log) ;; we need the add-log faces
Eric S. Raymond's avatar
Eric S. Raymond committed
283
  (set (make-local-variable 'log-view-file-re) "^Working file:[ \t]+\\(.+\\)")
284 285 286
  (set (make-local-variable 'log-view-message-re)
       "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
  (set (make-local-variable 'log-view-font-lock-keywords)
287
       (append
288
	log-view-font-lock-keywords
289
	'(
290 291 292 293 294
	  ;; 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))
295 296 297 298 299 300
	  ;; Handle the cases:
	  ;; user: foo@bar 
	  ;; and 
	  ;; user: foo
	  ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
	   (1 'change-log-email))
301
	  ("^date: \\(.+\\)" (1 'change-log-date))
302
	  ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
303

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

322 323
(defun vc-hg-revision-table (files)
  (let ((default-directory (file-name-directory (car files))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
324
    (with-temp-buffer
325
      (vc-hg-command t nil files "log" "--template" "{rev} ")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
326 327 328 329
      (split-string 
       (buffer-substring-no-properties (point-min) (point-max))))))

;; Modelled after the similar function in vc-cvs.el
330 331
(defun vc-hg-revision-completion-table (files)
  (lexical-let ((files files)
332 333
                table)
    (setq table (lazy-completion-table
334
                 table (lambda () (vc-hg-revision-table files))))
335
    table))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
336

337
(defun vc-hg-annotate-command (file buffer &optional revision)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
338
  "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
339 340
Optional arg REVISION is a revision to annotate from."
  (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if revision (concat "-r" revision)))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
341 342 343 344 345 346
  (with-current-buffer buffer
    (goto-char (point-min))
    (re-search-forward "^[0-9]")
    (delete-region (point-min) (1- (point)))))


347 348 349
;; 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
Dan Nicolaescu's avatar
Dan Nicolaescu committed
350 351 352 353 354
(defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")

(defun vc-hg-annotate-time ()
  (when (looking-at vc-hg-annotate-re)
    (goto-char (match-end 0))
355
    (vc-annotate-convert-time
Dan Nicolaescu's avatar
Dan Nicolaescu committed
356 357 358 359 360 361 362
     (date-to-time (match-string-no-properties 2)))))

(defun vc-hg-annotate-extract-revision-at-line ()
  (save-excursion
    (beginning-of-line)
    (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))

363
(defun vc-hg-previous-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
364 365 366
  (let ((newrev (1- (string-to-number rev))))
    (when (>= newrev 0)
      (number-to-string newrev))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
367

368
(defun vc-hg-next-revision (file rev)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
369
  (let ((newrev (1+ (string-to-number rev)))
370
	(tip-revision 
Dan Nicolaescu's avatar
Dan Nicolaescu committed
371
	 (with-temp-buffer
Dan Nicolaescu's avatar
Dan Nicolaescu committed
372
	   (vc-hg-command t 0 nil "tip")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
373 374 375
	   (goto-char (point-min))
	   (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
	   (string-to-number (match-string-no-properties 1)))))
376 377 378
    ;; 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
379 380 381 382 383 384 385 386
      (number-to-string newrev))))

;; Modelled after the similar function in vc-bzr.el
(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
387
  (vc-hg-command nil 0 file "remove" "--after" "--force"))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
388 389 390 391

;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-rename-file (old new)
  "Rename file from OLD to NEW using `hg mv'."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
392
  (vc-hg-command nil 0 new old "mv"))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
393

394 395
(defun vc-hg-register (files &optional rev comment)
  "Register FILES under hg.
396 397
REV is ignored.
COMMENT is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
398
  (vc-hg-command nil 0 files "add"))
399 400 401

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

Dan Nicolaescu's avatar
Dan Nicolaescu committed
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
(defalias 'vc-hg-responsible-p 'vc-hg-root)

;; Modelled after the similar function in vc-bzr.el
(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))))

;; XXX This would remove the file. Is that correct?
;; (defun vc-hg-unregister (file)
;;   "Unregister FILE from hg."
;;   (vc-hg-command nil nil file "remove"))

422
(defun vc-hg-checkin (files rev comment)
423
  "Hg-specific version of `vc-backend-checkin'.
Dan Nicolaescu's avatar
Dan Nicolaescu committed
424
REV is ignored."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
425
  (vc-hg-command nil 0 files  "commit" "-m" comment))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
426

Eric S. Raymond's avatar
Eric S. Raymond committed
427
(defun vc-hg-find-revision (file rev buffer)
428 429 430
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
    (if rev
Dan Nicolaescu's avatar
Dan Nicolaescu committed
431 432
	(vc-hg-command buffer 0 file "cat" "-r" rev)
      (vc-hg-command buffer 0 file "cat"))))
Dan Nicolaescu's avatar
Dan Nicolaescu committed
433 434

;; Modelled after the similar function in vc-bzr.el
435 436 437 438 439 440 441 442
(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
443 444
        (vc-hg-command t 0 file "cat" "-r" rev)
      (vc-hg-command t 0 file "cat")))))
445 446 447 448

(defun vc-hg-checkout-model (file)
  'implicit)

449 450 451 452
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-workfile-unchanged-p (file)
  (eq 'up-to-date (vc-hg-state file)))

453 454 455 456
(defun vc-hg-dired-state-info (file)
  "Hg-specific version of `vc-dired-state-info'."
  (let ((hg-state (vc-state file)))
    (if (eq hg-state 'edited)
Eric S. Raymond's avatar
Eric S. Raymond committed
457
	(if (equal (vc-working-revision file) "0")
458 459
	    "(added)" "(modified)")
      ;; fall back to the default VC representation
460
      (vc-default-dired-state-info 'Hg file))))
461

462 463 464
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-revert (file &optional contents-done)
  (unless contents-done
Dan Nicolaescu's avatar
Dan Nicolaescu committed
465
    (with-temp-buffer (vc-hg-command t 0 file "revert"))))
466

467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
;;; Hg specific functionality.

;;; XXX This functionality is experimental/work in progress. It might
;;; change without notice.
(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)

(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")

483 484 485 486 487

;; XXX Experimental function for the vc-dired replacement.
(defun vc-hg-dir-status (dir)
  "Return a list of conses (file . state) for DIR."
  (with-temp-buffer
488
    (vc-hg-command (current-buffer) nil dir "status" "-A")
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512
    (goto-char (point-min))
    (let ((status-char nil)
	  (file nil)
	  (translation '((?= . up-to-date)
			 (?C . up-to-date)
			 (?A . added)
			 (?R . removed)
			 (?M . edited)
			 (?I . ignored)
			 (?! . deleted)
			 (?? . unregistered)))
	  (translated nil)
	  (result nil))
      (while (not (eobp))
	(setq status-char (char-after))
	(setq file 
	      (buffer-substring-no-properties (+ (point) 2) 
					       (line-end-position)))
	(setq translated (assoc status-char translation))
	(when (and translated (not (eq (cdr translated) 'up-to-date)))
	  (push (cons file (cdr translated)) result))
	(forward-line))
      result)))

513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
;; XXX this adds another top level menu, instead figure out how to
;; 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)))

539 540
(declare-function log-view-get-marked "log-view" ())

541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
;; XXX maybe also add key bindings for these functions.
(defun vc-hg-push ()
  (interactive)
  (let ((marked-list (log-view-get-marked)))
    (if marked-list
	(vc-hg-command 
	 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
	(vc-hg-command 
	 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
564 565
;;; Internal functions

566
(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
567 568 569
  "A wrapper around `vc-do-command' for use in vc-hg.el.
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."
570
  (apply 'vc-do-command buffer okstatus "hg" file-or-list
Dan Nicolaescu's avatar
Dan Nicolaescu committed
571 572 573 574 575
         (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
576 577 578
(defun vc-hg-root (file)
  (vc-find-root file ".hg"))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
579 580
(provide 'vc-hg)

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