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 2, 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 ;; * workfile-version (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-version ()                           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-version (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 version)       NOT NEEDED
  70 ;; HISTORY FUNCTIONS
  71 ;; * print-log (files &optional buffer)        OK
  72 ;; - log-view-mode ()                          OK
  73 ;; - show-log-entry (version)                  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)          OK
  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-version (file rev)               OK
  93 ;; - next-version (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-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-workfile-version "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-workfile-version (file)
 211   "Hg-specific version of `vc-workfile-version'."
 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 faces add-log
 261   ;; Don't have file markers, so use impossible regexp.
 262   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 263   (set (make-local-variable 'log-view-message-re)
 264        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 265   (set (make-local-variable 'log-view-font-lock-keywords)
 266        (append
 267         log-view-font-lock-keywords
 268         ;; Handle the case:
 269         ;; user: foo@bar
 270         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 271            (1 'change-log-email))
 272           ;; Handle the case:
 273           ;; user: FirstName LastName <foo@bar>
 274           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 275            (1 'change-log-name)
 276            (2 'change-log-email))
 277           ("^date: \\(.+\\)" (1 'change-log-date))
 278           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 279
 280 (defun vc-hg-diff (files &optional oldvers newvers buffer)
 281   "Get a difference report using hg between two versions of FILES."
 282   (let ((working (vc-workfile-version (car files))))
 283     (if (and (equal oldvers working) (not newvers))
 284         (setq oldvers nil))
 285     (if (and (not oldvers) newvers)
 286         (setq oldvers working))
 287     (apply #'vc-hg-command (or buffer "*vc-diff*") nil
 288            (mapcar (lambda (file) (file-name-nondirectory file)) files)
 289            "--cwd" (file-name-directory (car files))
 290            "diff"
 291            (append
 292             (if oldvers
 293                 (if newvers
 294                     (list "-r" oldvers "-r" newvers)
 295                   (list "-r" oldvers))
 296               (list ""))))))
 297
 298 (defun vc-hg-revision-table (file)
 299   (let ((default-directory (file-name-directory file)))
 300     (with-temp-buffer
 301       (vc-hg-command t nil file "log" "--template" "{rev} ")
 302       (split-string
 303        (buffer-substring-no-properties (point-min) (point-max))))))
 304
 305 ;; Modelled after the similar function in vc-cvs.el
 306 (defun vc-hg-revision-completion-table (file)
 307   (lexical-let ((file file)
 308                 table)
 309     (setq table (lazy-completion-table
 310                  table (lambda () (vc-hg-revision-table file))))
 311     table))
 312
 313 (defun vc-hg-diff-tree (file &optional oldvers newvers buffer)
 314   (vc-hg-diff (list file) oldvers newvers buffer))
 315
 316 (defun vc-hg-annotate-command (file buffer &optional version)
 317   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 318 Optional arg VERSION is a version to annotate from."
 319   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 320   (with-current-buffer buffer
 321     (goto-char (point-min))
 322     (re-search-forward "^[0-9]")
 323     (delete-region (point-min) (1- (point)))))
 324
 325
 326 ;; The format for one line output by "hg annotate -d -n" looks like this:
 327 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 328 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 329 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 330
 331 (defun vc-hg-annotate-time ()
 332   (when (looking-at vc-hg-annotate-re)
 333     (goto-char (match-end 0))
 334     (vc-annotate-convert-time
 335      (date-to-time (match-string-no-properties 2)))))
 336
 337 (defun vc-hg-annotate-extract-revision-at-line ()
 338   (save-excursion
 339     (beginning-of-line)
 340     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 341
 342 (defun vc-hg-previous-version (file rev)
 343   (let ((newrev (1- (string-to-number rev))))
 344     (when (>= newrev 0)
 345       (number-to-string newrev))))
 346
 347 (defun vc-hg-next-version (file rev)
 348   (let ((newrev (1+ (string-to-number rev)))
 349         (tip-version
 350          (with-temp-buffer
 351            (vc-hg-command t 0 nil "tip")
 352            (goto-char (point-min))
 353            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 354            (string-to-number (match-string-no-properties 1)))))
 355     ;; We don't want to exceed the maximum possible version number, ie
 356     ;; the tip version.
 357     (when (<= newrev tip-version)
 358       (number-to-string newrev))))
 359
 360 ;; Modelled after the similar function in vc-bzr.el
 361 (defun vc-hg-delete-file (file)
 362   "Delete FILE and delete it in the hg repository."
 363   (condition-case ()
 364       (delete-file file)
 365     (file-error nil))
 366   (vc-hg-command nil 0 file "remove" "--after" "--force"))
 367
 368 ;; Modelled after the similar function in vc-bzr.el
 369 (defun vc-hg-rename-file (old new)
 370   "Rename file from OLD to NEW using `hg mv'."
 371   (vc-hg-command nil 0 new old "mv"))
 372
 373 (defun vc-hg-register (files &optional rev comment)
 374   "Register FILES under hg.
 375 REV is ignored.
 376 COMMENT is ignored."
 377   (vc-hg-command nil 0 files "add"))
 378
 379 (defun vc-hg-create-repo ()
 380   "Create a new Mercurial repository."
 381   (vc-hg-command nil 0 nil "init"))
 382
 383 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 384
 385 ;; Modelled after the similar function in vc-bzr.el
 386 (defun vc-hg-could-register (file)
 387   "Return non-nil if FILE could be registered under hg."
 388   (and (vc-hg-responsible-p file)      ; shortcut
 389        (condition-case ()
 390            (with-temp-buffer
 391              (vc-hg-command t nil file "add" "--dry-run"))
 392              ;; The command succeeds with no output if file is
 393              ;; registered.
 394          (error))))
 395
 396 ;; XXX This would remove the file. Is that correct?
 397 ;; (defun vc-hg-unregister (file)
 398 ;;   "Unregister FILE from hg."
 399 ;;   (vc-hg-command nil nil file "remove"))
 400
 401 (defun vc-hg-checkin (files rev comment)
 402   "HG-specific version of `vc-backend-checkin'.
 403 REV is ignored."
 404   (vc-hg-command nil 0 files  "commit" "-m" comment))
 405
 406 (defun vc-hg-find-version (file rev buffer)
 407   (let ((coding-system-for-read 'binary)
 408         (coding-system-for-write 'binary))
 409     (if rev
 410         (vc-hg-command buffer 0 file "cat" "-r" rev)
 411       (vc-hg-command buffer 0 file "cat"))))
 412
 413 ;; Modelled after the similar function in vc-bzr.el
 414 (defun vc-hg-checkout (file &optional editable rev)
 415   "Retrieve a revision of FILE.
 416 EDITABLE is ignored.
 417 REV is the revision to check out into WORKFILE."
 418   (let ((coding-system-for-read 'binary)
 419         (coding-system-for-write 'binary))
 420   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 421     (if rev
 422         (vc-hg-command t 0 file "cat" "-r" rev)
 423       (vc-hg-command t 0 file "cat")))))
 424
 425 (defun vc-hg-checkout-model (file)
 426   'implicit)
 427
 428 ;; Modelled after the similar function in vc-bzr.el
 429 (defun vc-hg-workfile-unchanged-p (file)
 430   (eq 'up-to-date (vc-hg-state file)))
 431
 432 (defun vc-hg-dired-state-info (file)
 433   "Hg-specific version of `vc-dired-state-info'."
 434   (let ((hg-state (vc-state file)))
 435     (if (eq hg-state 'edited)
 436         (if (equal (vc-workfile-version file) "0")
 437             "(added)" "(modified)")
 438       ;; fall back to the default VC representation
 439       (vc-default-dired-state-info 'HG file))))
 440
 441 ;; Modelled after the similar function in vc-bzr.el
 442 (defun vc-hg-revert (file &optional contents-done)
 443   (unless contents-done
 444     (with-temp-buffer (vc-hg-command t 0 file "revert"))))
 445
 446 ;;; Internal functions
 447
 448 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
 449   "A wrapper around `vc-do-command' for use in vc-hg.el.
 450 The difference to vc-do-command is that this function always invokes `hg',
 451 and that it passes `vc-hg-global-switches' to it before FLAGS."
 452   (apply 'vc-do-command buffer okstatus "hg" file-or-list
 453          (if (stringp vc-hg-global-switches)
 454              (cons vc-hg-global-switches flags)
 455            (append vc-hg-global-switches
 456                    flags))))
 457
 458 (defun vc-hg-root (file)
 459   (vc-find-root file ".hg"))
 460
 461 (provide 'vc-hg)
 462
 463 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 464 ;;; vc-hg.el ends here