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. See the comment at the
  39 ;; beginning of vc.el. The current status is:
  40
  41 ;; FUNCTION NAME                               STATUS
  42 ;; * registered (file)                         OK
  43 ;; * state (file)                              OK
  44 ;; - state-heuristic (file)                    ?? PROBABLY NOT NEEDED
  45 ;; - dir-state (dir)                           NEEDED
  46 ;; * workfile-version (file)                   OK
  47 ;; - latest-on-branch-p (file)                 ??
  48 ;; * checkout-model (file)                     OK
  49 ;; - workfile-unchanged-p (file)               ??
  50 ;; - mode-line-string (file)                   NOT NEEDED
  51 ;; - dired-state-info (file)                   NEEDED
  52 ;; STATE-CHANGING FUNCTIONS
  53 ;; * register (file &optional rev comment)     OK
  54 ;; - init-version ()                           NOT NEEDED
  55 ;; - responsible-p (file)                      OK
  56 ;; - could-register (file)                     OK
  57 ;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
  58 ;; - unregister (file)                         COMMENTED OUT, MAY BE INCORRECT
  59 ;; * checkin (file rev comment)                OK
  60 ;; * find-version (file rev buffer)            OK
  61 ;; * checkout (file &optional editable rev)    NOT NEEDED, COMMENTED OUT
  62 ;; * revert (file &optional contents-done)     OK
  63 ;; - cancel-version (file editable)            ?? PROBABLY NOT NEEDED
  64 ;; - merge (file rev1 rev2)                    NEEDED
  65 ;; - merge-news (file)                         NEEDED
  66 ;; - steal-lock (file &optional version)       NOT NEEDED
  67 ;; HISTORY FUNCTIONS
  68 ;; * print-log (file &optional buffer)         OK
  69 ;; - log-view-mode ()                          OK
  70 ;; - show-log-entry (version)                  NOT NEEDED, DEFAULT IS GOOD
  71 ;; - wash-log (file)                           ??
  72 ;; - logentry-check ()                         NOT NEEDED
  73 ;; - comment-history (file)                    NOT NEEDED
  74 ;; - update-changelog (files)                  NOT NEEDED
  75 ;; * diff (file &optional rev1 rev2 buffer)    OK
  76 ;; - revision-completion-table (file)          ??
  77 ;; - diff-tree (dir &optional rev1 rev2)       TEST IT
  78 ;; - annotate-command (file buf &optional rev) OK
  79 ;; - annotate-time ()                          OK
  80 ;; - annotate-current-time ()                  ?? NOT NEEDED
  81 ;; - annotate-extract-revision-at-line ()      OK
  82 ;; SNAPSHOT SYSTEM
  83 ;; - create-snapshot (dir name branchp)        NEEDED (probably branch?)
  84 ;; - assign-name (file name)                   NOT NEEDED
  85 ;; - retrieve-snapshot (dir name update)       ?? NEEDED??
  86 ;; MISCELLANEOUS
  87 ;; - make-version-backups-p (file)             ??
  88 ;; - repository-hostname (dirname)             ??
  89 ;; - previous-version (file rev)               OK
  90 ;; - next-version (file rev)                   OK
  91 ;; - check-headers ()                          ??
  92 ;; - clear-headers ()                          ??
  93 ;; - delete-file (file)                        TEST IT
  94 ;; - rename-file (old new)                     OK
  95 ;; - find-file-hook ()                         PROBABLY NOT NEEDED
  96 ;; - find-file-not-found-hook ()               PROBABLY NOT NEEDED
  97
  98 ;; Implement Stefan Monnier's advice:
  99 ;; vc-hg-registered and vc-hg-state
 100 ;; Both of those functions should be super extra careful to fail gracefully in
 101 ;; unexpected circumstances. The reason this is important is that any error
 102 ;; there will prevent the user from even looking at the file :-(
 103 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
 104 ;; mercurial's control and extracting the current revision should be done
 105 ;; without even using `hg' (this way even if you don't have `hg' installed,
 106 ;; Emacs is able to tell you this file is under mercurial's control).
 107
 108 ;;; History:
 109 ;;
 110
 111 ;;; Code:
 112
 113 (eval-when-compile
 114   (require 'vc))
 115
 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."
 140   (if (vc-hg-root file)               ; short cut
 141       (vc-hg-state file)))            ; expensive
 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
 162         (let ((state (aref out 0)))
 163           (cond
 164            ((eq state ?M) 'edited)
 165            ((eq state ?A) 'edited)
 166            ((eq state ?P) 'needs-patch)
 167            ((eq state ??) nil)
 168            (t 'up-to-date)))))))
 169
 170 (defun vc-hg-workfile-version (file)
 171   "Hg-specific version of `vc-workfile-version'."
 172   (let*
 173       ((status nil)
 174        (out
 175         (with-output-to-string
 176           (with-current-buffer
 177               standard-output
 178             (setq status
 179                   (condition-case nil
 180                       ;; Ignore all errors.
 181                       (call-process
 182                        "hg" nil t nil "--cwd" (file-name-directory file)
 183                        "log" "-l1" (file-name-nondirectory file))
 184                     ;; Some problem happened.  E.g. We can't find an `hg'
 185                     ;; executable.
 186                     (error nil)))))))
 187     (when (eq 0 status)
 188       (if (string-match "changeset: *\\([0-9]*\\)" out)
 189           (match-string 1 out)
 190         "0"))))
 191
 192 ;;; History functions
 193
 194 (defun vc-hg-print-log(file &optional buffer)
 195   "Get change log associated with FILE."
 196   ;; `log-view-mode' needs to have the file name in order to function
 197   ;; correctly. "hg log" does not print it, so we insert it here by
 198   ;; hand.
 199
 200   ;; `vc-do-command' creates the buffer, but we need it before running
 201   ;; the command.
 202   (vc-setup-buffer buffer)
 203   ;; If the buffer exists from a previous invocation it might be
 204   ;; read-only.
 205   (let ((inhibit-read-only t))
 206     (with-current-buffer
 207         buffer
 208       (insert "File:        " (file-name-nondirectory file) "\n")))
 209   (vc-hg-command
 210    buffer
 211    (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
 212    file "log"))
 213
 214 (defvar log-view-message-re)
 215 (defvar log-view-file-re)
 216 (defvar log-view-font-lock-keywords)
 217
 218 (define-derived-mode vc-hg-log-view-mode log-view-mode "HG-Log-View"
 219   (require 'add-log) ;; we need the faces add-log
 220   ;; Don't have file markers, so use impossible regexp.
 221   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 222   (set (make-local-variable 'log-view-message-re)
 223        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 224   (set (make-local-variable 'log-view-font-lock-keywords)
 225        (append
 226         log-view-font-lock-keywords
 227         ;; Handle the case:
 228         ;; user: foo@bar
 229         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 230            (1 'change-log-email))
 231           ;; Handle the case:
 232           ;; user: FirstName LastName <foo@bar>
 233           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 234            (1 'change-log-name)
 235            (2 'change-log-email))
 236           ("^date: \\(.+\\)" (1 'change-log-date))
 237           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 238
 239 (defun vc-hg-diff (file &optional oldvers newvers buffer)
 240   "Get a difference report using hg between two versions of FILE."
 241   (let ((working (vc-workfile-version file)))
 242     (if (and (equal oldvers working) (not newvers))
 243         (setq oldvers nil))
 244     (if (and (not oldvers) newvers)
 245         (setq oldvers working))
 246     (apply 'call-process "hg" nil (or buffer "*vc-diff*") nil
 247            "--cwd" (file-name-directory file) "diff"
 248            (append
 249             (if oldvers
 250                 (if newvers
 251                     (list "-r" oldvers "-r" newvers)
 252                   (list "-r" oldvers))
 253               (list ""))
 254             (list (file-name-nondirectory file))))))
 255
 256 (defalias 'vc-hg-diff-tree 'vc-hg-diff)
 257
 258 (defun vc-hg-annotate-command (file buffer &optional version)
 259   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 260 Optional arg VERSION is a version to annotate from."
 261   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 262   (with-current-buffer buffer
 263     (goto-char (point-min))
 264     (re-search-forward "^[0-9]")
 265     (delete-region (point-min) (1- (point)))))
 266
 267
 268 ;; The format for one line output by "hg annotate -d -n" looks like this:
 269 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 270 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 271 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 272
 273 (defun vc-hg-annotate-time ()
 274   (when (looking-at vc-hg-annotate-re)
 275     (goto-char (match-end 0))
 276     (vc-annotate-convert-time
 277      (date-to-time (match-string-no-properties 2)))))
 278
 279 (defun vc-hg-annotate-extract-revision-at-line ()
 280   (save-excursion
 281     (beginning-of-line)
 282     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 283
 284 (defun vc-hg-previous-version (file rev)
 285   (let ((newrev (1- (string-to-number rev))))
 286     (when (>= newrev 0)
 287       (number-to-string newrev))))
 288
 289 (defun vc-hg-next-version (file rev)
 290   (let ((newrev (1+ (string-to-number rev)))
 291         (tip-version
 292          (with-temp-buffer
 293            (vc-hg-command t nil nil "tip")
 294            (goto-char (point-min))
 295            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 296            (string-to-number (match-string-no-properties 1)))))
 297     ;; We don't want to exceed the maximum possible version number, ie
 298     ;; the tip version.
 299     (when (<= newrev tip-version)
 300       (number-to-string newrev))))
 301
 302 ;; Modelled after the similar function in vc-bzr.el
 303 (defun vc-hg-delete-file (file)
 304   "Delete FILE and delete it in the hg repository."
 305   (condition-case ()
 306       (delete-file file)
 307     (file-error nil))
 308   (vc-hg-command nil nil file "remove" "--after" "--force"))
 309
 310 ;; Modelled after the similar function in vc-bzr.el
 311 (defun vc-hg-rename-file (old new)
 312   "Rename file from OLD to NEW using `hg mv'."
 313   (vc-hg-command nil nil new old "mv"))
 314
 315 (defun vc-hg-register (file &optional rev comment)
 316   "Register FILE under hg.
 317 REV is ignored.
 318 COMMENT is ignored."
 319   (vc-hg-command nil nil file "add"))
 320
 321 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 322
 323 ;; Modelled after the similar function in vc-bzr.el
 324 (defun vc-hg-could-register (file)
 325   "Return non-nil if FILE could be registered under hg."
 326   (and (vc-hg-responsible-p file)      ; shortcut
 327        (condition-case ()
 328            (with-temp-buffer
 329              (vc-hg-command t nil file "add" "--dry-run"))
 330              ;; The command succeeds with no output if file is
 331              ;; registered.
 332          (error))))
 333
 334 ;; XXX This would remove the file. Is that correct?
 335 ;; (defun vc-hg-unregister (file)
 336 ;;   "Unregister FILE from hg."
 337 ;;   (vc-hg-command nil nil file "remove"))
 338
 339 (defun vc-hg-checkin (file rev comment)
 340   "HG-specific version of `vc-backend-checkin'.
 341 REV is ignored."
 342   (vc-hg-command nil nil file  "commit" "-m" comment))
 343
 344 (defun vc-hg-find-version (file rev buffer)
 345   (let ((coding-system-for-read 'binary)
 346         (coding-system-for-write 'binary))
 347     (if rev
 348         (vc-hg-command buffer nil file "cat" "-r" rev)
 349       (vc-hg-command buffer nil file "cat"))))
 350
 351 ;; Modelled after the similar function in vc-bzr.el
 352 ;; This should not be needed, `vc-hg-find-version' provides the same
 353 ;; functionality.
 354 ;; (defun vc-hg-checkout (file &optional editable rev workfile)
 355 ;;   "Retrieve a revision of FILE into a WORKFILE.
 356 ;; EDITABLE is ignored.
 357 ;; REV is the revision to check out into WORKFILE."
 358 ;;   (unless workfile
 359 ;;     (setq workfile (vc-version-backup-file-name file rev)))
 360 ;;   (let ((coding-system-for-read 'binary)
 361 ;;         (coding-system-for-write 'binary))
 362 ;;   (with-temp-file workfile
 363 ;;     (if rev
 364 ;;         (vc-hg-command t nil file "cat" "-r" rev)
 365 ;;       (vc-hg-command t nil file "cat")))))
 366
 367 (defun vc-hg-checkout-model (file)
 368   'implicit)
 369
 370 ;; Modelled after the similar function in vc-bzr.el
 371 (defun vc-hg-revert (file &optional contents-done)
 372   (unless contents-done
 373     (with-temp-buffer (vc-hg-command t nil file "revert"))))
 374
 375 ;;; Internal functions
 376
 377 (defun vc-hg-command (buffer okstatus file &rest flags)
 378   "A wrapper around `vc-do-command' for use in vc-hg.el.
 379 The difference to vc-do-command is that this function always invokes `hg',
 380 and that it passes `vc-hg-global-switches' to it before FLAGS."
 381   (apply 'vc-do-command buffer okstatus "hg" file
 382          (if (stringp vc-hg-global-switches)
 383              (cons vc-hg-global-switches flags)
 384            (append vc-hg-global-switches
 385                    flags))))
 386
 387 (defun vc-hg-root (file)
 388   (vc-find-root file ".hg"))
 389
 390 (provide 'vc-hg)
 391
 392 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 393 ;;; vc-hg.el ends here