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

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

;; Copyright (C) 2006, 2007 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
;; BACKEND PROPERTIES
;; * revision-granularity                      OK
;; STATE-QUERYING FUNCTIONS
;; * 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 (files &optional rev comment)    OK
;; * create-repo ()                            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 (files rev comment)               OK
;; * find-version (file rev buffer)            OK
;; * checkout (file &optional editable rev)    OK
;; * revert (file &optional contents-done)     OK
;; - rollback (files)                          ?? PROBABLY NOT NEEDED   
;; - merge (file rev1 rev2)                    NEEDED
;; - merge-news (file)                         NEEDED
;; - steal-lock (file &optional version)       NOT NEEDED
;; HISTORY FUNCTIONS
;; * print-log (files &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 (files &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)

\f
;;; Properties of the backend

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

;;; 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 nil "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-workfile-version "0")
	  (vc-file-setprop file 'vc-state 'edited))
	 ((eq status-char ?M)
	  (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(files &optional buffer)
  "Get change log associated with FILES."
  ;; `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))
    ;; We need to loop and call "hg log" on each file separately. 
    ;; "hg log" with multiple file arguments mashes all the logs
    ;; together.
    (dolist (file files)
      (with-current-buffer
	  buffer
	(insert "File:        " (file-name-nondirectory file) "\n"))
      (vc-hg-command buffer 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 add-log faces
  (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: foo@bar
	'(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
	   (1 'change-log-email))
	  ;; 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))
	  ("^date: \\(.+\\)" (1 'change-log-date))
	  ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))

(defun vc-hg-diff (files &optional oldvers newvers buffer)
  "Get a difference report using hg between two versions of FILES."
  (let ((working (vc-workfile-version (car files))))
    (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
	   (mapcar (lambda (file) (file-name-nondirectory file)) files)
	   "--cwd" (file-name-directory (car files))
	   "diff"
	   (append
	    (if oldvers
		(if newvers
		    (list "-r" oldvers "-r" newvers)
		  (list "-r" oldvers))
	      (list ""))))))

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

(defun vc-hg-diff-tree (file &optional oldvers newvers buffer)
  (vc-hg-diff (list file) oldvers newvers buffer))

(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 (files &optional rev comment)
  "Register FILES under hg.
REV is ignored.
COMMENT is ignored."
  (vc-hg-command nil 0 files "add"))

(defun vc-hg-create-repo ()
  "Create a new Mercurial repository."
  (vc-hg-command nil 0 nil "init"))

(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 (files rev comment)
  "Hg-specific version of `vc-backend-checkin'.
REV is ignored."
  (vc-hg-command nil 0 files  "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"))))

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

;; 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)))

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

;;; Internal functions

