[bpt/emacs.git] / lisp / vc-hg.el

;;; vc-hg.el --- VC backend for the mercurial version control system

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

;; Author: Ivan Kanis
;; Keywords: tools

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; 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.

;; You should have received a copy of the GNU General Public License
;; 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.

;;; Commentary:

;; This is a mercurial version control backend

;;; Thanks:

;;; Bugs:

;;; Installation:

;;; Todo:

;; Implement the rest of the vc interface. See the comment at the
;; beginning of vc.el. The current status is:

;; FUNCTION NAME                               STATUS
;; * registered (file)                         OK
;; * state (file)                              OK
;; - state-heuristic (file)                    ?? PROBABLY NOT NEEDED
;; - dir-state (dir)                           OK
;; * workfile-version (file)                   OK
;; - latest-on-branch-p (file)                 ??
;; * checkout-model (file)                     OK
;; - workfile-unchanged-p (file)               OK
;; - mode-line-string (file)                   NOT NEEDED
;; - dired-state-info (file)                   OK
;; STATE-CHANGING FUNCTIONS
;; * register (file &optional rev comment)     OK
;; - init-version ()                           NOT NEEDED
;; - responsible-p (file)                      OK
;; - could-register (file)                     OK
;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
;; - unregister (file)                         COMMENTED OUT, MAY BE INCORRECT
;; * checkin (file rev comment)                OK
;; * find-version (file rev buffer)            OK
;; * checkout (file &optional editable rev)    OK
;; * revert (file &optional contents-done)     OK
;; - cancel-version (file editable)            ?? PROBABLY NOT NEEDED   
;; - merge (file rev1 rev2)                    NEEDED
;; - merge-news (file)                         NEEDED
;; - steal-lock (file &optional version)       NOT NEEDED
;; HISTORY FUNCTIONS
;; * print-log (file &optional buffer)         OK
;; - log-view-mode ()                          OK
;; - show-log-entry (version)                  NOT NEEDED, DEFAULT IS GOOD
;; - wash-log (file)                           ??
;; - logentry-check ()                         NOT NEEDED
;; - comment-history (file)                    NOT NEEDED
;; - update-changelog (files)                  NOT NEEDED
;; * diff (file &optional rev1 rev2 buffer)    OK
;; - revision-completion-table (file)          COMMENTED OUT AS A WORKAROUND FOR A BUG
;; - diff-tree (dir &optional rev1 rev2)       TEST IT
;; - 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)             ?? 
;; - previous-version (file rev)               OK
;; - next-version (file rev)                   OK
;; - 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

;; Implement Stefan Monnier's advice:
;; vc-hg-registered and vc-hg-state
;; Both of those functions should be super extra careful to fail gracefully in
;; unexpected circumstances. The reason this is important is that any error
;; 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).

;;; History:
;;

;;; Code:

