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 ;; BACKEND PROPERTIES
  42 ;; * revision-granularity                      OK
  43 ;; STATE-QUERYING FUNCTIONS
  44 ;; * registered (file)                         OK
  45 ;; * state (file)                              OK
  46 ;; - state-heuristic (file)                    ?? PROBABLY NOT NEEDED
  47 ;; - dir-state (dir)                           OK
  48 ;; * working-revision (file)                   OK
  49 ;; - latest-on-branch-p (file)                 ??
  50 ;; * checkout-model (file)                     OK
  51 ;; - workfile-unchanged-p (file)               OK
  52 ;; - mode-line-string (file)                   NOT NEEDED
  53 ;; - dired-state-info (file)                   OK
  54 ;; STATE-CHANGING FUNCTIONS
  55 ;; * register (files &optional rev comment)    OK
  56 ;; * create-repo ()                            OK
  57 ;; - init-revision ()                           NOT NEEDED
  58 ;; - responsible-p (file)                      OK
  59 ;; - could-register (file)                     OK
  60 ;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
  61 ;; - unregister (file)                         COMMENTED OUT, MAY BE INCORRECT
  62 ;; * checkin (files rev comment)               OK
  63 ;; * find-revision (file rev buffer)            OK
  64 ;; * checkout (file &optional editable rev)    OK
  65 ;; * revert (file &optional contents-done)     OK
  66 ;; - rollback (files)                          ?? PROBABLY NOT NEEDED
  67 ;; - merge (file rev1 rev2)                    NEEDED
  68 ;; - merge-news (file)                         NEEDED
  69 ;; - steal-lock (file &optional revision)       NOT NEEDED
  70 ;; HISTORY FUNCTIONS
  71 ;; * print-log (files &optional buffer)        OK
  72 ;; - log-view-mode ()                          OK
  73 ;; - show-log-entry (revision)                  NOT NEEDED, DEFAULT IS GOOD
  74 ;; - wash-log (file)                           ??
  75 ;; - logentry-check ()                         NOT NEEDED
  76 ;; - comment-history (file)                    NOT NEEDED
  77 ;; - update-changelog (files)                  NOT NEEDED
  78 ;; * diff (files &optional rev1 rev2 buffer)   OK
  79 ;; - revision-completion-table (files)         OK?
  80 ;; - annotate-command (file buf &optional rev) OK
  81 ;; - annotate-time ()                          OK
  82 ;; - annotate-current-time ()                  ?? NOT NEEDED
  83 ;; - annotate-extract-revision-at-line ()      OK
  84 ;; SNAPSHOT SYSTEM
  85 ;; - create-snapshot (dir name branchp)        NEEDED (probably branch?)
  86 ;; - assign-name (file name)                   NOT NEEDED
  87 ;; - retrieve-snapshot (dir name update)       ?? NEEDED??
  88 ;; MISCELLANEOUS
  89 ;; - make-version-backups-p (file)             ??
  90 ;; - repository-hostname (dirname)             ??
  91 ;; - previous-revision (file rev)               OK
  92 ;; - next-revision (file rev)                   OK
  93 ;; - check-headers ()                          ??
  94 ;; - clear-headers ()                          ??
  95 ;; - delete-file (file)                        TEST IT
  96 ;; - rename-file (old new)                     OK
  97 ;; - find-file-hook ()                         PROBABLY NOT NEEDED
  98 ;; - find-file-not-found-hook ()               PROBABLY NOT NEEDED
  99
 100 ;; Implement Stefan Monnier's advice:
 101 ;; vc-hg-registered and vc-hg-state
 102 ;; Both of those functions should be super extra careful to fail gracefully in
 103 ;; unexpected circumstances. The reason this is important is that any error
 104 ;; there will prevent the user from even looking at the file :-(
 105 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
 106 ;; mercurial's control and extracting the current revision should be done
 107 ;; without even using `hg' (this way even if you don't have `hg' installed,
 108 ;; Emacs is able to tell you this file is under mercurial's control).
 109
 110 ;;; History:
 111 ;;
 112
 113 ;;; Code:
 114
 115 (eval-when-compile
 116   (require 'cl)
 117   (require 'vc))
 118
 119 ;;; Customization options
 120
 121 (defcustom vc-hg-global-switches nil
 122   "*Global switches to pass to any Hg command."
 123   :type '(choice (const :tag "None" nil)
 124          (string :tag "Argument String")
 125          (repeat :tag "Argument List"
 126              :value ("")
 127              string))
 128   :version "22.2"
 129   :group 'vc)
 130
 131 \f
 132 ;;; Properties of the backend
 133
 134 (defun vc-hg-revision-granularity ()
 135      'repository)
 136
 137 ;;; State querying functions
 138
 139 ;;;###autoload (defun vc-hg-registered (file)
 140 ;;;###autoload   "Return non-nil if FILE is registered with hg."
 141 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
 142 ;;;###autoload       (progn
 143 ;;;###autoload         (load "vc-hg")
 144 ;;;###autoload         (vc-hg-registered file))))
 145
 146 ;; Modelled after the similar function in vc-bzr.el
 147 (defun vc-hg-registered (file)
 148   "Return non-nil if FILE is registered with hg."
 149   (when (vc-hg-root file)           ; short cut
 150     (vc-file-setprop file 'vc-state (vc-hg-state file)))) ; expensive
 151
 152 (defun vc-hg-state (file)
 153   "Hg-specific version of `vc-state'."
 154   (let*
 155       ((status nil)
 156        (out
 157         (with-output-to-string
 158           (with-current-buffer
 159               standard-output
 160             (setq status
 161                   (condition-case nil
 162                       ;; Ignore all errors.
 163                       (call-process
 164                        "hg" nil t nil "--cwd" (file-name-directory file)
 165                        "status" (file-name-nondirectory file))
 166                     ;; Some problem happened.  E.g. We can't find an `hg'
 167                     ;; executable.
 168                     (error nil)))))))
 169     (when (eq 0 status)
 170       (if (eq 0 (length out)) 'up-to-date
 171         (when (null (string-match ".*: No such file or directory$" out))
 172           (let ((state (aref out 0)))
 173             (cond
 174              ((eq state ?A) 'edited)
 175              ((eq state ?M) 'edited)
 176              ((eq state ?R) nil)
 177              ((eq state ??) nil)
 178              (t 'up-to-date))))))))
 179
 180 (defun vc-hg-dir-state (dir)
 181   (with-temp-buffer
 182     (vc-hg-command (current-buffer) nil nil "status")
 183     (goto-char (point-min))
 184     (let ((status-char nil)
 185           (file nil))
 186       (while (not (eobp))
 187         (setq status-char (char-after))
 188         (setq file
 189               (expand-file-name
 190                (buffer-substring-no-properties (+ (point) 2)
 191                                                (line-end-position))))
 192         (cond
 193          ;; The rest of the possible states in "hg status" output:
 194          ;;      R = removed
 195          ;;      ! = deleted, but still tracked
 196          ;;      ? = not tracked
 197          ;; should not show up in vc-dired, so don't deal with them
 198          ;; here.
 199          ((eq status-char ?A)
 200           (vc-file-setprop file 'vc-working-revision "0")
 201           (vc-file-setprop file 'vc-state 'edited))
 202          ((eq status-char ?M)
 203           (vc-file-setprop file 'vc-state 'edited))
 204          ((eq status-char ??)
 205           (vc-file-setprop file 'vc-backend 'none)
 206           (vc-file-setprop file 'vc-state 'nil)))
 207         (forward-line)))))
 208
 209 (defun vc-hg-working-revision (file)
 210   "Hg-specific version of `vc-working-revision'."
 211   (let*
 212       ((status nil)
 213        (out
 214         (with-output-to-string
 215           (with-current-buffer
 216               standard-output
 217             (setq status
 218                   (condition-case nil
 219                       ;; Ignore all errors.
 220                       (call-process
 221                        "hg" nil t nil "--cwd" (file-name-directory file)
 222                        "log" "-l1" (file-name-nondirectory file))
 223                     ;; Some problem happened.  E.g. We can't find an `hg'
 224                     ;; executable.
 225                     (error nil)))))))
 226     (when (eq 0 status)
 227       (if (string-match "changeset: *\\([0-9]*\\)" out)
 228           (match-string 1 out)
 229         "0"))))
 230
 231 ;;; History functions
 232
 233 (defun vc-hg-print-log(files &optional buffer)
 234   "Get change log associated with FILES."
 235   ;; `log-view-mode' needs to have the file name in order to function
 236   ;; correctly. "hg log" does not print it, so we insert it here by
 237   ;; hand.
 238
 239   ;; `vc-do-command' creates the buffer, but we need it before running
 240   ;; the command.
 241   (vc-setup-buffer buffer)
 242   ;; If the buffer exists from a previous invocation it might be
 243   ;; read-only.
 244   (let ((inhibit-read-only t))
 245     ;; We need to loop and call "hg log" on each file separately.
 246     ;; "hg log" with multiple file arguments mashes all the logs
 247     ;; together.
 248     (dolist (file files)
 249       (with-current-buffer
 250           buffer
 251         (insert "File:        " (file-name-nondirectory file) "\n"))
 252       (vc-hg-command buffer 0 file "log"))))
 253
 254 (defvar log-view-message-re)
 255 (defvar log-view-file-re)
 256 (defvar log-view-font-lock-keywords)
 257
 258 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
 259   (require 'add-log) ;; we need the add-log faces
 260   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 261   (set (make-local-variable 'log-view-message-re)
 262        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 263   (set (make-local-variable 'log-view-font-lock-keywords)
 264        (append
 265         log-view-font-lock-keywords
 266         ;; Handle the case:
 267         ;; user: foo@bar
 268         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 269            (1 'change-log-email))
 270           ;; Handle the case:
 271           ;; user: FirstName LastName <foo@bar>
 272           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 273            (1 'change-log-name)
 274            (2 'change-log-email))
 275           ("^date: \\(.+\\)" (1 'change-log-date))
 276           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 277
 278 (defun vc-hg-diff (files &optional oldvers newvers buffer)
 279   "Get a difference report using hg between two revisions of FILES."
 280   (let ((working (vc-working-revision (car files))))
 281     (if (and (equal oldvers working) (not newvers))
 282         (setq oldvers nil))
 283     (if (and (not oldvers) newvers)
 284         (setq oldvers working))
 285     (apply #'vc-hg-command (or buffer "*vc-diff*") nil
 286            (mapcar (lambda (file) (file-name-nondirectory file)) files)
 287            "--cwd" (file-name-directory (car files))
 288            "diff"
 289            (append
 290             (if oldvers
 291                 (if newvers
 292                     (list "-r" oldvers "-r" newvers)
 293                   (list "-r" oldvers))
 294               (list ""))))))
 295
 296 (defun vc-hg-revision-table (files)
 297   (let ((default-directory (file-name-directory (car files))))
 298     (with-temp-buffer
 299       (vc-hg-command t nil file "log" "--template" "{rev} ")
 300       (split-string
 301        (buffer-substring-no-properties (point-min) (point-max))))))
 302
 303 ;; Modelled after the similar function in vc-cvs.el
 304 (defun vc-hg-revision-completion-table (files)
 305   (lexical-let ((files files)
 306                 table)
 307     (setq table (lazy-completion-table
 308                  table (lambda () (vc-hg-revision-table files))))
 309     table))
 310
 311 (defun vc-hg-annotate-command (file buffer &optional revision)
 312   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 313 Optional arg REVISION is a revision to annotate from."
 314   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if revision (concat "-r" revision)))
 315   (with-current-buffer buffer
 316     (goto-char (point-min))
 317     (re-search-forward "^[0-9]")
 318     (delete-region (point-min) (1- (point)))))
 319
 320
 321 ;; The format for one line output by "hg annotate -d -n" looks like this:
 322 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 323 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 324 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 325
 326 (defun vc-hg-annotate-time ()
 327   (when (looking-at vc-hg-annotate-re)
 328     (goto-char (match-end 0))
 329     (vc-annotate-convert-time
 330      (date-to-time (match-string-no-properties 2)))))
 331
 332 (defun vc-hg-annotate-extract-revision-at-line ()
 333   (save-excursion
 334     (beginning-of-line)
 335     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 336
 337 (defun vc-hg-previous-revision (file rev)
 338   (let ((newrev (1- (string-to-number rev))))
 339     (when (>= newrev 0)
 340       (number-to-string newrev))))
 341
 342 (defun vc-hg-next-revision (file rev)
 343   (let ((newrev (1+ (string-to-number rev)))
 344         (tip-revision
 345          (with-temp-buffer
 346            (vc-hg-command t 0 nil "tip")
 347            (goto-char (point-min))
 348            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 349            (string-to-number (match-string-no-properties 1)))))
 350     ;; We don't want to exceed the maximum possible revision number, ie
 351     ;; the tip revision.
 352     (when (<= newrev tip-revision)
 353       (number-to-string newrev))))
 354
 355 ;; Modelled after the similar function in vc-bzr.el
 356 (defun vc-hg-delete-file (file)
 357   "Delete FILE and delete it in the hg repository."
 358   (condition-case ()
 359       (delete-file file)
 360     (file-error nil))
 361   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 362
 363 ;; Modelled after the similar function in vc-bzr.el
 364 (defun vc-hg-rename-file (old new)
 365   "Rename file from OLD to NEW using `hg mv'."
 366   (vc-hg-command nil 0 new old "mv"))
 367
 368 (defun vc-hg-register (files &optional rev comment)
 369   "Register FILES under hg.
 370 REV is ignored.
 371 COMMENT is ignored."
 372   (vc-hg-command nil 0 files "add"))
 373
 374 (defun vc-hg-create-repo ()
 375   "Create a new Mercurial repository."
 376   (vc-hg-command nil 0 nil "init"))
 377
 378 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 379
 380 ;; Modelled after the similar function in vc-bzr.el
 381 (defun vc-hg-could-register (file)
 382   "Return non-nil if FILE could be registered under hg."
 383   (and (vc-hg-responsible-p file)      ; shortcut
 384        (condition-case ()
 385            (with-temp-buffer
 386              (vc-hg-command t nil file "add" "--dry-run"))
 387              ;; The command succeeds with no output if file is
 388              ;; registered.
 389          (error))))
 390
 391 ;; XXX This would remove the file. Is that correct?
 392 ;; (defun vc-hg-unregister (file)
 393 ;;   "Unregister FILE from hg."
 394 ;;   (vc-hg-command nil nil file "remove"))
 395
 396 (defun vc-hg-checkin (files rev comment)
 397   "Hg-specific version of `vc-backend-checkin'.
 398 REV is ignored."
 399   (vc-hg-command nil 0 files  "commit" "-m" comment))
 400
 401 (defun vc-hg-find-revision (file rev buffer)
 402   (let ((coding-system-for-read 'binary)
 403         (coding-system-for-write 'binary))
 404     (if rev
 405         (vc-hg-command buffer 0 file "cat" "-r" rev)
 406       (vc-hg-command buffer 0 file "cat"))))
 407
 408 ;; Modelled after the similar function in vc-bzr.el
 409 (defun vc-hg-checkout (file &optional editable rev)
 410   "Retrieve a revision of FILE.
 411 EDITABLE is ignored.
 412 REV is the revision to check out into WORKFILE."
 413   (let ((coding-system-for-read 'binary)
 414         (coding-system-for-write 'binary))
 415   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 416     (if rev
 417         (vc-hg-command t 0 file "cat" "-r" rev)
 418       (vc-hg-command t 0 file "cat")))))
 419
 420 (defun vc-hg-checkout-model (file)
 421   'implicit)
 422
 423 ;; Modelled after the similar function in vc-bzr.el
 424 (defun vc-hg-workfile-unchanged-p (file)
 425   (eq 'up-to-date (vc-hg-state file)))
 426
 427 (defun vc-hg-dired-state-info (file)
 428   "Hg-specific version of `vc-dired-state-info'."
 429   (let ((hg-state (vc-state file)))
 430     (if (eq hg-state 'edited)
 431         (if (equal (vc-working-revision file) "0")
 432             "(added)" "(modified)")
 433       ;; fall back to the default VC representation
 434       (vc-default-dired-state-info 'Hg file))))
 435
 436 ;; Modelled after the similar function in vc-bzr.el
 437 (defun vc-hg-revert (file &optional contents-done)
 438   (unless contents-done
 439     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 440
 441 ;;; Hg specific functionality.
 442
 443 ;;; XXX This functionality is experimental/work in progress. It might
 444 ;;; change without notice.
 445 (defvar vc-hg-extra-menu-map
 446   (let ((map (make-sparse-keymap)))
 447     (define-key map [incoming] '(menu-item "Show incoming" vc-hg-incoming))
 448     (define-key map [outgoing] '(menu-item "Show outgoing" vc-hg-outgoing))
 449     map))
 450
 451 (defun vc-hg-extra-menu () vc-hg-extra-menu-map)
 452
 453 (define-derived-mode vc-hg-outgoing-mode vc-hg-log-view-mode "Hg-Outgoing")
 454
 455 (define-derived-mode vc-hg-incoming-mode vc-hg-log-view-mode "Hg-Incoming")
 456
 457 ;; XXX this adds another top level menu, instead figure out how to
 458 ;; replace the Log-View menu.
 459 (easy-menu-define log-view-mode-menu vc-hg-outgoing-mode-map
 460   "Hg-outgoing Display Menu"
 461   `("Hg-outgoing"
 462     ["Push selected"  vc-hg-push]))
 463
 464 (easy-menu-define log-view-mode-menu vc-hg-incoming-mode-map
 465   "Hg-incoming Display Menu"
 466   `("Hg-incoming"
 467     ["Pull selected"  vc-hg-pull]))
 468
 469 (defun vc-hg-outgoing ()
 470   (interactive)
 471   (let ((bname "*Hg outgoing*"))
 472     (vc-hg-command bname 0 nil "outgoing" "-n")
 473     (pop-to-buffer bname)
 474     (vc-hg-outgoing-mode)))
 475
 476 (defun vc-hg-incoming ()
 477   (interactive)
 478   (let ((bname "*Hg incoming*"))
 479     (vc-hg-command bname 0 nil "incoming" "-n")
 480     (pop-to-buffer bname)
 481     (vc-hg-incoming-mode)))
 482
 483 ;; XXX maybe also add key bindings for these functions.
 484 (defun vc-hg-push ()
 485   (interactive)
 486   (let ((marked-list (log-view-get-marked)))
 487     (if marked-list
 488         (vc-hg-command
 489          nil 0 nil
 490          (cons "push"
 491                (apply 'nconc
 492                       (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
 493          (error "No log entries selected for push"))))
 494
 495 (defun vc-hg-pull ()
 496   (interactive)
 497   (let ((marked-list (log-view-get-marked)))
 498     (if marked-list
 499         (vc-hg-command
 500          nil 0 nil
 501          (cons "pull"
 502                (apply 'nconc
 503                       (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
 504       (error "No log entries selected for pull"))))
 505
 506 ;;; Internal functions
 507
 508 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
 509   "A wrapper around `vc-do-command' for use in vc-hg.el.
 510 The difference to vc-do-command is that this function always invokes `hg',
 511 and that it passes `vc-hg-global-switches' to it before FLAGS."
 512   (apply 'vc-do-command buffer okstatus "hg" file-or-list
 513          (if (stringp vc-hg-global-switches)
 514              (cons vc-hg-global-switches flags)
 515            (append vc-hg-global-switches
 516                    flags))))
 517
 518 (defun vc-hg-root (file)
 519   (vc-find-root file ".hg"))
 520
 521 (provide 'vc-hg)
 522
 523 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 524 ;;; vc-hg.el ends here