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
   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 nil "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-workfile-version "0")
 192           (vc-file-setprop file 'vc-state 'edited))
 193          ((eq status-char ?M)
 194           (vc-file-setprop file 'vc-state 'edited))
 195          ((eq status-char ??)
 196           (vc-file-setprop file 'vc-backend 'none)
 197           (vc-file-setprop file 'vc-state 'nil)))
 198         (forward-line)))))
 199
 200 (defun vc-hg-workfile-version (file)
 201   "Hg-specific version of `vc-workfile-version'."
 202   (let*
 203       ((status nil)
 204        (out
 205         (with-output-to-string
 206           (with-current-buffer
 207               standard-output
 208             (setq status
 209                   (condition-case nil
 210                       ;; Ignore all errors.
 211                       (call-process
 212                        "hg" nil t nil "--cwd" (file-name-directory file)
 213                        "log" "-l1" (file-name-nondirectory file))
 214                     ;; Some problem happened.  E.g. We can't find an `hg'
 215                     ;; executable.
 216                     (error nil)))))))
 217     (when (eq 0 status)
 218       (if (string-match "changeset: *\\([0-9]*\\)" out)
 219           (match-string 1 out)
 220         "0"))))
 221
 222 ;;; History functions
 223
 224 (defun vc-hg-print-log(file &optional buffer)
 225   "Get change log associated with FILE."
 226   ;; `log-view-mode' needs to have the file name in order to function
 227   ;; correctly. "hg log" does not print it, so we insert it here by
 228   ;; hand.
 229
 230   ;; `vc-do-command' creates the buffer, but we need it before running
 231   ;; the command.
 232   (vc-setup-buffer buffer)
 233   ;; If the buffer exists from a previous invocation it might be
 234   ;; read-only.
 235   (let ((inhibit-read-only t))
 236     (with-current-buffer
 237         buffer
 238       (insert "File:        " (file-name-nondirectory file) "\n")))
 239   (vc-hg-command
 240    buffer
 241    (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
 242    file "log"))
 243
 244 (defvar log-view-message-re)
 245 (defvar log-view-file-re)
 246 (defvar log-view-font-lock-keywords)
 247
 248 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
 249   (require 'add-log) ;; we need the faces add-log
 250   ;; Don't have file markers, so use impossible regexp.
 251   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 252   (set (make-local-variable 'log-view-message-re)
 253        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 254   (set (make-local-variable 'log-view-font-lock-keywords)
 255        (append
 256         log-view-font-lock-keywords
 257         ;; Handle the case:
 258         ;; user: foo@bar
 259         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 260            (1 'change-log-email))
 261           ;; Handle the case:
 262           ;; user: FirstName LastName <foo@bar>
 263           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 264            (1 'change-log-name)
 265            (2 'change-log-email))
 266           ("^date: \\(.+\\)" (1 'change-log-date))
 267           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 268
 269 (defun vc-hg-diff (file &optional oldvers newvers buffer)
 270   "Get a difference report using hg between two versions of FILE."
 271   (let ((working (vc-workfile-version file)))
 272     (if (and (equal oldvers working) (not newvers))
 273         (setq oldvers nil))
 274     (if (and (not oldvers) newvers)
 275         (setq oldvers working))
 276     (apply #'vc-hg-command (or buffer "*vc-diff*") nil
 277            (file-name-nondirectory file)
 278            "--cwd" (file-name-directory file)
 279            "diff"
 280            (append
 281             (if oldvers
 282                 (if newvers
 283                     (list "-r" oldvers "-r" newvers)
 284                   (list "-r" oldvers))
 285               (list ""))))))
 286
 287 (defun vc-hg-revision-table (file)
 288   (let ((default-directory (file-name-directory file)))
 289     (with-temp-buffer
 290       (vc-hg-command t nil file "log" "--template" "{rev} ")
 291       (split-string
 292        (buffer-substring-no-properties (point-min) (point-max))))))
 293
 294 ;; Modelled after the similar function in vc-cvs.el
 295 (defun vc-hg-revision-completion-table (file)
 296   (lexical-let ((file file)
 297                 table)
 298     (setq table (lazy-completion-table
 299                  table (lambda () (vc-hg-revision-table file))))
 300     table))
 301
 302 (defalias 'vc-hg-diff-tree 'vc-hg-diff)
 303
 304 (defun vc-hg-annotate-command (file buffer &optional version)
 305   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 306 Optional arg VERSION is a version to annotate from."
 307   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 308   (with-current-buffer buffer
 309     (goto-char (point-min))
 310     (re-search-forward "^[0-9]")
 311     (delete-region (point-min) (1- (point)))))
 312
 313
 314 ;; The format for one line output by "hg annotate -d -n" looks like this:
 315 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 316 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 317 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 318
 319 (defun vc-hg-annotate-time ()
 320   (when (looking-at vc-hg-annotate-re)
 321     (goto-char (match-end 0))
 322     (vc-annotate-convert-time
 323      (date-to-time (match-string-no-properties 2)))))
 324
 325 (defun vc-hg-annotate-extract-revision-at-line ()
 326   (save-excursion
 327     (beginning-of-line)
 328     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 329
 330 (defun vc-hg-previous-version (file rev)
 331   (let ((newrev (1- (string-to-number rev))))
 332     (when (>= newrev 0)
 333       (number-to-string newrev))))
 334
 335 (defun vc-hg-next-version (file rev)
 336   (let ((newrev (1+ (string-to-number rev)))
 337         (tip-version
 338          (with-temp-buffer
 339            (vc-hg-command t 0 nil "tip")
 340            (goto-char (point-min))
 341            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 342            (string-to-number (match-string-no-properties 1)))))
 343     ;; We don't want to exceed the maximum possible version number, ie
 344     ;; the tip version.
 345     (when (<= newrev tip-version)
 346       (number-to-string newrev))))
 347
 348 ;; Modelled after the similar function in vc-bzr.el
 349 (defun vc-hg-delete-file (file)
 350   "Delete FILE and delete it in the hg repository."
 351   (condition-case ()
 352       (delete-file file)
 353     (file-error nil))
 354   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 355
 356 ;; Modelled after the similar function in vc-bzr.el
 357 (defun vc-hg-rename-file (old new)
 358   "Rename file from OLD to NEW using `hg mv'."
 359   (vc-hg-command nil 0 new old "mv"))
 360
 361 (defun vc-hg-register (file &optional rev comment)
 362   "Register FILE under hg.
 363 REV is ignored.
 364 COMMENT is ignored."
 365   (vc-hg-command nil 0 file "add"))
 366
 367 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 368
 369 ;; Modelled after the similar function in vc-bzr.el
 370 (defun vc-hg-could-register (file)
 371   "Return non-nil if FILE could be registered under hg."
 372   (and (vc-hg-responsible-p file)      ; shortcut
 373        (condition-case ()
 374            (with-temp-buffer
 375              (vc-hg-command t nil file "add" "--dry-run"))
 376              ;; The command succeeds with no output if file is
 377              ;; registered.
 378          (error))))
 379
 380 ;; XXX This would remove the file. Is that correct?
 381 ;; (defun vc-hg-unregister (file)
 382 ;;   "Unregister FILE from hg."
 383 ;;   (vc-hg-command nil nil file "remove"))
 384
 385 (defun vc-hg-checkin (file rev comment)
 386   "Hg-specific version of `vc-backend-checkin'.
 387 REV is ignored."
 388   (vc-hg-command nil 0 file  "commit" "-m" comment))
 389
 390 (defun vc-hg-find-version (file rev buffer)
 391   (let ((coding-system-for-read 'binary)
 392         (coding-system-for-write 'binary))
 393     (if rev
 394         (vc-hg-command buffer 0 file "cat" "-r" rev)
 395       (vc-hg-command buffer 0 file "cat"))))
 396
 397 ;; Modelled after the similar function in vc-bzr.el
 398 (defun vc-hg-checkout (file &optional editable rev)
 399   "Retrieve a revision of FILE.
 400 EDITABLE is ignored.
 401 REV is the revision to check out into WORKFILE."
 402   (let ((coding-system-for-read 'binary)
 403         (coding-system-for-write 'binary))
 404   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 405     (if rev
 406         (vc-hg-command t 0 file "cat" "-r" rev)
 407       (vc-hg-command t 0 file "cat")))))
 408
 409 (defun vc-hg-checkout-model (file)
 410   'implicit)
 411
 412 ;; Modelled after the similar function in vc-bzr.el
 413 (defun vc-hg-workfile-unchanged-p (file)
 414   (eq 'up-to-date (vc-hg-state file)))
 415
 416 (defun vc-hg-dired-state-info (file)
 417   "Hg-specific version of `vc-dired-state-info'."
 418   (let ((hg-state (vc-state file)))
 419     (if (eq hg-state 'edited)
 420         (if (equal (vc-workfile-version file) "0")
 421             "(added)" "(modified)")
 422       ;; fall back to the default VC representation
 423       (vc-default-dired-state-info 'Hg file))))
 424
 425 ;; Modelled after the similar function in vc-bzr.el
 426 (defun vc-hg-revert (file &optional contents-done)
 427   (unless contents-done
 428     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 429
 430 ;;; Internal functions
 431
 432 (defun vc-hg-command (buffer okstatus file &rest flags)
 433   "A wrapper around `vc-do-command' for use in vc-hg.el.
 434 The difference to vc-do-command is that this function always invokes `hg',
 435 and that it passes `vc-hg-global-switches' to it before FLAGS."
 436   (apply 'vc-do-command buffer okstatus "hg" file
 437          (if (stringp vc-hg-global-switches)
 438              (cons vc-hg-global-switches flags)
 439            (append vc-hg-global-switches
 440                    flags))))
 441
 442 (defun vc-hg-root (file)
 443   (vc-find-root file ".hg"))
 444
 445 (provide 'vc-hg)
 446
 447 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 448 ;;; vc-hg.el ends here