lisp/vc-hg.el

   1 ;;; vc-hg.el --- VC backend for the mercurial version control system
   2
   3 ;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: Ivan Kanis
   6 ;; Keywords: tools
   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
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  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
  44 ;; - dir-state (dir)                           OK
  45 ;; * workfile-version (file)                   OK
  46 ;; - latest-on-branch-p (file)                 ??
  47 ;; * checkout-model (file)                     OK
  48 ;; - workfile-unchanged-p (file)               OK
  49 ;; - mode-line-string (file)                   NOT NEEDED
  50 ;; - dired-state-info (file)                   OK
  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
  60 ;; * checkout (file &optional editable rev)    OK
  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
  75 ;; - revision-completion-table (file)          COMMENTED OUT AS A WORKAROUND FOR A BUG
  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
 113   (require 'cl)
 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   (when (vc-hg-root file)           ; short cut
 141     (vc-file-setprop file 'vc-state (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         (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))))))))
 170
 171 (defun vc-hg-dir-state (dir)
 172   (with-temp-buffer
 173     (vc-hg-command (current-buffer) nil dir "status")
 174     (goto-char (point-min))
 175     (let ((status-char nil)
 176           (file nil))
 177       (while (not (eobp))
 178         (setq status-char (char-after))
 179         (setq file
 180               (expand-file-name
 181                (buffer-substring-no-properties (+ (point) 2)
 182                                                (line-end-position))))
 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)
 191           (vc-file-setprop file 'vc-backend 'Hg)
 192           (vc-file-setprop file 'vc-workfile-version "0")
 193           (vc-file-setprop file 'vc-state 'edited))
 194          ((eq status-char ?M)
 195           (vc-file-setprop file 'vc-backend 'Hg)
 196           (vc-file-setprop file 'vc-state 'edited))
 197          ((eq status-char ??)
 198           (vc-file-setprop file 'vc-backend 'none)
 199           (vc-file-setprop file 'vc-state 'nil)))
 200         (forward-line)))))
 201
 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
 250 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
 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
 259         '(
 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))
 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))
 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))
 281     (apply #'vc-hg-command (or buffer "*vc-diff*") nil
 282            (file-name-nondirectory file)
 283            "--cwd" (file-name-directory file)
 284            "diff"
 285            (append
 286             (if oldvers
 287                 (if newvers
 288                     (list "-r" oldvers "-r" newvers)
 289                   (list "-r" oldvers)))))))
 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
 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))
 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
 343            (vc-hg-command t 0 nil "tip")
 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))
 358   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 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'."
 363   (vc-hg-command nil 0 new old "mv"))
 364
 365 (defun vc-hg-register (file &optional rev comment)
 366   "Register FILE under hg.
 367 REV is ignored.
 368 COMMENT is ignored."
 369   (vc-hg-command nil 0 file "add"))
 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)
 390   "Hg-specific version of `vc-backend-checkin'.
 391 REV is ignored."
 392   (vc-hg-command nil 0 file  "commit" "-m" comment))
 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
 398         (vc-hg-command buffer 0 file "cat" "-r" rev)
 399       (vc-hg-command buffer 0 file "cat"))))
 400
 401 ;; Modelled after the similar function in vc-bzr.el
 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
 410         (vc-hg-command t 0 file "cat" "-r" rev)
 411       (vc-hg-command t 0 file "cat")))))
 412
 413 (defun vc-hg-checkout-model (file)
 414   'implicit)
 415
 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
 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
 427       (vc-default-dired-state-info 'Hg file))))
 428
 429 ;; Modelled after the similar function in vc-bzr.el
 430 (defun vc-hg-revert (file &optional contents-done)
 431   (unless contents-done
 432     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 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
 451 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 452 ;;; vc-hg.el ends here