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