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 ;; XXX This should be moved to vc-hooks after this gets a bit more
 117 ;; testing in the trunk.
 118 (add-to-list 'vc-handled-backends 'HG)
 119
 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))
 129   :version "22.2"
 130   :group 'vc)
 131
 132 ;;; State querying functions
 133
 134 ;;;###autoload (defun vc-hg-registered (file)
 135 ;;;###autoload   "Return non-nil if FILE is registered with hg."
 136 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
 137 ;;;###autoload       (progn
 138 ;;;###autoload         (load "vc-hg")
 139 ;;;###autoload         (vc-hg-registered file))))
 140
 141 ;; Modelled after the similar function in vc-bzr.el
 142 (defun vc-hg-registered (file)
 143   "Return non-nil if FILE is registered with hg."
 144   (if (vc-hg-root file)               ; short cut
 145       (vc-hg-state file)))            ; expensive
 146
 147 (defun vc-hg-state (file)
 148   "Hg-specific version of `vc-state'."
 149   (let*
 150       ((status nil)
 151        (out
 152         (with-output-to-string
 153           (with-current-buffer
 154               standard-output
 155             (setq status
 156                   (condition-case nil
 157                       ;; Ignore all errors.
 158                       (call-process
 159                        "hg" nil t nil "--cwd" (file-name-directory file)
 160                        "status" (file-name-nondirectory file))
 161                     ;; Some problem happened.  E.g. We can't find an `hg'
 162                     ;; executable.
 163                     (error nil)))))))
 164     (when (eq 0 status)
 165       (if (eq 0 (length out)) 'up-to-date
 166         (let ((state (aref out 0)))
 167           (cond
 168            ((eq state ?M) 'edited)
 169            ((eq state ?A) 'edited)
 170            ((eq state ?P) 'needs-patch)
 171            ((eq state ??) nil)
 172            (t 'up-to-date)))))))
 173
 174 (defun vc-hg-workfile-version (file)
 175   "Hg-specific version of `vc-workfile-version'."
 176   (let*
 177       ((status nil)
 178        (out
 179         (with-output-to-string
 180           (with-current-buffer
 181               standard-output
 182             (setq status
 183                   (condition-case nil
 184                       ;; Ignore all errors.
 185                       (call-process
 186                        "hg" nil t nil "--cwd" (file-name-directory file)
 187                        "log" "-l1" (file-name-nondirectory file))
 188                     ;; Some problem happened.  E.g. We can't find an `hg'
 189                     ;; executable.
 190                     (error nil)))))))
 191     (when (eq 0 status)
 192       (if (string-match "changeset: *\\([0-9]*\\)" out)
 193           (match-string 1 out)
 194         "0"))))
 195
 196 ;;; History functions
 197
 198 (defun vc-hg-print-log(file &optional buffer)
 199   "Get change log associated with FILE."
 200   ;; `log-view-mode' needs to have the file name in order to function
 201   ;; correctly. "hg log" does not print it, so we insert it here by
 202   ;; hand.
 203
 204   ;; `vc-do-command' creates the buffer, but we need it before running
 205   ;; the command.
 206   (vc-setup-buffer buffer)
 207   ;; If the buffer exists from a previous invocation it might be
 208   ;; read-only.
 209   (let ((inhibit-read-only t))
 210     (with-current-buffer
 211         buffer
 212       (insert "File:        " (file-name-nondirectory file) "\n")))
 213   (vc-hg-command
 214    buffer
 215    (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
 216    file "log"))
 217
 218 (defvar log-view-message-re)
 219 (defvar log-view-file-re)
 220 (defvar log-view-font-lock-keywords)
 221
 222 (define-derived-mode vc-hg-log-view-mode log-view-mode "HG-Log-View"
 223   (require 'add-log) ;; we need the faces add-log
 224   ;; Don't have file markers, so use impossible regexp.
 225   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 226   (set (make-local-variable 'log-view-message-re)
 227        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 228   (set (make-local-variable 'log-view-font-lock-keywords)
 229        (append
 230         log-view-font-lock-keywords
 231         ;; Handle the case:
 232         ;; user: foo@bar
 233         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 234            (1 'change-log-email))
 235           ;; Handle the case:
 236           ;; user: FirstName LastName <foo@bar>
 237           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 238            (1 'change-log-name)
 239            (2 'change-log-email))
 240           ("^date: \\(.+\\)" (1 'change-log-date))
 241           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 242
 243 (defun vc-hg-diff (file &optional oldvers newvers buffer)
 244   "Get a difference report using hg between two versions of FILE."
 245   (let ((working (vc-workfile-version file)))
 246     (if (and (equal oldvers working) (not newvers))
 247         (setq oldvers nil))
 248     (if (and (not oldvers) newvers)
 249         (setq oldvers working))
 250     (apply 'call-process "hg" nil (or buffer "*vc-diff*") nil
 251            "--cwd" (file-name-directory file) "diff"
 252            (append
 253             (if oldvers
 254                 (if newvers
 255                     (list "-r" oldvers "-r" newvers)
 256                   (list "-r" oldvers))
 257               (list ""))
 258             (list (file-name-nondirectory file))))))
 259
 260 (defalias 'vc-hg-diff-tree 'vc-hg-diff)
 261
 262 (defun vc-hg-annotate-command (file buffer &optional version)
 263   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 264 Optional arg VERSION is a version to annotate from."
 265   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 266   (with-current-buffer buffer
 267     (goto-char (point-min))
 268     (re-search-forward "^[0-9]")
 269     (delete-region (point-min) (1- (point)))))
 270
 271
 272 ;; The format for one line output by "hg annotate -d -n" looks like this:
 273 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 274 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 275 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 276
 277 (defun vc-hg-annotate-time ()
 278   (when (looking-at vc-hg-annotate-re)
 279     (goto-char (match-end 0))
 280     (vc-annotate-convert-time
 281      (date-to-time (match-string-no-properties 2)))))
 282
 283 (defun vc-hg-annotate-extract-revision-at-line ()
 284   (save-excursion
 285     (beginning-of-line)
 286     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 287
 288 (defun vc-hg-previous-version (file rev)
 289   (let ((newrev (1- (string-to-number rev))))
 290     (when (>= newrev 0)
 291       (number-to-string newrev))))
 292
 293 (defun vc-hg-next-version (file rev)
 294   (let ((newrev (1+ (string-to-number rev)))
 295         (tip-version
 296          (with-temp-buffer
 297            (vc-hg-command t nil nil "tip")
 298            (goto-char (point-min))
 299            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 300            (string-to-number (match-string-no-properties 1)))))
 301     ;; We don't want to exceed the maximum possible version number, ie
 302     ;; the tip version.
 303     (when (<= newrev tip-version)
 304       (number-to-string newrev))))
 305
 306 ;; Modelled after the similar function in vc-bzr.el
 307 (defun vc-hg-delete-file (file)
 308   "Delete FILE and delete it in the hg repository."
 309   (condition-case ()
 310       (delete-file file)
 311     (file-error nil))
 312   (vc-hg-command nil nil file "remove" "--after" "--force"))
 313
 314 ;; Modelled after the similar function in vc-bzr.el
 315 (defun vc-hg-rename-file (old new)
 316   "Rename file from OLD to NEW using `hg mv'."
 317   (vc-hg-command nil nil new old "mv"))
 318
 319 (defun vc-hg-register (file &optional rev comment)
 320   "Register FILE under hg.
 321 REV is ignored.
 322 COMMENT is ignored."
 323   (vc-hg-command nil nil file "add"))
 324
 325 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 326
 327 ;; Modelled after the similar function in vc-bzr.el
 328 (defun vc-hg-could-register (file)
 329   "Return non-nil if FILE could be registered under hg."
 330   (and (vc-hg-responsible-p file)      ; shortcut
 331        (condition-case ()
 332            (with-temp-buffer
 333              (vc-hg-command t nil file "add" "--dry-run"))
 334              ;; The command succeeds with no output if file is
 335              ;; registered.
 336          (error))))
 337
 338 ;; XXX This would remove the file. Is that correct?
 339 ;; (defun vc-hg-unregister (file)
 340 ;;   "Unregister FILE from hg."
 341 ;;   (vc-hg-command nil nil file "remove"))
 342
 343 (defun vc-hg-checkin (file rev comment)
 344   "HG-specific version of `vc-backend-checkin'.
 345 REV is ignored."
 346   (vc-hg-command nil nil file  "commit" "-m" comment))
 347
 348 (defun vc-hg-find-version (file rev buffer)
 349   (let ((coding-system-for-read 'binary)
 350         (coding-system-for-write 'binary))
 351     (if rev
 352         (vc-hg-command buffer nil file "cat" "-r" rev)
 353       (vc-hg-command buffer nil file "cat"))))
 354
 355 ;; Modelled after the similar function in vc-bzr.el
 356 ;; This should not be needed, `vc-hg-find-version' provides the same
 357 ;; functionality.
 358 ;; (defun vc-hg-checkout (file &optional editable rev workfile)
 359 ;;   "Retrieve a revision of FILE into a WORKFILE.
 360 ;; EDITABLE is ignored.
 361 ;; REV is the revision to check out into WORKFILE."
 362 ;;   (unless workfile
 363 ;;     (setq workfile (vc-version-backup-file-name file rev)))
 364 ;;   (let ((coding-system-for-read 'binary)
 365 ;;         (coding-system-for-write 'binary))
 366 ;;   (with-temp-file workfile
 367 ;;     (if rev
 368 ;;         (vc-hg-command t nil file "cat" "-r" rev)
 369 ;;       (vc-hg-command t nil file "cat")))))
 370
 371 (defun vc-hg-checkout-model (file)
 372   'implicit)
 373
 374 ;; Modelled after the similar function in vc-bzr.el
 375 (defun vc-hg-revert (file &optional contents-done)
 376   (unless contents-done
 377     (with-temp-buffer (vc-hg-command t nil file "revert"))))
 378
 379 ;;; Internal functions
 380
 381 (defun vc-hg-command (buffer okstatus file &rest flags)
 382   "A wrapper around `vc-do-command' for use in vc-hg.el.
 383 The difference to vc-do-command is that this function always invokes `hg',
 384 and that it passes `vc-hg-global-switches' to it before FLAGS."
 385   (apply 'vc-do-command buffer okstatus "hg" file
 386          (if (stringp vc-hg-global-switches)
 387              (cons vc-hg-global-switches flags)
 388            (append vc-hg-global-switches
 389                    flags))))
 390
 391 (defun vc-hg-root (file)
 392   (vc-find-root file ".hg"))
 393
 394 (provide 'vc-hg)
 395
 396 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 397 ;;; vc-hg.el ends here