(eval-when-compile
  (require 'cl)
  (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))
  :version "22.2"
  :group 'vc)

;;; State querying functions

;;;###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
(defun vc-hg-registered (file)
  "Return non-nil if FILE is registered with hg."
  (when (vc-hg-root file)           ; short cut
    (vc-file-setprop file 'vc-state (vc-hg-state file)))) ; expensive

(defun vc-hg-state (file)
  "Hg-specific version of `vc-state'."
  (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)
		       "status" (file-name-nondirectory file))
		    ;; Some problem happened.  E.g. We can't find an `hg'
		    ;; executable.
		    (error nil)))))))
    (when (eq 0 status)
      (if (eq 0 (length out)) 'up-to-date
	(when (null (string-match ".*: No such file or directory$" out))
	  (let ((state (aref out 0)))
	    (cond
	     ((eq state ?A) 'edited)
	     ((eq state ?M) 'edited)
	     ((eq state ?R) nil)
	     ((eq state ??) nil)
	     (t 'up-to-date))))))))

(defun vc-hg-dir-state (dir)
  (with-temp-buffer
    (vc-hg-command (current-buffer) nil dir "status")
    (goto-char (point-min))
    (let ((status-char nil)
	  (file nil))
      (while (not (eobp))
	(setq status-char (char-after))
	(setq file 
	      (expand-file-name
	       (buffer-substring-no-properties (+ (point) 2) 
					       (line-end-position))))
	(cond
	 ;; The rest of the possible states in "hg status" output:
	 ;; 	 R = removed
	 ;; 	 ! = deleted, but still tracked
	 ;; 	 ? = not tracked
	 ;; should not show up in vc-dired, so don't deal with them
	 ;; here.
	 ((eq status-char ?A)
	  (vc-file-setprop file 'vc-backend 'Hg)
	  (vc-file-setprop file 'vc-workfile-version "0")
	  (vc-file-setprop file 'vc-state 'edited))
	 ((eq status-char ?M)
	  (vc-file-setprop file 'vc-backend 'Hg)
	  (vc-file-setprop file 'vc-state 'edited))
	 ((eq status-char ??)
	  (vc-file-setprop file 'vc-backend 'none)
	  (vc-file-setprop file 'vc-state 'nil)))
	(forward-line)))))

(defun vc-hg-workfile-version (file)
  "Hg-specific version of `vc-workfile-version'."
  (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"))))

;;; History functions

(defun vc-hg-print-log(file &optional buffer)
  "Get change log associated with FILE."
  ;; `log-view-mode' needs to have the file name in order to function
  ;; 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))
    (with-current-buffer
	buffer
      (insert "File:        " (file-name-nondirectory file) "\n")))
  (vc-hg-command
   buffer
   (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
   file "log"))

(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)

(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
  (require 'add-log) ;; we need the faces add-log
  ;; Don't have file markers, so use impossible regexp.
  (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
  (set (make-local-variable 'log-view-message-re)
       "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
  (set (make-local-variable 'log-view-font-lock-keywords)
       (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))
	  ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))

(defun vc-hg-diff (file &optional oldvers newvers buffer)
  "Get a difference report using hg between two versions of FILE."
  (let ((working (vc-workfile-version file)))
    (if (and (equal oldvers working) (not newvers))
	(setq oldvers nil))
    (if (and (not oldvers) newvers)
	(setq oldvers working))
    (apply #'vc-hg-command (or buffer "*vc-diff*") nil
	   (file-name-nondirectory file)
	   "--cwd" (file-name-directory file) 
	   "diff"
	   (append
	    (if oldvers
		(if newvers
		    (list "-r" oldvers "-r" newvers)
		  (list "-r" oldvers)))))))

(defun vc-hg-revision-table (file)
  (let ((default-directory (file-name-directory file)))
    (with-temp-buffer
      (vc-hg-command t nil file "log" "--template" "{rev} ")
      (split-string 
       (buffer-substring-no-properties (point-min) (point-max))))))

;; Modelled after the similar function in vc-cvs.el
(defun vc-hg-revision-completion-table (file)
  (lexical-let ((file file)
                table)
    (setq table (lazy-completion-table
                 table (lambda () (vc-hg-revision-table file))))
    table))

(defalias 'vc-hg-diff-tree 'vc-hg-diff)

(defun vc-hg-annotate-command (file buffer &optional version)
  "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
Optional arg VERSION is a version to annotate from."
  (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
  (with-current-buffer buffer
    (goto-char (point-min))
    (re-search-forward "^[0-9]")
    (delete-region (point-min) (1- (point)))))


;; 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
(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))
    (vc-annotate-convert-time
     (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))))

(defun vc-hg-previous-version (file rev)
  (let ((newrev (1- (string-to-number rev))))
    (when (>= newrev 0)
      (number-to-string newrev))))

(defun vc-hg-next-version (file rev)
  (let ((newrev (1+ (string-to-number rev)))
	(tip-version 
	 (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)))))
    ;; We don't want to exceed the maximum possible version number, ie
    ;; the tip version.
    (when (<= newrev tip-version)
      (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))
  (vc-hg-command nil 0 file "remove" "--after" "--force"))

;; 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'."
  (vc-hg-command nil 0 new old "mv"))

(defun vc-hg-register (file &optional rev comment)
  "Register FILE under hg.
REV is ignored.
COMMENT is ignored."
  (vc-hg-command nil 0 file "add"))

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

(defun vc-hg-checkin (file rev comment)
  "Hg-specific version of `vc-backend-checkin'.
REV is ignored."
  (vc-hg-command nil 0 file  "commit" "-m" comment))

(defun vc-hg-find-version (file rev buffer)
  (let ((coding-system-for-read 'binary)
        (coding-system-for-write 'binary))
    (if rev
	(vc-hg-command buffer 0 file "cat" "-r" rev)
      (vc-hg-command buffer 0 file "cat"))))

;; Modelled after the similar function in vc-bzr.el
(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
        (vc-hg-command t 0 file "cat" "-r" rev)
      (vc-hg-command t 0 file "cat")))))

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

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

(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)
	(if (equal (vc-workfile-version file) "0")
	    "(added)" "(modified)")
      ;; fall back to the default VC representation
      (vc-default-dired-state-info 'Hg file))))

;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-revert (file &optional contents-done)
  (unless contents-done
    (with-temp-buffer (vc-hg-command t 0 file "revert"))))

;;; Internal functions

(defun vc-hg-command (buffer okstatus file &rest flags)
  "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."
  (apply 'vc-do-command buffer okstatus "hg" file
         (if (stringp vc-hg-global-switches)
             (cons vc-hg-global-switches flags)
           (append vc-hg-global-switches
                   flags))))

(defun vc-hg-root (file)
  (vc-find-root file ".hg"))

(provide 'vc-hg)

;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
;;; vc-hg.el ends here
Commit	Line	Data
8b69ba6c DN	1	;;; vc-hg.el --- VC backend for the mercurial version control system
8b69ba6c DN	2
409cc4a3	3	;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
8b69ba6c DN	4
	5	;; Author: Ivan Kanis
	6	;; Keywords: tools
8b69ba6c DN	7
	8	;; This file is part of GNU Emacs.
	9
	10	;; GNU Emacs is free software; you can redistribute it and/or modify
	11	;; it under the terms of the GNU General Public License as published by
b4aa6026	12	;; the Free Software Foundation; either version 3, or (at your option)
8b69ba6c DN	13	;; any later version.
	14
	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
	21	;; along with GNU Emacs; see the file COPYING. If not, write to the
	22	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	23	;; Boston, MA 02110-1301, USA.
	24
	25	;;; Commentary:
	26
	27	;; This is a mercurial version control backend
	28
	29	;;; Thanks:
	30
	31	;;; Bugs:
	32
	33	;;; Installation:
	34
	35	;;; Todo:
	36
	37	;; Implement the rest of the vc interface. See the comment at the
	38	;; beginning of vc.el. The current status is:
	39
	40	;; FUNCTION NAME STATUS
	41	;; * registered (file) OK
	42	;; * state (file) OK
	43	;; - state-heuristic (file) ?? PROBABLY NOT NEEDED
908265fc	44	;; - dir-state (dir) OK
8b69ba6c DN	45	;; * workfile-version (file) OK
	46	;; - latest-on-branch-p (file) ??
	47	;; * checkout-model (file) OK
727bdea1	48	;; - workfile-unchanged-p (file) OK
8b69ba6c	49	;; - mode-line-string (file) NOT NEEDED
908265fc	50	;; - dired-state-info (file) OK
8b69ba6c DN	51	;; STATE-CHANGING FUNCTIONS
	52	;; * register (file &optional rev comment) OK
	53	;; - init-version () NOT NEEDED
	54	;; - responsible-p (file) OK
	55	;; - could-register (file) OK
	56	;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
	57	;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
	58	;; * checkin (file rev comment) OK
	59	;; * find-version (file rev buffer) OK
908265fc	60	;; * checkout (file &optional editable rev) OK
8b69ba6c DN	61	;; * revert (file &optional contents-done) OK
	62	;; - cancel-version (file editable) ?? PROBABLY NOT NEEDED
	63	;; - merge (file rev1 rev2) NEEDED
	64	;; - merge-news (file) NEEDED
	65	;; - steal-lock (file &optional version) NOT NEEDED
	66	;; HISTORY FUNCTIONS
	67	;; * print-log (file &optional buffer) OK
	68	;; - log-view-mode () OK
	69	;; - show-log-entry (version) NOT NEEDED, DEFAULT IS GOOD
	70	;; - wash-log (file) ??
	71	;; - logentry-check () NOT NEEDED
	72	;; - comment-history (file) NOT NEEDED
	73	;; - update-changelog (files) NOT NEEDED
	74	;; * diff (file &optional rev1 rev2 buffer) OK
57b8089a	75	;; - revision-completion-table (file) COMMENTED OUT AS A WORKAROUND FOR A BUG
8b69ba6c DN	76	;; - diff-tree (dir &optional rev1 rev2) TEST IT
	77	;; - annotate-command (file buf &optional rev) OK
	78	;; - annotate-time () OK
	79	;; - annotate-current-time () ?? NOT NEEDED
	80	;; - annotate-extract-revision-at-line () OK
	81	;; SNAPSHOT SYSTEM
	82	;; - create-snapshot (dir name branchp) NEEDED (probably branch?)
	83	;; - assign-name (file name) NOT NEEDED
	84	;; - retrieve-snapshot (dir name update) ?? NEEDED??
	85	;; MISCELLANEOUS
	86	;; - make-version-backups-p (file) ??
	87	;; - repository-hostname (dirname) ??
	88	;; - previous-version (file rev) OK
	89	;; - next-version (file rev) OK
	90	;; - check-headers () ??
	91	;; - clear-headers () ??
	92	;; - delete-file (file) TEST IT
	93	;; - rename-file (old new) OK
	94	;; - find-file-hook () PROBABLY NOT NEEDED
	95	;; - find-file-not-found-hook () PROBABLY NOT NEEDED
	96
	97	;; Implement Stefan Monnier's advice:
	98	;; vc-hg-registered and vc-hg-state
	99	;; Both of those functions should be super extra careful to fail gracefully in
	100	;; unexpected circumstances. The reason this is important is that any error
	101	;; there will prevent the user from even looking at the file :-(
	102	;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
	103	;; mercurial's control and extracting the current revision should be done
	104	;; without even using `hg' (this way even if you don't have `hg' installed,
	105	;; Emacs is able to tell you this file is under mercurial's control).
	106
	107	;;; History:
	108	;;
	109
	110	;;; Code:
	111
	112	(eval-when-compile
0c3b8cc4	113	(require 'cl)
8b69ba6c DN	114	(require 'vc))
8b69ba6c DN	115
8b69ba6c DN	116	;;; Customization options
	117
	118	(defcustom vc-hg-global-switches nil
	119	"*Global switches to pass to any Hg command."
	120	:type '(choice (const :tag "None" nil)
	121	(string :tag "Argument String")
	122	(repeat :tag "Argument List"
	123	:value ("")
	124	string))
	125	:version "22.2"
	126	:group 'vc)
	127
	128	;;; State querying functions
	129
	130	;;;###autoload (defun vc-hg-registered (file)
	131	;;;###autoload "Return non-nil if FILE is registered with hg."
	132	;;;###autoload (if (vc-find-root file ".hg") ; short cut
	133	;;;###autoload (progn
	134	;;;###autoload (load "vc-hg")
	135	;;;###autoload (vc-hg-registered file))))
	136
	137	;; Modelled after the similar function in vc-bzr.el
	138	(defun vc-hg-registered (file)
	139	"Return non-nil if FILE is registered with hg."
ad546929	140	(when (vc-hg-root file) ; short cut
791869eb	141	(vc-file-setprop file 'vc-state (vc-hg-state file)))) ; expensive
8b69ba6c DN	142
	143	(defun vc-hg-state (file)
	144	"Hg-specific version of `vc-state'."
	145	(let*
	146	((status nil)
	147	(out
	148	(with-output-to-string
	149	(with-current-buffer
	150	standard-output
	151	(setq status
	152	(condition-case nil
	153	;; Ignore all errors.
	154	(call-process
	155	"hg" nil t nil "--cwd" (file-name-directory file)
	156	"status" (file-name-nondirectory file))
	157	;; Some problem happened. E.g. We can't find an `hg'
	158	;; executable.
	159	(error nil)))))))
	160	(when (eq 0 status)
	161	(if (eq 0 (length out)) 'up-to-date
ad546929 DN	162	(when (null (string-match ".*: No such file or directory$" out))
	163	(let ((state (aref out 0)))
	164	(cond
	165	((eq state ?A) 'edited)
	166	((eq state ?M) 'edited)
	167	((eq state ?R) nil)
	168	((eq state ??) nil)
	169	(t 'up-to-date))))))))
8b69ba6c	170
908265fc DN	171	(defun vc-hg-dir-state (dir)
908265fc DN	172	(with-temp-buffer
45286831	173	(vc-hg-command (current-buffer) nil dir "status")
908265fc DN	174	(goto-char (point-min))
	175	(let ((status-char nil)
	176	(file nil))
0c3b8cc4	177	(while (not (eobp))
908265fc DN	178	(setq status-char (char-after))
	179	(setq file
	180	(expand-file-name
0c3b8cc4 DN	181	(buffer-substring-no-properties (+ (point) 2)
0c3b8cc4 DN	182	(line-end-position))))
908265fc DN	183	(cond
	184	;; The rest of the possible states in "hg status" output:
	185	;; R = removed
	186	;; ! = deleted, but still tracked
	187	;; ? = not tracked
	188	;; should not show up in vc-dired, so don't deal with them
	189	;; here.
	190	((eq status-char ?A)
5378843c	191	(vc-file-setprop file 'vc-backend 'Hg)
908265fc DN	192	(vc-file-setprop file 'vc-workfile-version "0")
	193	(vc-file-setprop file 'vc-state 'edited))
	194	((eq status-char ?M)
5378843c	195	(vc-file-setprop file 'vc-backend 'Hg)
908265fc DN	196	(vc-file-setprop file 'vc-state 'edited))
	197	((eq status-char ??)
	198	(vc-file-setprop file 'vc-backend 'none)
0c3b8cc4 DN	199	(vc-file-setprop file 'vc-state 'nil)))
0c3b8cc4 DN	200	(forward-line)))))
908265fc	201
8b69ba6c DN	202	(defun vc-hg-workfile-version (file)
	203	"Hg-specific version of `vc-workfile-version'."
	204	(let*
	205	((status nil)
	206	(out
	207	(with-output-to-string
	208	(with-current-buffer
	209	standard-output
	210	(setq status
	211	(condition-case nil
	212	;; Ignore all errors.
	213	(call-process
	214	"hg" nil t nil "--cwd" (file-name-directory file)
	215	"log" "-l1" (file-name-nondirectory file))
	216	;; Some problem happened. E.g. We can't find an `hg'
	217	;; executable.
	218	(error nil)))))))
	219	(when (eq 0 status)
	220	(if (string-match "changeset: \\([0-9]\\)" out)
	221	(match-string 1 out)
	222	"0"))))
	223
	224	;;; History functions
	225
	226	(defun vc-hg-print-log(file &optional buffer)
	227	"Get change log associated with FILE."
	228	;; `log-view-mode' needs to have the file name in order to function
	229	;; correctly. "hg log" does not print it, so we insert it here by
	230	;; hand.
	231
	232	;; `vc-do-command' creates the buffer, but we need it before running
	233	;; the command.
	234	(vc-setup-buffer buffer)
	235	;; If the buffer exists from a previous invocation it might be
	236	;; read-only.
	237	(let ((inhibit-read-only t))
	238	(with-current-buffer
	239	buffer
	240	(insert "File: " (file-name-nondirectory file) "\n")))
	241	(vc-hg-command
	242	buffer
	243	(if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
	244	file "log"))
	245
	246	(defvar log-view-message-re)
	247	(defvar log-view-file-re)
	248	(defvar log-view-font-lock-keywords)
	249
5716cebd	250	(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
8b69ba6c DN	251	(require 'add-log) ;; we need the faces add-log
	252	;; Don't have file markers, so use impossible regexp.
	253	(set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
	254	(set (make-local-variable 'log-view-message-re)
	255	"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
	256	(set (make-local-variable 'log-view-font-lock-keywords)
	257	(append
	258	log-view-font-lock-keywords
1030ad5e	259	'(
8b69ba6c DN	260	;; Handle the case:
	261	;; user: FirstName LastName <foo@bar>
	262	("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
	263	(1 'change-log-name)
	264	(2 'change-log-email))
1030ad5e DN	265	;; Handle the cases:
	266	;; user: foo@bar
	267	;; and
	268	;; user: foo
	269	("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
	270	(1 'change-log-email))
8b69ba6c DN	271	("^date: \\(.+\\)" (1 'change-log-date))
	272	("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
	273
	274	(defun vc-hg-diff (file &optional oldvers newvers buffer)
	275	"Get a difference report using hg between two versions of FILE."
	276	(let ((working (vc-workfile-version file)))
	277	(if (and (equal oldvers working) (not newvers))
	278	(setq oldvers nil))
	279	(if (and (not oldvers) newvers)
	280	(setq oldvers working))
0c3b8cc4 DN	281	(apply #'vc-hg-command (or buffer "vc-diff") nil
	282	(file-name-nondirectory file)
	283	"--cwd" (file-name-directory file)
	284	"diff"
8b69ba6c DN	285	(append
	286	(if oldvers
	287	(if newvers
	288	(list "-r" oldvers "-r" newvers)
09c5aa7c	289	(list "-r" oldvers)))))))
0c3b8cc4 DN	290
	291	(defun vc-hg-revision-table (file)
	292	(let ((default-directory (file-name-directory file)))
	293	(with-temp-buffer
	294	(vc-hg-command t nil file "log" "--template" "{rev} ")
	295	(split-string
	296	(buffer-substring-no-properties (point-min) (point-max))))))
	297
	298	;; Modelled after the similar function in vc-cvs.el
eff23ff3 DN	299	(defun vc-hg-revision-completion-table (file)
	300	(lexical-let ((file file)
	301	table)
	302	(setq table (lazy-completion-table
	303	table (lambda () (vc-hg-revision-table file))))
	304	table))
8b69ba6c DN	305
	306	(defalias 'vc-hg-diff-tree 'vc-hg-diff)
	307
	308	(defun vc-hg-annotate-command (file buffer &optional version)
	309	"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
	310	Optional arg VERSION is a version to annotate from."
	311	(vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
	312	(with-current-buffer buffer
	313	(goto-char (point-min))
	314	(re-search-forward "^[0-9]")
	315	(delete-region (point-min) (1- (point)))))
	316
	317
	318	;; The format for one line output by "hg annotate -d -n" looks like this:
	319	;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
	320	;; i.e: VERSION_NUMBER DATE: CONTENTS
	321	(defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
	322
	323	(defun vc-hg-annotate-time ()
	324	(when (looking-at vc-hg-annotate-re)
	325	(goto-char (match-end 0))
	326	(vc-annotate-convert-time
	327	(date-to-time (match-string-no-properties 2)))))
	328
	329	(defun vc-hg-annotate-extract-revision-at-line ()
	330	(save-excursion
	331	(beginning-of-line)
	332	(if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
	333
	334	(defun vc-hg-previous-version (file rev)
	335	(let ((newrev (1- (string-to-number rev))))
	336	(when (>= newrev 0)
	337	(number-to-string newrev))))
	338
	339	(defun vc-hg-next-version (file rev)
	340	(let ((newrev (1+ (string-to-number rev)))
	341	(tip-version
	342	(with-temp-buffer
0c3b8cc4	343	(vc-hg-command t 0 nil "tip")
8b69ba6c DN	344	(goto-char (point-min))
	345	(re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
	346	(string-to-number (match-string-no-properties 1)))))
	347	;; We don't want to exceed the maximum possible version number, ie
	348	;; the tip version.
	349	(when (<= newrev tip-version)
	350	(number-to-string newrev))))
	351
	352	;; Modelled after the similar function in vc-bzr.el
	353	(defun vc-hg-delete-file (file)
	354	"Delete FILE and delete it in the hg repository."
	355	(condition-case ()
	356	(delete-file file)
	357	(file-error nil))
0c3b8cc4	358	(vc-hg-command nil 0 file "remove" "--after" "--force"))
8b69ba6c DN	359
	360	;; Modelled after the similar function in vc-bzr.el
	361	(defun vc-hg-rename-file (old new)
	362	"Rename file from OLD to NEW using `hg mv'."
0c3b8cc4	363	(vc-hg-command nil 0 new old "mv"))
8b69ba6c DN	364
	365	(defun vc-hg-register (file &optional rev comment)
	366	"Register FILE under hg.
	367	REV is ignored.
	368	COMMENT is ignored."
0c3b8cc4	369	(vc-hg-command nil 0 file "add"))
8b69ba6c DN	370
	371	(defalias 'vc-hg-responsible-p 'vc-hg-root)
	372
	373	;; Modelled after the similar function in vc-bzr.el
	374	(defun vc-hg-could-register (file)
	375	"Return non-nil if FILE could be registered under hg."
	376	(and (vc-hg-responsible-p file) ; shortcut
	377	(condition-case ()
	378	(with-temp-buffer
	379	(vc-hg-command t nil file "add" "--dry-run"))
	380	;; The command succeeds with no output if file is
	381	;; registered.
	382	(error))))
	383
	384	;; XXX This would remove the file. Is that correct?
	385	;; (defun vc-hg-unregister (file)
	386	;; "Unregister FILE from hg."
	387	;; (vc-hg-command nil nil file "remove"))
	388
	389	(defun vc-hg-checkin (file rev comment)
5716cebd	390	"Hg-specific version of `vc-backend-checkin'.
8b69ba6c	391	REV is ignored."
57b8089a	392	(vc-hg-command nil 0 file "commit" "-m" comment))
8b69ba6c DN	393
	394	(defun vc-hg-find-version (file rev buffer)
	395	(let ((coding-system-for-read 'binary)
	396	(coding-system-for-write 'binary))
	397	(if rev
0c3b8cc4 DN	398	(vc-hg-command buffer 0 file "cat" "-r" rev)
0c3b8cc4 DN	399	(vc-hg-command buffer 0 file "cat"))))
8b69ba6c DN	400
8b69ba6c DN	401	;; Modelled after the similar function in vc-bzr.el
908265fc DN	402	(defun vc-hg-checkout (file &optional editable rev)
	403	"Retrieve a revision of FILE.
	404	EDITABLE is ignored.
	405	REV is the revision to check out into WORKFILE."
	406	(let ((coding-system-for-read 'binary)
	407	(coding-system-for-write 'binary))
	408	(with-current-buffer (or (get-file-buffer file) (current-buffer))
	409	(if rev
0c3b8cc4 DN	410	(vc-hg-command t 0 file "cat" "-r" rev)
0c3b8cc4 DN	411	(vc-hg-command t 0 file "cat")))))
8b69ba6c DN	412
	413	(defun vc-hg-checkout-model (file)
	414	'implicit)
	415
727bdea1 DN	416	;; Modelled after the similar function in vc-bzr.el
	417	(defun vc-hg-workfile-unchanged-p (file)
	418	(eq 'up-to-date (vc-hg-state file)))
	419
908265fc DN	420	(defun vc-hg-dired-state-info (file)
	421	"Hg-specific version of `vc-dired-state-info'."
	422	(let ((hg-state (vc-state file)))
	423	(if (eq hg-state 'edited)
	424	(if (equal (vc-workfile-version file) "0")
	425	"(added)" "(modified)")
	426	;; fall back to the default VC representation
5716cebd	427	(vc-default-dired-state-info 'Hg file))))
908265fc	428
8b69ba6c DN	429	;; Modelled after the similar function in vc-bzr.el
	430	(defun vc-hg-revert (file &optional contents-done)
	431	(unless contents-done
0c3b8cc4	432	(with-temp-buffer (vc-hg-command t 0 file "revert"))))
8b69ba6c DN	433
	434	;;; Internal functions
	435
	436	(defun vc-hg-command (buffer okstatus file &rest flags)
	437	"A wrapper around `vc-do-command' for use in vc-hg.el.
	438	The difference to vc-do-command is that this function always invokes `hg',
	439	and that it passes `vc-hg-global-switches' to it before FLAGS."
	440	(apply 'vc-do-command buffer okstatus "hg" file
	441	(if (stringp vc-hg-global-switches)
	442	(cons vc-hg-global-switches flags)
	443	(append vc-hg-global-switches
	444	flags))))
	445
	446	(defun vc-hg-root (file)
	447	(vc-find-root file ".hg"))
	448
	449	(provide 'vc-hg)
	450
300e5e22	451	;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
8b69ba6c	452	;;; vc-hg.el ends here