(defun vc-hg-command (buffer okstatus file-or-list &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-or-list
         (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
61223448 DN	1	;;; vc-hg.el --- VC backend for the mercurial version control system
61223448 DN	2
248c6645 DN	3	;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
248c6645 DN	4
61223448	5	;; Author: Ivan Kanis
248c6645	6	;; Keywords: tools
a58b1e40 GM	7
	8	;; This file is part of GNU Emacs.
	9
	10	;; GNU Emacs is free software; you can redistribute it and/or modify
61223448	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)
a58b1e40 GM	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
61223448	20	;; You should have received a copy of the GNU General Public License
a58b1e40 GM	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.
61223448 DN	24
	25	;;; Commentary:
	26
	27	;; This is a mercurial version control backend
	28
248c6645 DN	29	;;; Thanks:
	30
	31	;;; Bugs:
	32
	33	;;; Installation:
	34
	35	;;; Todo:
	36
a07e665b DN	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
a6ea7ffc DN	41	;; BACKEND PROPERTIES
	42	;; * revision-granularity OK
	43	;; STATE-QUERYING FUNCTIONS
a07e665b DN	44	;; * registered (file) OK
	45	;; * state (file) OK
	46	;; - state-heuristic (file) ?? PROBABLY NOT NEEDED
a6ea7ffc	47	;; - dir-state (dir) OK
a07e665b DN	48	;; * workfile-version (file) OK
	49	;; - latest-on-branch-p (file) ??
	50	;; * checkout-model (file) OK
a272e668	51	;; - workfile-unchanged-p (file) OK
a07e665b	52	;; - mode-line-string (file) NOT NEEDED
a6ea7ffc	53	;; - dired-state-info (file) OK
a07e665b	54	;; STATE-CHANGING FUNCTIONS
8cdd17b4	55	;; * register (files &optional rev comment) OK
a6ea7ffc	56	;; * create-repo () OK
a07e665b DN	57	;; - init-version () NOT NEEDED
	58	;; - responsible-p (file) OK
	59	;; - could-register (file) OK
	60	;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
	61	;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
8cdd17b4	62	;; * checkin (files rev comment) OK
a07e665b	63	;; * find-version (file rev buffer) OK
a6ea7ffc	64	;; * checkout (file &optional editable rev) OK
a07e665b	65	;; * revert (file &optional contents-done) OK
8cdd17b4	66	;; - rollback (files) ?? PROBABLY NOT NEEDED
a07e665b DN	67	;; - merge (file rev1 rev2) NEEDED
	68	;; - merge-news (file) NEEDED
	69	;; - steal-lock (file &optional version) NOT NEEDED
	70	;; HISTORY FUNCTIONS
8cdd17b4	71	;; * print-log (files &optional buffer) OK
a07e665b DN	72	;; - log-view-mode () OK
	73	;; - show-log-entry (version) NOT NEEDED, DEFAULT IS GOOD
	74	;; - wash-log (file) ??
	75	;; - logentry-check () NOT NEEDED
	76	;; - comment-history (file) NOT NEEDED
	77	;; - update-changelog (files) NOT NEEDED
8cdd17b4	78	;; * diff (files &optional rev1 rev2 buffer) OK
57b8089a	79	;; - revision-completion-table (file) COMMENTED OUT AS A WORKAROUND FOR A BUG
a07e665b DN	80	;; - diff-tree (dir &optional rev1 rev2) TEST IT
	81	;; - annotate-command (file buf &optional rev) OK
	82	;; - annotate-time () OK
	83	;; - annotate-current-time () ?? NOT NEEDED
	84	;; - annotate-extract-revision-at-line () OK
	85	;; SNAPSHOT SYSTEM
	86	;; - create-snapshot (dir name branchp) NEEDED (probably branch?)
	87	;; - assign-name (file name) NOT NEEDED
	88	;; - retrieve-snapshot (dir name update) ?? NEEDED??
	89	;; MISCELLANEOUS
	90	;; - make-version-backups-p (file) ??
	91	;; - repository-hostname (dirname) ??
	92	;; - previous-version (file rev) OK
	93	;; - next-version (file rev) OK
	94	;; - check-headers () ??
	95	;; - clear-headers () ??
	96	;; - delete-file (file) TEST IT
	97	;; - rename-file (old new) OK
	98	;; - find-file-hook () PROBABLY NOT NEEDED
	99	;; - find-file-not-found-hook () PROBABLY NOT NEEDED
61223448	100
11a4edc2	101	;; Implement Stefan Monnier's advice:
248c6645 DN	102	;; vc-hg-registered and vc-hg-state
248c6645 DN	103	;; Both of those functions should be super extra careful to fail gracefully in
a07e665b	104	;; unexpected circumstances. The reason this is important is that any error
248c6645 DN	105	;; there will prevent the user from even looking at the file :-(
	106	;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
	107	;; mercurial's control and extracting the current revision should be done
	108	;; without even using `hg' (this way even if you don't have `hg' installed,
	109	;; Emacs is able to tell you this file is under mercurial's control).
61223448	110
248c6645	111	;;; History:
11a4edc2	112	;;
61223448 DN	113
	114	;;; Code:
	115
	116	(eval-when-compile
34b7fb85	117	(require 'cl)
61223448 DN	118	(require 'vc))
61223448 DN	119
61223448 DN	120	;;; Customization options
	121
	122	(defcustom vc-hg-global-switches nil
	123	"*Global switches to pass to any Hg command."
	124	:type '(choice (const :tag "None" nil)
	125	(string :tag "Argument String")
	126	(repeat :tag "Argument List"
	127	:value ("")
	128	string))
a07e665b	129	:version "22.2"
61223448 DN	130	:group 'vc)
61223448 DN	131
8cdd17b4 ER	132	\f
	133	;;; Properties of the backend
	134
	135	(defun vc-hg-revision-granularity ()
	136	'repository)
	137
61223448 DN	138	;;; State querying functions
61223448 DN	139
11a4edc2 SM	140	;;;###autoload (defun vc-hg-registered (file)
	141	;;;###autoload "Return non-nil if FILE is registered with hg."
	142	;;;###autoload (if (vc-find-root file ".hg") ; short cut
	143	;;;###autoload (progn
	144	;;;###autoload (load "vc-hg")
	145	;;;###autoload (vc-hg-registered file))))
	146
	147	;; Modelled after the similar function in vc-bzr.el
61223448	148	(defun vc-hg-registered (file)
248c6645	149	"Return non-nil if FILE is registered with hg."
a6ea7ffc	150	(when (vc-hg-root file) ; short cut
791869eb	151	(vc-file-setprop file 'vc-state (vc-hg-state file)))) ; expensive
61223448 DN	152
61223448 DN	153	(defun vc-hg-state (file)
248c6645	154	"Hg-specific version of `vc-state'."
b33ac3b7 DN	155	(let*
	156	((status nil)
	157	(out
	158	(with-output-to-string
	159	(with-current-buffer
	160	standard-output
	161	(setq status
	162	(condition-case nil
	163	;; Ignore all errors.
	164	(call-process
	165	"hg" nil t nil "--cwd" (file-name-directory file)
	166	"status" (file-name-nondirectory file))
	167	;; Some problem happened. E.g. We can't find an `hg'
	168	;; executable.
	169	(error nil)))))))
	170	(when (eq 0 status)
	171	(if (eq 0 (length out)) 'up-to-date
a6ea7ffc DN	172	(when (null (string-match ".*: No such file or directory$" out))
	173	(let ((state (aref out 0)))
	174	(cond
	175	((eq state ?A) 'edited)
	176	((eq state ?M) 'edited)
	177	((eq state ?R) nil)
	178	((eq state ??) nil)
	179	(t 'up-to-date))))))))
	180
	181	(defun vc-hg-dir-state (dir)
	182	(with-temp-buffer
	183	(vc-hg-command (current-buffer) nil nil "status")
	184	(goto-char (point-min))
	185	(let ((status-char nil)
	186	(file nil))
34b7fb85	187	(while (not (eobp))
a6ea7ffc DN	188	(setq status-char (char-after))
	189	(setq file
	190	(expand-file-name
34b7fb85 DN	191	(buffer-substring-no-properties (+ (point) 2)
34b7fb85 DN	192	(line-end-position))))
a6ea7ffc DN	193	(cond
	194	;; The rest of the possible states in "hg status" output:
	195	;; R = removed
	196	;; ! = deleted, but still tracked
	197	;; ? = not tracked
	198	;; should not show up in vc-dired, so don't deal with them
	199	;; here.
	200	((eq status-char ?A)
	201	(vc-file-setprop file 'vc-workfile-version "0")
	202	(vc-file-setprop file 'vc-state 'edited))
	203	((eq status-char ?M)
	204	(vc-file-setprop file 'vc-state 'edited))
	205	((eq status-char ??)
	206	(vc-file-setprop file 'vc-backend 'none)
34b7fb85 DN	207	(vc-file-setprop file 'vc-state 'nil)))
34b7fb85 DN	208	(forward-line)))))
61223448 DN	209
61223448 DN	210	(defun vc-hg-workfile-version (file)
248c6645	211	"Hg-specific version of `vc-workfile-version'."
b33ac3b7 DN	212	(let*
	213	((status nil)
	214	(out
	215	(with-output-to-string
	216	(with-current-buffer
	217	standard-output
	218	(setq status
	219	(condition-case nil
	220	;; Ignore all errors.
	221	(call-process
	222	"hg" nil t nil "--cwd" (file-name-directory file)
	223	"log" "-l1" (file-name-nondirectory file))
	224	;; Some problem happened. E.g. We can't find an `hg'
	225	;; executable.
	226	(error nil)))))))
	227	(when (eq 0 status)
	228	(if (string-match "changeset: \\([0-9]\\)" out)
	229	(match-string 1 out)
	230	"0"))))
61223448	231
61223448 DN	232	;;; History functions
61223448 DN	233
8cdd17b4 ER	234	(defun vc-hg-print-log(files &optional buffer)
8cdd17b4 ER	235	"Get change log associated with FILES."
7c1912af DN	236	;; `log-view-mode' needs to have the file name in order to function
	237	;; correctly. "hg log" does not print it, so we insert it here by
	238	;; hand.
	239
	240	;; `vc-do-command' creates the buffer, but we need it before running
	241	;; the command.
	242	(vc-setup-buffer buffer)
	243	;; If the buffer exists from a previous invocation it might be
	244	;; read-only.
	245	(let ((inhibit-read-only t))
a6ea7ffc DN	246	;; We need to loop and call "hg log" on each file separately.
	247	;; "hg log" with multiple file arguments mashes all the logs
	248	;; together.
	249	(dolist (file files)
	250	(with-current-buffer
	251	buffer
	252	(insert "File: " (file-name-nondirectory file) "\n"))
34b7fb85	253	(vc-hg-command buffer 0 file "log"))))
61223448	254
d797e643 DN	255	(defvar log-view-message-re)
	256	(defvar log-view-file-re)
	257	(defvar log-view-font-lock-keywords)
d797e643	258
4211679b	259	(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
f0230324	260	(require 'add-log) ;; we need the add-log faces
7c1912af	261	(set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
d797e643 DN	262	(set (make-local-variable 'log-view-message-re)
	263	"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
	264	(set (make-local-variable 'log-view-font-lock-keywords)
11a4edc2	265	(append
e72e768b	266	log-view-font-lock-keywords
d797e643 DN	267	;; Handle the case:
	268	;; user: foo@bar
	269	'(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
	270	(1 'change-log-email))
	271	;; Handle the case:
	272	;; user: FirstName LastName <foo@bar>
	273	("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
	274	(1 'change-log-name)
	275	(2 'change-log-email))
	276	("^date: \\(.+\\)" (1 'change-log-date))
e72e768b	277	("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
d797e643	278
8cdd17b4 ER	279	(defun vc-hg-diff (files &optional oldvers newvers buffer)
	280	"Get a difference report using hg between two versions of FILES."
	281	(let ((working (vc-workfile-version (car files))))
cdaf01cc DN	282	(if (and (equal oldvers working) (not newvers))
	283	(setq oldvers nil))
	284	(if (and (not oldvers) newvers)
	285	(setq oldvers working))
d7927b9f DN	286	(apply #'vc-hg-command (or buffer "vc-diff") nil
	287	(mapcar (lambda (file) (file-name-nondirectory file)) files)
	288	"--cwd" (file-name-directory (car files))
	289	"diff"
11a4edc2	290	(append
cdaf01cc DN	291	(if oldvers
	292	(if newvers
	293	(list "-r" oldvers "-r" newvers)
	294	(list "-r" oldvers))
d7927b9f	295	(list ""))))))
cdaf01cc	296
34b7fb85 DN	297	(defun vc-hg-revision-table (file)
	298	(let ((default-directory (file-name-directory file)))
	299	(with-temp-buffer
	300	(vc-hg-command t nil file "log" "--template" "{rev} ")
	301	(split-string
	302	(buffer-substring-no-properties (point-min) (point-max))))))
	303
	304	;; Modelled after the similar function in vc-cvs.el
eff23ff3 DN	305	(defun vc-hg-revision-completion-table (file)
	306	(lexical-let ((file file)
	307	table)
	308	(setq table (lazy-completion-table
	309	table (lambda () (vc-hg-revision-table file))))
	310	table))
34b7fb85	311
8cdd17b4 ER	312	(defun vc-hg-diff-tree (file &optional oldvers newvers buffer)
8cdd17b4 ER	313	(vc-hg-diff (list file) oldvers newvers buffer))
a07e665b	314
cdaf01cc DN	315	(defun vc-hg-annotate-command (file buffer &optional version)
	316	"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
	317	Optional arg VERSION is a version to annotate from."
	318	(vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
	319	(with-current-buffer buffer
	320	(goto-char (point-min))
	321	(re-search-forward "^[0-9]")
	322	(delete-region (point-min) (1- (point)))))
	323
	324
11a4edc2 SM	325	;; The format for one line output by "hg annotate -d -n" looks like this:
	326	;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
	327	;; i.e: VERSION_NUMBER DATE: CONTENTS
cdaf01cc DN	328	(defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
	329
	330	(defun vc-hg-annotate-time ()
	331	(when (looking-at vc-hg-annotate-re)
	332	(goto-char (match-end 0))
11a4edc2	333	(vc-annotate-convert-time
cdaf01cc DN	334	(date-to-time (match-string-no-properties 2)))))
	335
	336	(defun vc-hg-annotate-extract-revision-at-line ()
	337	(save-excursion
	338	(beginning-of-line)
	339	(if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
	340
	341	(defun vc-hg-previous-version (file rev)
	342	(let ((newrev (1- (string-to-number rev))))
	343	(when (>= newrev 0)
	344	(number-to-string newrev))))
61223448	345
a07e665b DN	346	(defun vc-hg-next-version (file rev)
	347	(let ((newrev (1+ (string-to-number rev)))
	348	(tip-version
	349	(with-temp-buffer
34b7fb85	350	(vc-hg-command t 0 nil "tip")
a07e665b DN	351	(goto-char (point-min))
	352	(re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
	353	(string-to-number (match-string-no-properties 1)))))
	354	;; We don't want to exceed the maximum possible version number, ie
	355	;; the tip version.
	356	(when (<= newrev tip-version)
	357	(number-to-string newrev))))
	358
	359	;; Modelled after the similar function in vc-bzr.el
	360	(defun vc-hg-delete-file (file)
	361	"Delete FILE and delete it in the hg repository."
	362	(condition-case ()
	363	(delete-file file)
	364	(file-error nil))
34b7fb85	365	(vc-hg-command nil 0 file "remove" "--after" "--force"))
a07e665b DN	366
	367	;; Modelled after the similar function in vc-bzr.el
	368	(defun vc-hg-rename-file (old new)
	369	"Rename file from OLD to NEW using `hg mv'."
34b7fb85	370	(vc-hg-command nil 0 new old "mv"))
a07e665b	371
8cdd17b4 ER	372	(defun vc-hg-register (files &optional rev comment)
8cdd17b4 ER	373	"Register FILES under hg.
248c6645 DN	374	REV is ignored.
248c6645 DN	375	COMMENT is ignored."
34b7fb85	376	(vc-hg-command nil 0 files "add"))
8cdd17b4 ER	377
	378	(defun vc-hg-create-repo ()
	379	"Create a new Mercurial repository."
34b7fb85	380	(vc-hg-command nil 0 nil "init"))
248c6645	381
a07e665b DN	382	(defalias 'vc-hg-responsible-p 'vc-hg-root)
	383
	384	;; Modelled after the similar function in vc-bzr.el
	385	(defun vc-hg-could-register (file)
	386	"Return non-nil if FILE could be registered under hg."
	387	(and (vc-hg-responsible-p file) ; shortcut
	388	(condition-case ()
	389	(with-temp-buffer
	390	(vc-hg-command t nil file "add" "--dry-run"))
	391	;; The command succeeds with no output if file is
	392	;; registered.
	393	(error))))
	394
	395	;; XXX This would remove the file. Is that correct?
	396	;; (defun vc-hg-unregister (file)
	397	;; "Unregister FILE from hg."
	398	;; (vc-hg-command nil nil file "remove"))
	399
8cdd17b4	400	(defun vc-hg-checkin (files rev comment)
4211679b	401	"Hg-specific version of `vc-backend-checkin'.
cdaf01cc	402	REV is ignored."
34b7fb85	403	(vc-hg-command nil 0 files "commit" "-m" comment))
cdaf01cc	404
a07e665b	405	(defun vc-hg-find-version (file rev buffer)
248c6645 DN	406	(let ((coding-system-for-read 'binary)
248c6645 DN	407	(coding-system-for-write 'binary))
248c6645	408	(if rev
34b7fb85 DN	409	(vc-hg-command buffer 0 file "cat" "-r" rev)
34b7fb85 DN	410	(vc-hg-command buffer 0 file "cat"))))
a07e665b DN	411
a07e665b DN	412	;; Modelled after the similar function in vc-bzr.el
a6ea7ffc DN	413	(defun vc-hg-checkout (file &optional editable rev)
	414	"Retrieve a revision of FILE.
	415	EDITABLE is ignored.
	416	REV is the revision to check out into WORKFILE."
	417	(let ((coding-system-for-read 'binary)
	418	(coding-system-for-write 'binary))
	419	(with-current-buffer (or (get-file-buffer file) (current-buffer))
	420	(if rev
34b7fb85 DN	421	(vc-hg-command t 0 file "cat" "-r" rev)
34b7fb85 DN	422	(vc-hg-command t 0 file "cat")))))
248c6645 DN	423
	424	(defun vc-hg-checkout-model (file)
	425	'implicit)
	426
a272e668 DN	427	;; Modelled after the similar function in vc-bzr.el
	428	(defun vc-hg-workfile-unchanged-p (file)
	429	(eq 'up-to-date (vc-hg-state file)))
	430
a6ea7ffc DN	431	(defun vc-hg-dired-state-info (file)
	432	"Hg-specific version of `vc-dired-state-info'."
	433	(let ((hg-state (vc-state file)))
	434	(if (eq hg-state 'edited)
	435	(if (equal (vc-workfile-version file) "0")
	436	"(added)" "(modified)")
	437	;; fall back to the default VC representation
4211679b	438	(vc-default-dired-state-info 'Hg file))))
a6ea7ffc	439
b33ac3b7 DN	440	;; Modelled after the similar function in vc-bzr.el
	441	(defun vc-hg-revert (file &optional contents-done)
	442	(unless contents-done
34b7fb85	443	(with-temp-buffer (vc-hg-command t 0 file "revert"))))
b33ac3b7	444
f0230324 DN	445	;;; Hg specific functionality.
	446
	447	;;; XXX This functionality is experimental/work in progress. It might
	448	;;; change without notice.
	449	(defvar vc-hg-extra-menu-map
	450	(let ((map (make-sparse-keymap)))
	451	(define-key map [incoming] '(menu-item "Show incoming" vc-hg-incoming))
	452	(define-key map [outgoing] '(menu-item "Show outgoing" vc-hg-outgoing))
	453	map))
	454
	455	(defun vc-hg-extra-menu () vc-hg-extra-menu-map)
	456
	457	(define-derived-mode vc-hg-outgoing-mode vc-hg-log-view-mode "Hg-Outgoing")
	458
	459	(define-derived-mode vc-hg-incoming-mode vc-hg-log-view-mode "Hg-Incoming")
	460
	461	;; XXX this adds another top level menu, instead figure out how to
	462	;; replace the Log-View menu.
	463	(easy-menu-define log-view-mode-menu vc-hg-outgoing-mode-map
	464	"Hg-outgoing Display Menu"
	465	`("Hg-outgoing"
	466	["Push selected" vc-hg-push]))
	467
	468	(easy-menu-define log-view-mode-menu vc-hg-incoming-mode-map
	469	"Hg-incoming Display Menu"
	470	`("Hg-incoming"
	471	["Pull selected" vc-hg-pull]))
	472
	473	(defun vc-hg-outgoing ()
	474	(interactive)
	475	(let ((bname "Hg outgoing"))
	476	(vc-hg-command bname 0 nil "outgoing" "-n")
	477	(pop-to-buffer bname)
	478	(vc-hg-outgoing-mode)))
	479
	480	(defun vc-hg-incoming ()
	481	(interactive)
	482	(let ((bname "Hg incoming"))
	483	(vc-hg-command bname 0 nil "incoming" "-n")
	484	(pop-to-buffer bname)
	485	(vc-hg-incoming-mode)))
	486
	487	;; XXX maybe also add key bindings for these functions.
	488	(defun vc-hg-push ()
	489	(interactive)
	490	(let ((marked-list (log-view-get-marked)))
	491	(if marked-list
	492	(vc-hg-command
	493	nil 0 nil
	494	(cons "push"
	495	(apply 'nconc
	496	(mapcar (lambda (arg) (list "-r" arg)) marked-list))))
	497	(error "No log entries selected for push"))))
	498
	499	(defun vc-hg-pull ()
	500	(interactive)
	501	(let ((marked-list (log-view-get-marked)))
	502	(if marked-list
	503	(vc-hg-command
	504	nil 0 nil
	505	(cons "pull"
	506	(apply 'nconc
	507	(mapcar (lambda (arg) (list "-r" arg)) marked-list))))
	508	(error "No log entries selected for pull"))))
509
61223448 DN	510	;;; Internal functions
61223448 DN	511
8cdd17b4	512	(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
61223448 DN	513	"A wrapper around `vc-do-command' for use in vc-hg.el.
	514	The difference to vc-do-command is that this function always invokes `hg',
	515	and that it passes `vc-hg-global-switches' to it before FLAGS."
8cdd17b4	516	(apply 'vc-do-command buffer okstatus "hg" file-or-list
61223448 DN	517	(if (stringp vc-hg-global-switches)
	518	(cons vc-hg-global-switches flags)
	519	(append vc-hg-global-switches
	520	flags))))
	521
a07e665b DN	522	(defun vc-hg-root (file)
	523	(vc-find-root file ".hg"))
	524
61223448 DN	525	(provide 'vc-hg)
61223448 DN	526
eaaa2b09	527	;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
248c6645	528	;;; vc-hg.el ends here