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