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 ;; Version: 1889
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This is a mercurial version control backend
  29
  30 ;;; Thanks:
  31
  32 ;;; Bugs:
  33
  34 ;;; Installation:
  35
  36 ;;; Todo:
  37
  38 ;; Implement the rest of the vc interface. See the comment at the
  39 ;; beginning of vc.el. The current status is:
  40
  41 ;; FUNCTION NAME                               STATUS
  42 ;; * registered (file)                         OK
  43 ;; * state (file)                              OK
  44 ;; - state-heuristic (file)                    ?? PROBABLY NOT NEEDED
  45 ;; - dir-state (dir)                           NEEDED
  46 ;; * workfile-version (file)                   OK
  47 ;; - latest-on-branch-p (file)                 ??
  48 ;; * checkout-model (file)                     OK
  49 ;; - workfile-unchanged-p (file)               ??
  50 ;; - mode-line-string (file)                   NOT NEEDED
  51 ;; - dired-state-info (file)                   NEEDED
  52 ;; STATE-CHANGING FUNCTIONS
  53 ;; * register (files &optional rev comment)    OK
  54 ;; - init-version ()                           NOT NEEDED
  55 ;; - responsible-p (file)                      OK
  56 ;; - could-register (file)                     OK
  57 ;; - receive-file (file rev)                   ?? PROBABLY NOT NEEDED
  58 ;; - unregister (file)                         COMMENTED OUT, MAY BE INCORRECT
  59 ;; * checkin (files rev comment)               OK
  60 ;; * find-version (file rev buffer)            OK
  61 ;; * checkout (file &optional editable rev)    NOT NEEDED, COMMENTED OUT
  62 ;; * revert (file &optional contents-done)     OK
  63 ;; - rollback (files)                          ?? PROBABLY NOT NEEDED
  64 ;; - merge (file rev1 rev2)                    NEEDED
  65 ;; - merge-news (file)                         NEEDED
  66 ;; - steal-lock (file &optional version)       NOT NEEDED
  67 ;; HISTORY FUNCTIONS
  68 ;; * print-log (files &optional buffer)        OK
  69 ;; - log-view-mode ()                          OK
  70 ;; - show-log-entry (version)                  NOT NEEDED, DEFAULT IS GOOD
  71 ;; - wash-log (file)                           ??
  72 ;; - logentry-check ()                         NOT NEEDED
  73 ;; - comment-history (file)                    NOT NEEDED
  74 ;; - update-changelog (files)                  NOT NEEDED
  75 ;; * diff (files &optional rev1 rev2 buffer)   OK
  76 ;; - revision-completion-table (file)          ??
  77 ;; - diff-tree (dir &optional rev1 rev2)       TEST IT
  78 ;; - annotate-command (file buf &optional rev) OK
  79 ;; - annotate-time ()                          OK
  80 ;; - annotate-current-time ()                  ?? NOT NEEDED
  81 ;; - annotate-extract-revision-at-line ()      OK
  82 ;; SNAPSHOT SYSTEM
  83 ;; - create-snapshot (dir name branchp)        NEEDED (probably branch?)
  84 ;; - assign-name (file name)                   NOT NEEDED
  85 ;; - retrieve-snapshot (dir name update)       ?? NEEDED??
  86 ;; MISCELLANEOUS
  87 ;; - make-version-backups-p (file)             ??
  88 ;; - repository-hostname (dirname)             ??
  89 ;; - previous-version (file rev)               OK
  90 ;; - next-version (file rev)                   OK
  91 ;; - check-headers ()                          ??
  92 ;; - clear-headers ()                          ??
  93 ;; - delete-file (file)                        TEST IT
  94 ;; - rename-file (old new)                     OK
  95 ;; - find-file-hook ()                         PROBABLY NOT NEEDED
  96 ;; - find-file-not-found-hook ()               PROBABLY NOT NEEDED
  97
  98 ;; Implement Stefan Monnier's advice:
  99 ;; vc-hg-registered and vc-hg-state
 100 ;; Both of those functions should be super extra careful to fail gracefully in
 101 ;; unexpected circumstances. The reason this is important is that any error
 102 ;; there will prevent the user from even looking at the file :-(
 103 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
 104 ;; mercurial's control and extracting the current revision should be done
 105 ;; without even using `hg' (this way even if you don't have `hg' installed,
 106 ;; Emacs is able to tell you this file is under mercurial's control).
 107
 108 ;;; History:
 109 ;;
 110
 111 ;;; Code:
 112
 113 (eval-when-compile
 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 \f
 129 ;;; Properties of the backend
 130
 131 (defun vc-hg-revision-granularity ()
 132      'repository)
 133
 134 ;;; State querying functions
 135
 136 ;;;###autoload (defun vc-hg-registered (file)
 137 ;;;###autoload   "Return non-nil if FILE is registered with hg."
 138 ;;;###autoload   (if (vc-find-root file ".hg")       ; short cut
 139 ;;;###autoload       (progn
 140 ;;;###autoload         (load "vc-hg")
 141 ;;;###autoload         (vc-hg-registered file))))
 142
 143 ;; Modelled after the similar function in vc-bzr.el
 144 (defun vc-hg-registered (file)
 145   "Return non-nil if FILE is registered with hg."
 146   (if (vc-hg-root file)               ; short cut
 147       (vc-hg-state file)))            ; expensive
 148
 149 (defun vc-hg-state (file)
 150   "Hg-specific version of `vc-state'."
 151   (let*
 152       ((status nil)
 153        (out
 154         (with-output-to-string
 155           (with-current-buffer
 156               standard-output
 157             (setq status
 158                   (condition-case nil
 159                       ;; Ignore all errors.
 160                       (call-process
 161                        "hg" nil t nil "--cwd" (file-name-directory file)
 162                        "status" (file-name-nondirectory file))
 163                     ;; Some problem happened.  E.g. We can't find an `hg'
 164                     ;; executable.
 165                     (error nil)))))))
 166     (when (eq 0 status)
 167       (if (eq 0 (length out)) 'up-to-date
 168         (let ((state (aref out 0)))
 169           (cond
 170            ((eq state ?M) 'edited)
 171            ((eq state ?A) 'edited)
 172            ((eq state ?P) 'needs-patch)
 173            ((eq state ??) nil)
 174            (t 'up-to-date)))))))
 175
 176 (defun vc-hg-workfile-version (file)
 177   "Hg-specific version of `vc-workfile-version'."
 178   (let*
 179       ((status nil)
 180        (out
 181         (with-output-to-string
 182           (with-current-buffer
 183               standard-output
 184             (setq status
 185                   (condition-case nil
 186                       ;; Ignore all errors.
 187                       (call-process
 188                        "hg" nil t nil "--cwd" (file-name-directory file)
 189                        "log" "-l1" (file-name-nondirectory file))
 190                     ;; Some problem happened.  E.g. We can't find an `hg'
 191                     ;; executable.
 192                     (error nil)))))))
 193     (when (eq 0 status)
 194       (if (string-match "changeset: *\\([0-9]*\\)" out)
 195           (match-string 1 out)
 196         "0"))))
 197
 198 ;;; History functions
 199
 200 (defun vc-hg-print-log(files &optional buffer)
 201   "Get change log associated with FILES."
 202   ;; `log-view-mode' needs to have the file name in order to function
 203   ;; correctly. "hg log" does not print it, so we insert it here by
 204   ;; hand.
 205
 206   ;; `vc-do-command' creates the buffer, but we need it before running
 207   ;; the command.
 208   (vc-setup-buffer buffer)
 209   ;; If the buffer exists from a previous invocation it might be
 210   ;; read-only.
 211   (let ((inhibit-read-only t))
 212     (with-current-buffer
 213         buffer
 214       (insert "File:        " (vc-delistify (mapcar (lambda (file) (file-name-nondirectory file)) files)) "\n")))
 215   (vc-hg-command
 216    buffer
 217    (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
 218    files "log"))
 219
 220 (defvar log-view-message-re)
 221 (defvar log-view-file-re)
 222 (defvar log-view-font-lock-keywords)
 223
 224 (define-derived-mode vc-hg-log-view-mode log-view-mode "HG-Log-View"
 225   (require 'add-log) ;; we need the faces add-log
 226   ;; Don't have file markers, so use impossible regexp.
 227   (set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
 228   (set (make-local-variable 'log-view-message-re)
 229        "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
 230   (set (make-local-variable 'log-view-font-lock-keywords)
 231        (append
 232         log-view-font-lock-keywords
 233         ;; Handle the case:
 234         ;; user: foo@bar
 235         '(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 236            (1 'change-log-email))
 237           ;; Handle the case:
 238           ;; user: FirstName LastName <foo@bar>
 239           ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 240            (1 'change-log-name)
 241            (2 'change-log-email))
 242           ("^date: \\(.+\\)" (1 'change-log-date))
 243           ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
 244
 245 (defun vc-hg-diff (files &optional oldvers newvers buffer)
 246   "Get a difference report using hg between two versions of FILES."
 247   (let ((working (vc-workfile-version (car files))))
 248     (if (and (equal oldvers working) (not newvers))
 249         (setq oldvers nil))
 250     (if (and (not oldvers) newvers)
 251         (setq oldvers working))
 252     (apply 'call-process "hg" nil (or buffer "*vc-diff*") nil
 253            "--cwd" (file-name-directory (car files)) "diff"
 254            (append
 255             (if oldvers
 256                 (if newvers
 257                     (list "-r" oldvers "-r" newvers)
 258                   (list "-r" oldvers))
 259               (list ""))
 260             (mapcar (lambda (file) (file-name-nondirectory file)) files)))))
 261
 262 (defun vc-hg-diff-tree (file &optional oldvers newvers buffer)
 263   (vc-hg-diff (list file) oldvers newvers buffer))
 264
 265 (defun vc-hg-annotate-command (file buffer &optional version)
 266   "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
 267 Optional arg VERSION is a version to annotate from."
 268   (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
 269   (with-current-buffer buffer
 270     (goto-char (point-min))
 271     (re-search-forward "^[0-9]")
 272     (delete-region (point-min) (1- (point)))))
 273
 274
 275 ;; The format for one line output by "hg annotate -d -n" looks like this:
 276 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
 277 ;; i.e: VERSION_NUMBER DATE: CONTENTS
 278 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
 279
 280 (defun vc-hg-annotate-time ()
 281   (when (looking-at vc-hg-annotate-re)
 282     (goto-char (match-end 0))
 283     (vc-annotate-convert-time
 284      (date-to-time (match-string-no-properties 2)))))
 285
 286 (defun vc-hg-annotate-extract-revision-at-line ()
 287   (save-excursion
 288     (beginning-of-line)
 289     (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
 290
 291 (defun vc-hg-previous-version (file rev)
 292   (let ((newrev (1- (string-to-number rev))))
 293     (when (>= newrev 0)
 294       (number-to-string newrev))))
 295
 296 (defun vc-hg-next-version (file rev)
 297   (let ((newrev (1+ (string-to-number rev)))
 298         (tip-version
 299          (with-temp-buffer
 300            (vc-hg-command t nil nil "tip")
 301            (goto-char (point-min))
 302            (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
 303            (string-to-number (match-string-no-properties 1)))))
 304     ;; We don't want to exceed the maximum possible version number, ie
 305     ;; the tip version.
 306     (when (<= newrev tip-version)
 307       (number-to-string newrev))))
 308
 309 ;; Modelled after the similar function in vc-bzr.el
 310 (defun vc-hg-delete-file (file)
 311   "Delete FILE and delete it in the hg repository."
 312   (condition-case ()
 313       (delete-file file)
 314     (file-error nil))
 315   (vc-hg-command nil nil file "remove" "--after" "--force"))
 316
 317 ;; Modelled after the similar function in vc-bzr.el
 318 (defun vc-hg-rename-file (old new)
 319   "Rename file from OLD to NEW using `hg mv'."
 320   (vc-hg-command nil nil new old "mv"))
 321
 322 (defun vc-hg-register (files &optional rev comment)
 323   "Register FILES under hg.
 324 REV is ignored.
 325 COMMENT is ignored."
 326   (vc-hg-command nil nil files "add"))
 327
 328 (defun vc-hg-create-repo ()
 329   "Create a new Mercurial repository."
 330   (vc-do-command nil 0 "svn" '("init")))
 331
 332 (defalias 'vc-hg-responsible-p 'vc-hg-root)
 333
 334 ;; Modelled after the similar function in vc-bzr.el
 335 (defun vc-hg-could-register (file)
 336   "Return non-nil if FILE could be registered under hg."
 337   (and (vc-hg-responsible-p file)      ; shortcut
 338        (condition-case ()
 339            (with-temp-buffer
 340              (vc-hg-command t nil file "add" "--dry-run"))
 341              ;; The command succeeds with no output if file is
 342              ;; registered.
 343          (error))))
 344
 345 ;; XXX This would remove the file. Is that correct?
 346 ;; (defun vc-hg-unregister (file)
 347 ;;   "Unregister FILE from hg."
 348 ;;   (vc-hg-command nil nil file "remove"))
 349
 350 (defun vc-hg-checkin (files rev comment)
 351   "HG-specific version of `vc-backend-checkin'.
 352 REV is ignored."
 353   (vc-hg-command nil nil files  "commit" "-m" comment))
 354
 355 (defun vc-hg-find-version (file rev buffer)
 356   (let ((coding-system-for-read 'binary)
 357         (coding-system-for-write 'binary))
 358     (if rev
 359         (vc-hg-command buffer nil file "cat" "-r" rev)
 360       (vc-hg-command buffer nil file "cat"))))
 361
 362 ;; Modelled after the similar function in vc-bzr.el
 363 ;; This should not be needed, `vc-hg-find-version' provides the same
 364 ;; functionality.
 365 ;; (defun vc-hg-checkout (file &optional editable rev workfile)
 366 ;;   "Retrieve a revision of FILE into a WORKFILE.
 367 ;; EDITABLE is ignored.
 368 ;; REV is the revision to check out into WORKFILE."
 369 ;;   (unless workfile
 370 ;;     (setq workfile (vc-version-backup-file-name file rev)))
 371 ;;   (let ((coding-system-for-read 'binary)
 372 ;;         (coding-system-for-write 'binary))
 373 ;;   (with-temp-file workfile
 374 ;;     (if rev
 375 ;;         (vc-hg-command t nil file "cat" "-r" rev)
 376 ;;       (vc-hg-command t nil file "cat")))))
 377
 378 (defun vc-hg-checkout-model (file)
 379   'implicit)
 380
 381 ;; Modelled after the similar function in vc-bzr.el
 382 (defun vc-hg-revert (file &optional contents-done)
 383   (unless contents-done
 384     (with-temp-buffer (vc-hg-command t nil file "revert"))))
 385
 386 ;;; Internal functions
 387
 388 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
 389   "A wrapper around `vc-do-command' for use in vc-hg.el.
 390 The difference to vc-do-command is that this function always invokes `hg',
 391 and that it passes `vc-hg-global-switches' to it before FLAGS."
 392   (apply 'vc-do-command buffer okstatus "hg" file-or-list
 393          (if (stringp vc-hg-global-switches)
 394              (cons vc-hg-global-switches flags)
 395            (append vc-hg-global-switches
 396                    flags))))
 397
 398 (defun vc-hg-root (file)
 399   (vc-find-root file ".hg"))
 400
 401 (provide 'vc-hg)
 402
 403 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
 404 ;;; vc-hg.el ends here