code.delx.au - gnu-emacs/blob - 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               (list ""))))))
 291
 292 (defun vc-hg-revision-table (file)
 293   (let ((default-directory (file-name-directory file)))
 294     (with-temp-buffer
 295       (vc-hg-command t nil file "log" "--template" "{rev} ")
 296       (split-string
 297        (buffer-substring-no-properties (point-min) (point-max))))))
 298
 299 ;; Modelled after the similar function in vc-cvs.el
 300 (defun vc-hg-revision-completion-table (file)
 301   (lexical-let ((file file)
 302                 table)
 303     (setq table (lazy-completion-table
 304                  table (lambda () (vc-hg-revision-table file))))
 305     table))
 306
 307 (defalias 'vc-hg-diff-tree 'vc-hg-diff)
 308
 309 (defun vc-hg-annotate-command (file buffer &optional version)
 310   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 311 Optional arg VERSION is a version to annotate from."
 312   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 313   (with-current-buffer buffer
 314     (goto-char (point-min))
 315     (re-search-forward "^[0-9]")
 316     (delete-region (point-min) (1- (point)))))
 317
 318
 319 ;; The format for one line output by "hg annotate -d -n" looks like this:
 320 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 321 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 322 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 323
 324 (defun vc-hg-annotate-time ()
 325   (when (looking-at vc-hg-annotate-re)
 326     (goto-char (match-end 0))
 327     (vc-annotate-convert-time
 328      (date-to-time (match-string-no-properties 2)))))
 329
 330 (defun vc-hg-annotate-extract-revision-at-line ()
 331   (save-excursion
 332     (beginning-of-line)
 333     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 334
 335 (defun vc-hg-previous-version (file rev)
 336   (let ((newrev (1- (string-to-number rev))))
 337     (when (>= newrev 0)
 338       (number-to-string newrev))))
 339
 340 (defun vc-hg-next-version (file rev)
 341   (let ((newrev (1+ (string-to-number rev)))
 342         (tip-version
 343          (with-temp-buffer
 344            (vc-hg-command t 0 nil "tip")
 345            (goto-char (point-min))
 346            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 347            (string-to-number (match-string-no-properties 1)))))
 348     ;; We don't want to exceed the maximum possible version number, ie
 349     ;; the tip version.
 350     (when (<= newrev tip-version)
 351       (number-to-string newrev))))
 352
 353 ;; Modelled after the similar function in vc-bzr.el
 354 (defun vc-hg-delete-file (file)
 355   "Delete FILE and delete it in the hg repository."
 356   (condition-case ()
 357       (delete-file file)
 358     (file-error nil))
 359   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 360
 361 ;; Modelled after the similar function in vc-bzr.el
 362 (defun vc-hg-rename-file (old new)
 363   "Rename file from OLD to NEW using `hg mv'."
 364   (vc-hg-command nil 0 new old "mv"))
 365
 366 (defun vc-hg-register (file &optional rev comment)
 367   "Register FILE under hg.
 368 REV is ignored.
 369 COMMENT is ignored."
 370   (vc-hg-command nil 0 file "add"))
 371
 372 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 373
 374 ;; Modelled after the similar function in vc-bzr.el
 375 (defun vc-hg-could-register (file)
 376   "Return non-nil if FILE could be registered under hg."
 377   (and (vc-hg-responsible-p file)      ; shortcut
 378        (condition-case ()
 379            (with-temp-buffer
 380              (vc-hg-command t nil file "add" "--dry-run"))
 381              ;; The command succeeds with no output if file is
 382              ;; registered.
 383          (error))))
 384
 385 ;; XXX This would remove the file. Is that correct?
 386 ;; (defun vc-hg-unregister (file)
 387 ;;   "Unregister FILE from hg."
 388 ;;   (vc-hg-command nil nil file "remove"))
 389
 390 (defun vc-hg-checkin (file rev comment)
 391   "Hg-specific version of `vc-backend-checkin'.
 392 REV is ignored."
 393   (vc-hg-command nil 0 file  "commit" "-m" comment))
 394
 395 (defun vc-hg-find-version (file rev buffer)
 396   (let ((coding-system-for-read 'binary)
 397         (coding-system-for-write 'binary))
 398     (if rev
 399         (vc-hg-command buffer 0 file "cat" "-r" rev)
 400       (vc-hg-command buffer 0 file "cat"))))
 401
 402 ;; Modelled after the similar function in vc-bzr.el
 403 (defun vc-hg-checkout (file &optional editable rev)
 404   "Retrieve a revision of FILE.
 405 EDITABLE is ignored.
 406 REV is the revision to check out into WORKFILE."
 407   (let ((coding-system-for-read 'binary)
 408         (coding-system-for-write 'binary))
 409   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 410     (if rev
 411         (vc-hg-command t 0 file "cat" "-r" rev)
 412       (vc-hg-command t 0 file "cat")))))
 413
 414 (defun vc-hg-checkout-model (file)
 415   'implicit)
 416
 417 ;; Modelled after the similar function in vc-bzr.el
 418 (defun vc-hg-workfile-unchanged-p (file)
 419   (eq 'up-to-date (vc-hg-state file)))
 420
 421 (defun vc-hg-dired-state-info (file)
 422   "Hg-specific version of `vc-dired-state-info'."
 423   (let ((hg-state (vc-state file)))
 424     (if (eq hg-state 'edited)
 425         (if (equal (vc-workfile-version file) "0")
 426             "(added)" "(modified)")
 427       ;; fall back to the default VC representation
 428       (vc-default-dired-state-info 'Hg file))))
 429
 430 ;; Modelled after the similar function in vc-bzr.el
 431 (defun vc-hg-revert (file &optional contents-done)
 432   (unless contents-done
 433     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 434
 435 ;;; Internal functions
 436
 437 (defun vc-hg-command (buffer okstatus file &rest flags)
 438   "A wrapper around `vc-do-command' for use in vc-hg.el.
 439 The difference to vc-do-command is that this function always invokes `hg',
 440 and that it passes `vc-hg-global-switches' to it before FLAGS."
 441   (apply 'vc-do-command buffer okstatus "hg" file
 442          (if (stringp vc-hg-global-switches)
 443              (cons vc-hg-global-switches flags)
 444            (append vc-hg-global-switches
 445                    flags))))
 446
 447 (defun vc-hg-root (file)
 448   (vc-find-root file ".hg"))
 449
 450 (provide 'vc-hg)
 451
 452 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 453 ;;; vc-hg.el ends here