lisp/vc-hg.el

   1 ;;; vc-hg.el --- VC backend for the mercurial version control system
   2
   3 ;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
   4
   5 ;; Author: Ivan Kanis
   6 ;; Keywords: tools
   7 ;; Version: 1889
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This is a mercurial version control backend
  29
  30 ;;; Thanks:
  31
  32 ;;; Bugs:
  33
  34 ;;; Installation:
  35
  36 ;;; Todo:
  37
  38 ;; Implement the rest of the vc interface:
  39 ;; - dired
  40 ;; - snapshot?
  41
  42 ;; Implement Stefan Monnier's advice:
  43 ;; vc-hg-registered and vc-hg-state
  44 ;; Both of those functions should be super extra careful to fail gracefully in
  45 ;; unexpected circumstances.  The most important such case is when the `hg'
  46 ;; executable is not available.  The reason this is important is that any error
  47 ;; there will prevent the user from even looking at the file :-(
  48 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
  49 ;; mercurial's control and extracting the current revision should be done
  50 ;; without even using `hg' (this way even if you don't have `hg' installed,
  51 ;; Emacs is able to tell you this file is under mercurial's control).
  52
  53 ;;; History:
  54 ;;
  55
  56 ;;; Code:
  57
  58 (eval-when-compile
  59   (require 'vc))
  60
  61 ;; XXX This should be moved to vc-hooks when we can be sure that vc-state
  62 ;; and friends are always harmless.
  63 (add-to-list 'vc-handled-backends 'HG)
  64
  65 ;;; Customization options
  66
  67 (defcustom vc-hg-global-switches nil
  68   "*Global switches to pass to any Hg command."
  69   :type '(choice (const :tag "None" nil)
  70          (string :tag "Argument String")
  71          (repeat :tag "Argument List"
  72              :value ("")
  73              string))
  74 ;;  :version "22.2"
  75   :group 'vc)
  76
  77 ;;; State querying functions
  78
  79 ;;;###autoload (defun vc-hg-registered (file)
  80 ;;;###autoload   "Return non-nil if FILE is registered with hg."
  81 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
  82 ;;;###autoload       (progn
  83 ;;;###autoload         (load "vc-hg")
  84 ;;;###autoload         (vc-hg-registered file))))
  85
  86 ;; Modelled after the similar function in vc-bzr.el
  87 (defun vc-hg-registered (file)
  88   "Return non-nil if FILE is registered with hg."
  89   (if (vc-find-root file ".hg")       ; short cut
  90       (vc-hg-state file)))            ; expensive
  91
  92 (defun vc-hg-state (file)
  93   "Hg-specific version of `vc-state'."
  94   (let ((out (vc-hg-internal-status file)))
  95     (if (eq 0 (length out)) 'up-to-date
  96       (let ((state (aref out 0)))
  97         (cond
  98          ((eq state ?M) 'edited)
  99          ((eq state ?A) 'edited)
 100          ((eq state ?P) 'needs-patch)
 101          ((eq state ??) nil)
 102          (t 'up-to-date))))))
 103
 104 (defun vc-hg-workfile-version (file)
 105   "Hg-specific version of `vc-workfile-version'."
 106   (let ((out (vc-hg-internal-log file)))
 107     (if (string-match "changeset: *\\([0-9]*\\)" out)
 108         (match-string 1 out)
 109       "0")))
 110
 111 ;;; History functions
 112
 113 (defun vc-hg-print-log(file &optional buffer)
 114   "Get change log associated with FILE."
 115   ;; `log-view-mode' needs to have the file name in order to function
 116   ;; correctly. "hg log" does not print it, so we insert it here by
 117   ;; hand.
 118
 119   ;; `vc-do-command' creates the buffer, but we need it before running
 120   ;; the command.
 121   (vc-setup-buffer buffer)
 122   ;; If the buffer exists from a previous invocation it might be
 123   ;; read-only.
 124   (let ((inhibit-read-only t))
 125     (with-current-buffer
 126         buffer
 127       (insert "File:        " (file-name-nondirectory file) "\n")))
 128   (vc-hg-command
 129    buffer
 130    (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
 131    file "log"))
 132
 133 (defvar log-view-message-re)
 134 (defvar log-view-file-re)
 135 (defvar log-view-font-lock-keywords)
 136
 137 (define-derived-mode vc-hg-log-view-mode log-view-mode "HG-Log-View"
 138   (require 'add-log) ;; we need the faces add-log
 139   ;; Don't have file markers, so use impossible regexp.
 140   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 141   (set (make-local-variable 'log-view-message-re)
 142        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 143   (set (make-local-variable 'log-view-font-lock-keywords)
 144        (append
 145         log-view-font-lock-keywords
 146         ;; Handle the case:
 147         ;; user: foo@bar
 148         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 149            (1 'change-log-email))
 150           ;; Handle the case:
 151           ;; user: FirstName LastName <foo@bar>
 152           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 153            (1 'change-log-name)
 154            (2 'change-log-email))
 155           ("^date: \\(.+\\)" (1 'change-log-date))
 156           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 157
 158 (defun vc-hg-diff (file &optional oldvers newvers buffer)
 159   "Get a difference report using hg between two versions of FILE."
 160   (let ((working (vc-workfile-version file)))
 161     (if (and (equal oldvers working) (not newvers))
 162         (setq oldvers nil))
 163     (if (and (not oldvers) newvers)
 164         (setq oldvers working))
 165     (apply 'call-process "hg" nil (or buffer "*vc-diff*") nil
 166            "--cwd" (file-name-directory file) "diff"
 167            (append
 168             (if oldvers
 169                 (if newvers
 170                     (list "-r" oldvers "-r" newvers)
 171                   (list "-r" oldvers))
 172               (list ""))
 173             (list (file-name-nondirectory file))))))
 174
 175 (defun vc-hg-annotate-command (file buffer &optional version)
 176   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 177 Optional arg VERSION is a version to annotate from."
 178   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 179   (with-current-buffer buffer
 180     (goto-char (point-min))
 181     (re-search-forward "^[0-9]")
 182     (delete-region (point-min) (1- (point)))))
 183
 184
 185 ;; The format for one line output by "hg annotate -d -n" looks like this:
 186 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 187 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 188 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 189
 190 (defun vc-hg-annotate-time ()
 191   (when (looking-at vc-hg-annotate-re)
 192     (goto-char (match-end 0))
 193     (vc-annotate-convert-time
 194      (date-to-time (match-string-no-properties 2)))))
 195
 196 (defun vc-hg-annotate-extract-revision-at-line ()
 197   (save-excursion
 198     (beginning-of-line)
 199     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 200
 201 (defun vc-hg-previous-version (file rev)
 202   (let ((newrev (1- (string-to-number rev))))
 203     (when (>= newrev 0)
 204       (number-to-string newrev))))
 205
 206 (defun vc-hg-register (file &optional rev comment)
 207   "Register FILE under hg.
 208 REV is ignored.
 209 COMMENT is ignored."
 210   (vc-hg-command nil nil file "add"))
 211
 212 (defun vc-hg-checkin (file rev comment)
 213   "HG-specific version of `vc-backend-checkin'.
 214 REV is ignored."
 215   (vc-hg-command nil nil file  "commit" "-m" comment))
 216
 217 ;; Modelled after the similar function in vc-bzr.el
 218 (defun vc-hg-checkout (file &optional editable rev workfile)
 219   "Retrieve a revision of FILE into a WORKFILE.
 220 EDITABLE is ignored.
 221 REV is the revision to check out into WORKFILE."
 222   (unless workfile
 223     (setq workfile (vc-version-backup-file-name file rev)))
 224   (let ((coding-system-for-read 'binary)
 225         (coding-system-for-write 'binary))
 226   (with-temp-file workfile
 227     (if rev
 228         (vc-hg-command t nil file "cat" "-r" rev)
 229       (vc-hg-command t nil file "cat")))))
 230
 231 (defun vc-hg-checkout-model (file)
 232   'implicit)
 233
 234 ;;; Internal functions
 235
 236 (defun vc-hg-command (buffer okstatus file &rest flags)
 237   "A wrapper around `vc-do-command' for use in vc-hg.el.
 238 The difference to vc-do-command is that this function always invokes `hg',
 239 and that it passes `vc-hg-global-switches' to it before FLAGS."
 240   (apply 'vc-do-command buffer okstatus "hg" file
 241          (if (stringp vc-hg-global-switches)
 242              (cons vc-hg-global-switches flags)
 243            (append vc-hg-global-switches
 244                    flags))))
 245
 246 (defun vc-hg-internal-log (file &optional buffer)
 247   "Return log of FILE."
 248   (with-output-to-string
 249     (with-current-buffer
 250         standard-output
 251       (call-process
 252        "hg" nil t nil "--cwd" (file-name-directory file)
 253        "log" "-l1" (file-name-nondirectory file)))))
 254
 255 (defun vc-hg-internal-status(file)
 256   "Return status of FILE."
 257   (with-output-to-string
 258     (with-current-buffer
 259         standard-output
 260       (call-process
 261        "hg" nil t nil "--cwd" (file-name-directory file)
 262        "status" (file-name-nondirectory file)))))
 263
 264 (provide 'vc-hg)
 265
 266 ;;; vc-hg.el ends here