/external/dvc/lisp/xhg.el
Emacs Lisp | 1368 lines | 1035 code | 111 blank | 222 comment | 30 complexity | 3af8db955df0e5cf9937e5278ab74984 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-3.0, GPL-2.0
Large files files are truncated, but you can click here to view the full file
- ;;; xhg.el --- Mercurial interface for dvc
- ;; Copyright (C) 2005-2009 by all contributors
- ;; Author: Stefan Reichoer, <stefan@xsteve.at>
- ;; This file is free software; you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 3, or (at your option)
- ;; any later version.
- ;; This file is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
- ;; You should have received a copy of the GNU General Public License
- ;; along with GNU Emacs; see the file COPYING. If not, write to
- ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- ;; Boston, MA 02110-1301, USA.
- ;;; Commentary:
- ;; The mercurial interface for dvc
- ;;; Commands:
- ;;
- ;; Below are complete command list:
- ;;
- ;; `xhg-init'
- ;; Run hg init.
- ;; `xhg-rollback'
- ;; Run hg rollback.
- ;; `xhg-addremove'
- ;; Run hg addremove.
- ;; `xhg-dvc-rename'
- ;; Run hg rename.
- ;; `xhg-forget'
- ;; Run hg forget.
- ;; `xhg-add-all-files'
- ;; Run 'hg add' to add all files to mercurial.
- ;; `xhg-log'
- ;; Run hg log.
- ;; `xhg-search-regexp-in-log'
- ;; Run hg log -k <pattern>
- ;; `xhg-diff-1'
- ;; Run hg diff.
- ;; `xhg-dvc-diff'
- ;; Run hg diff.
- ;; `xhg-pull'
- ;; Run hg pull.
- ;; `xhg-push'
- ;; Run hg push.
- ;; `xhg-clone'
- ;; Run hg clone.
- ;; `xhg-dired-clone'
- ;; Run `xhg-clone' from dired.
- ;; `xhg-bundle'
- ;; Run hg bundle.
- ;; `xhg-unbundle'
- ;; Run hg unbundle.
- ;; `xhg-incoming'
- ;; Run hg incoming.
- ;; `xhg-outgoing'
- ;; Run hg outgoing.
- ;; `xhg-strip'
- ;; Run hg strip.
- ;; `xhg-merge'
- ;; Run hg merge.
- ;; `xhg-resolve'
- ;; Run hg resolve --all or <spec file>.
- ;; `xhg-resolve-list'
- ;; Run hg resolve --list.
- ;; `xhg-command-version'
- ;; Run hg version.
- ;; `xhg-branch'
- ;; Run hg branch.
- ;; `xhg-branches'
- ;; run xhg-branches
- ;; `xhg-merge-branch'
- ;; Run hg merge <branch-name>.
- ;; `xhg-manifest'
- ;; Run hg manifest.
- ;; `xhg-tip'
- ;; Run hg tip.
- ;; `xhg-heads'
- ;; Run hg heads.
- ;; `xhg-parents'
- ;; Run hg parents.
- ;; `xhg-identify'
- ;; Run hg identify.
- ;; `xhg-verify'
- ;; Run hg verify.
- ;; `xhg-showconfig'
- ;; Run hg showconfig.
- ;; `xhg-paths'
- ;; Run hg paths.
- ;; `xhg-tag'
- ;; Run hg tag -r <REV> NAME.
- ;; `xhg-tags'
- ;; Run hg tags.
- ;; `xhg-view'
- ;; Run hg view.
- ;; `xhg-export'
- ;; Run hg export.
- ;; `xhg-import'
- ;; Run hg import.
- ;; `xhg-undo'
- ;; Run hg undo.
- ;; `xhg-update'
- ;; Run hg update.
- ;; `xhg-convert'
- ;; Convert a foreign SCM repository to a Mercurial one.
- ;; `xhg-serve'
- ;; Run hg serve --daemon.
- ;; `xhg-serve-kill'
- ;; Kill a hg serve process started with `xhg-serve'.
- ;; `xhg-revision-get-last-or-num-revision'
- ;; Run the command:
- ;; `xhg-ediff-file-at-rev'
- ;; Ediff file at rev1 against rev2.
- ;; `xhg-missing-1'
- ;; Shows the logs of the new arrived changesets after a pull and before an update.
- ;; `xhg-save-diff'
- ;; Save the current hg diff to a file named FILENAME.
- ;; `xhg-hgrc-edit-repository-hgrc'
- ;; Edit the .hg/hgrc file for the current working copy
- ;; `xhg-hgrc-edit-global-hgrc'
- ;; Edit the ~/.hgrc file
- ;; `hgrc-mode-help'
- ;; Show the manual for the hgrc configuration file.
- ;;
- ;;; Customizable Options:
- ;;
- ;; Below are customizable option list:
- ;;
- ;;; History:
- ;;
- ;;; Code:
- (require 'dired-x)
- (require 'dvc-core)
- (require 'dvc-diff)
- (require 'xhg-core)
- (require 'xhg-log)
- (require 'xhg-mq)
- (require 'xhg-annotate)
- (defvar xhg-export-git-style-patches t "Run hg export --git.")
- ;;;###autoload
- (defun xhg-init (&optional dir)
- "Run hg init."
- (interactive
- (list (expand-file-name (dvc-read-directory-name "Directory for hg init: "
- (or default-directory
- (getenv "HOME"))))))
- (dvc-run-dvc-sync 'xhg (list "init" dir)
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg init %s finished" dir))))
- ;;;###autoload
- (defun xhg-dvc-add-files (&rest files)
- "Run hg add."
- (dvc-trace "xhg-add-files: %s" files)
- (let ((default-directory (xhg-tree-root)))
- (dvc-run-dvc-sync 'xhg (append '("add") (mapcar #'file-relative-name files))
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg add finished")))))
- ;;;###autoload
- (defun xhg-dvc-revert-files (&rest files)
- "Run hg revert."
- (dvc-trace "xhg-revert-files: %s" files)
- (let ((default-directory (xhg-tree-root)))
- (dvc-run-dvc-sync 'xhg (append '("revert") (mapcar #'file-relative-name files))
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg revert finished")))))
- (defun xhg-dry-tip ()
- "Extract only the revision number of tip"
- (let ((revision (with-temp-buffer
- (apply #'call-process "hg" nil t nil
- '("tip" "--template" "#rev#"))
- (buffer-string))))
- revision))
- ;;;###autoload
- (defun xhg-rollback (&optional revert)
- "Run hg rollback.
- if prefix-arg (C-u) run hg revert"
- (interactive "P")
- (let ((act-rev (xhg-dry-tip))
- (new-rev))
- (if (yes-or-no-p (format "Really rollback rev %s?" act-rev))
- (progn
- (dvc-run-dvc-sync 'xhg (list "rollback")
- :finished
- (lambda (output error status arguments)
- (setq new-rev (xhg-dry-tip))
- (message
- (when (equal act-rev new-rev)
- "no rollback information available"))))
- (if (and current-prefix-arg
- (not (equal act-rev new-rev)))
- (progn
- (dvc-run-dvc-sync 'xhg (list "revert" "--all")
- :finished
- (lambda (output error status arguments)
- (message "hg revert finished, now at rev %s" new-rev))))
- (when (not (equal act-rev new-rev))
- (message
- "hg rollback finished, tip is now at %s don't forget to revert" new-rev))))
- (message "hg rollback aborted"))))
- ;;;###autoload
- (defun xhg-dvc-remove-files (&rest files)
- "Run hg remove."
- (dvc-trace "xhg-remove-files: %s" files)
- (let ((default-directory (xhg-tree-root)))
- (dvc-run-dvc-sync 'xhg (append '("remove") (mapcar #'file-relative-name files))
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg remove finished")))))
- ;;;###autoload
- (defun xhg-addremove ()
- "Run hg addremove."
- (interactive)
- (dvc-run-dvc-sync 'xhg '("addremove")
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg addremove finished"))))
- ;;;###autoload
- (defun xhg-dvc-rename (from to &optional after force)
- "Run hg rename."
- (interactive
- (let* ((from-name (dvc-confirm-read-file-name "xhg rename: "))
- (to-name (dvc-confirm-read-file-name (concat "xhg rename '" from-name "' to: ") nil "" from-name)))
- (list from-name to-name nil nil)))
- (dvc-run-dvc-sync 'xhg (list "rename" (dvc-uniquify-file-name from) (dvc-uniquify-file-name to)
- (when after "--after") (when force "--force"))
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg rename finished"))))
- ;;;###autoload
- (defun xhg-forget (&rest files)
- "Run hg forget."
- (interactive (dvc-current-file-list))
- (let ((multiprompt (format "Forget %%d files for hg? "))
- (singleprompt (format "Forget file for hg: ")))
- (when (dvc-confirm-read-file-name-list multiprompt files singleprompt t)
- (dvc-run-dvc-sync 'xhg (append '("forget") files)
- :finished (dvc-capturing-lambda
- (output error status arguments)
- (message "hg forget finished"))))))
- ;;;###autoload
- (defun xhg-add-all-files (arg)
- "Run 'hg add' to add all files to mercurial.
- Normally run 'hg add -n' to simulate the operation to see which files will be added.
- Only when called with a prefix argument, add the files."
- (interactive "P")
- (dvc-run-dvc-sync 'xhg (list "add" (unless arg "-n"))))
- ;;;###autoload
- (defun xhg-log-toggle-verbose ()
- (interactive)
- (if xhg-log-verbose
- (progn
- (setq xhg-log-verbose nil)
- (apply #'xhg-log
- xhg-log-remember-func-args))
- (setq xhg-log-verbose t)
- (apply #'xhg-log
- xhg-log-remember-func-args)))
- (defvar xhg-log-verbose nil)
- (defvar xhg-log-remember-last-args nil)
- (defvar xhg-log-remember-func-args nil)
- ;;;###autoload
- (defun xhg-log (&optional r1 r2 show-patch file)
- "Run hg log.
- When run interactively, the prefix argument decides, which parameters are queried from the user.
- C-u : Show patches also, use all revisions
- C-u C-u : Show patches also, ask for revisions
- positive : Don't show patches, ask for revisions.
- negative : Don't show patches, limit to n revisions."
- (interactive "P")
- (when (interactive-p)
- (cond ((equal current-prefix-arg '(4))
- (setq show-patch t)
- (setq r1 nil))
- ((equal current-prefix-arg '(16))
- (setq show-patch t)
- (setq r1 1)))
- (when (and (numberp r1) (> r1 0))
- (setq r1 (read-string "hg log, R1:"))
- (setq r2 (read-string "hg log, R2:"))))
- (let ((buffer (dvc-get-buffer-create 'xhg 'log))
- (command-list '("log"))
- (cur-dir default-directory))
- (when r1
- (when (numberp r1)
- (setq r1 (number-to-string r1))))
- (when r2
- (when (numberp r2)
- (setq r2 (number-to-string r2))))
- (if (and (> (length r2) 0) (> (length r1) 0))
- (setq command-list (append command-list (list "-r" (concat r2 ":" r1))))
- (when (> (length r1) 0)
- (let ((r1-num (string-to-number r1)))
- (if (> r1-num 0)
- (setq command-list (append command-list (list "-r" r1)))
- (setq command-list
- (append command-list
- (list "-l" (number-to-string (abs r1-num)))))))))
- (when show-patch
- (setq command-list (append command-list (list "-p"))))
- ;; be verbose or not
- (setq xhg-log-remember-last-args command-list)
- (if (and xhg-log-remember-last-args
- xhg-log-verbose)
- (setq command-list (append '("-v") xhg-log-remember-last-args))
- (setq command-list xhg-log-remember-last-args))
- (setf file (expand-file-name (or file (buffer-file-name) default-directory)))
- (setq command-list (append command-list (list file)))
- (setq xhg-log-remember-func-args (list r1 r2 show-patch file))
- (dvc-switch-to-buffer-maybe buffer)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (xhg-log-mode)
- ;;(dvc-trace "xhg-log command-list: %S, default-directory: %s" command-list cur-dir)
- (let ((default-directory cur-dir))
- (dvc-run-dvc-sync 'xhg command-list
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (progn
- (with-current-buffer (capture buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (goto-char (point-min))
- (insert (format "hg log for %s\n\n" default-directory))
- (toggle-read-only 1)))))))))
- ;;;###autoload
- (defun xhg-search-regexp-in-log ()
- "Run hg log -k <pattern>"
- (interactive)
- (let* ((regex (read-string "Pattern: "))
- (args `("log" "-k" ,regex))
- (buffer (dvc-get-buffer-create 'xhg 'log)))
- (dvc-switch-to-buffer-maybe buffer)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (xhg-log-mode)
- (dvc-run-dvc-sync 'xhg args
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (progn
- (with-current-buffer (capture buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (goto-char (point-min))
- (insert (format "hg log for %s\n\n" default-directory))
- (toggle-read-only 1))))))))
- (defun xhg-parse-diff (changes-buffer)
- (save-excursion
- (while (re-search-forward
- "^diff -r [^ ]+ \\(.*\\)$" nil t)
- (let* ((name (match-string-no-properties 1))
- (added (progn (forward-line 1)
- (looking-at "^--- /dev/null")))
- (removed (progn (forward-line 1)
- (looking-at "^\\+\\+\\+ /dev/null"))))
- (with-current-buffer changes-buffer
- (ewoc-enter-last
- dvc-fileinfo-ewoc
- (make-dvc-fileinfo-legacy
- :data (list 'file
- name
- (cond (added "A")
- (removed "D")
- (t " "))
- (cond ((or added removed) " ")
- (t "M"))
- " " ; dir. Nothing is a directory in hg.
- nil))))))))
- (defun xhg-parse-status (changes-buffer)
- (let ((status-list (split-string (dvc-buffer-content (current-buffer)) "\n")))
- (let ((inhibit-read-only t)
- (modif)
- (modif-char))
- (erase-buffer)
- (setq dvc-header (format "hg status for %s\n" default-directory))
- (dolist (elem status-list)
- (unless (string= "" elem)
- (setq modif-char (substring elem 0 1))
- (with-current-buffer changes-buffer
- (ewoc-enter-last
- dvc-fileinfo-ewoc
- (make-dvc-fileinfo-legacy
- :data (list 'file (substring elem 2) modif-char)))))))))
- (defun xhg-diff-1 (modified path dont-switch base-rev)
- "Run hg diff.
- If DONT-SWITCH, don't switch to the diff buffer"
- (interactive (list nil nil current-prefix-arg))
- (let* ((window-conf (current-window-configuration))
- (cur-dir (or path default-directory))
- (orig-buffer (current-buffer))
- (root (xhg-tree-root cur-dir))
- (buffer (dvc-prepare-changes-buffer
- `(xhg (last-revision ,root 1))
- `(xhg (local-tree ,root))
- 'diff root 'xhg))
- (command-list '("diff")))
- (dvc-switch-to-buffer-maybe buffer)
- (dvc-buffer-push-previous-window-config window-conf)
- (when dont-switch (pop-to-buffer orig-buffer))
- (dvc-save-some-buffers root)
- (when base-rev
- (setq command-list (append command-list (list "-r" base-rev)))
- (when modified
- (setq command-list (append command-list (list "-r" modified)))))
- (dvc-run-dvc-sync 'xhg command-list
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (dvc-show-changes-buffer output 'xhg-parse-diff
- (capture buffer))))))
- ;;;###autoload
- (defun xhg-dvc-diff (&optional base-rev path dont-switch)
- "Run hg diff.
- If DONT-SWITCH, don't switch to the diff buffer"
- (interactive (list nil nil current-prefix-arg))
- (xhg-diff-1 nil path dont-switch
- (dvc-revision-to-string base-rev nil "tip")))
- (defun xhg-delta (base-rev modified &optional path dont-switch)
- ;; TODO: dvc-revision-to-string doesn't work for me.
- (interactive (list nil nil nil current-prefix-arg))
- (xhg-diff-1 (dvc-revision-to-string modified) path dont-switch
- (dvc-revision-to-string base-rev)))
- (defun xhg-dvc-status ()
- "Run hg status."
- (let* ((window-conf (current-window-configuration))
- ;;(root (xhg-tree-root))
- (root default-directory) ;; default-directory is setup by the caller...
- (buffer (dvc-prepare-changes-buffer
- `(xhg (last-revision ,root 1))
- `(xhg (local-tree ,root))
- 'status root 'xhg)))
- ;; (message "xhg-dvc-status root: %s" root)
- (dvc-switch-to-buffer-maybe buffer)
- (dvc-buffer-push-previous-window-config window-conf)
- (dvc-save-some-buffers root)
- (dvc-run-dvc-sync 'xhg '("status" ".")
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (with-current-buffer (capture buffer)
- (xhg-status-extra-mode-setup)
- (if (> (point-max) (point-min))
- (dvc-show-changes-buffer output 'xhg-parse-status
- (capture buffer))
- (dvc-diff-no-changes (capture buffer)
- "No changes in %s"
- (capture root))))))))
- (easy-menu-define xhg-mode-menu dvc-diff-mode-map
- "`xhg' menu"
- `("hg"
- ,xhg-mq-submenu
- ["Edit project hgrc file" xhg-hgrc-edit-repository-hgrc t]
- ["Edit global ~/.hgrc file" xhg-hgrc-edit-global-hgrc t]
- ))
- (defun xhg-status-extra-mode-setup ()
- "Do some additonal setup for xhg status buffers."
- (dvc-trace "xhg-status-extra-mode-setup called.")
- (easy-menu-add xhg-mode-menu)
- (when (boundp 'xhg-mq-sub-mode-map)
- (local-set-key [?Q] xhg-mq-sub-mode-map))
- (setq dvc-buffer-refresh-function 'xhg-dvc-status))
- (defun xhg-pull-finish-function (output error status arguments)
- (let ((buffer (dvc-get-buffer-create 'xhg 'pull)))
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (toggle-read-only 1)))
- (let ((dvc-switch-to-buffer-mode 'show-in-other-window))
- (dvc-switch-to-buffer buffer))))
- ;;;###autoload
- (defun xhg-pull (src &optional update-after-pull)
- "Run hg pull."
- (interactive (list (let* ((completions (xhg-paths 'both))
- (initial-input (car (member "default" completions))))
- (dvc-completing-read
- "Pull from hg repository: "
- completions nil nil initial-input))))
- (dvc-run-dvc-async 'xhg (list "pull" (when update-after-pull "--update") src)
- :error 'xhg-pull-finish-function
- :finished 'xhg-pull-finish-function))
- (defun xhg-push-finish-function (output error status arguments)
- (let ((buffer (dvc-get-buffer-create 'xhg 'push)))
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (toggle-read-only 1)))
- (let ((dvc-switch-to-buffer-mode 'show-in-other-window))
- (dvc-switch-to-buffer buffer))))
- ;;;###autoload
- (defun xhg-push (src)
- "Run hg push."
- (interactive (list (let* ((completions (xhg-paths 'both))
- (initial-input (car (member "default" completions))))
- (dvc-completing-read
- "Push to hg repository: "
- completions nil nil initial-input))))
- (dvc-run-dvc-async 'xhg (list "push" src)
- :error 'xhg-push-finish-function
- :finished 'xhg-push-finish-function))
- ;;;###autoload
- (defun xhg-clone (src &optional dest rev noupdate pull)
- "Run hg clone."
- (interactive (list (read-string "hg clone from: ")
- (read-string "hg clone to: ")
- (if current-prefix-arg
- (read-string "hg revision: ") ;; rev
- nil)
- nil ;; noupdate
- nil ;; pull
- ))
- (if rev
- (dvc-run-dvc-async 'xhg (list "clone" "--rev" rev src dest))
- (dvc-run-dvc-async 'xhg (list "clone" src dest))))
- ;;;###autoload
- (defun xhg-dired-clone ()
- "Run `xhg-clone' from dired."
- (interactive)
- (let* ((source (dired-filename-at-point))
- (target
- (read-string (format "Clone(%s)To: " (file-name-nondirectory source))
- (file-name-directory source))))
- (xhg-clone source target)))
- ;;;###autoload
- (defun xhg-bundle (name)
- "Run hg bundle."
- (interactive "sBundleName: ")
- (let ((bundle-name (if (string-match ".*\.hg$" name)
- name
- (concat name ".hg"))))
- (dvc-run-dvc-async 'xhg (list "bundle" "--base" "null" bundle-name))))
- ;;;###autoload
- (defun xhg-unbundle (fname)
- "Run hg unbundle."
- (interactive "fBundleName: ")
- (dvc-run-dvc-async 'xhg (list "unbundle" (expand-file-name fname))
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (if (y-or-n-p "Update now?")
- (xhg-update)
- (message "Don't forget to update!")))))
- ;;;###autoload
- (defun xhg-incoming (&optional src show-patch no-merges)
- "Run hg incoming."
- (interactive (list (let* ((completions (xhg-paths 'both))
- (initial-input (car (member "default" completions))))
- (dvc-completing-read
- "Show incoming from hg repository: "
- completions nil nil initial-input))
- nil ;; show-patch
- nil ;; no-merges
- ))
- (let ((window-conf (current-window-configuration))
- (buffer (dvc-get-buffer-create 'xhg 'log)))
- (dvc-switch-to-buffer-maybe buffer t)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (xhg-log-mode)
- (dvc-run-dvc-async 'xhg (list "incoming" (when show-patch "--patch") (when no-merges "--no-merges") src)
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (progn
- (with-current-buffer (capture buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (goto-char (point-min))
- (insert (format "hg incoming for %s\n\n" default-directory))
- (toggle-read-only 1)
- (xhg-log-next 1)))))
- :error
- (dvc-capturing-lambda (output error status arguments)
- (with-current-buffer output
- (goto-char (point-max))
- (forward-line -1)
- (if (looking-at "no changes found")
- (progn
- (message "No changes found")
- (set-window-configuration (capture window-conf)))
- (dvc-default-error-function output error status arguments)))))))
- ;;;###autoload
- (defun xhg-outgoing (&optional src show-patch no-merges)
- "Run hg outgoing."
- (interactive (list (let* ((completions (xhg-paths 'both))
- (initial-input (car (member "default" completions))))
- (dvc-completing-read
- "Show outgoing to hg repository: "
- completions nil nil initial-input))
- nil ;; show-patch
- nil ;; no-merges
- ))
- (let ((window-conf (current-window-configuration))
- (buffer (dvc-get-buffer-create 'xhg 'log)))
- (dvc-switch-to-buffer-maybe buffer t)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (xhg-log-mode)
- (dvc-run-dvc-async 'xhg (list "outgoing" (when show-patch "--patch") (when no-merges "--no-merges") src)
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (progn
- (with-current-buffer (capture buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (goto-char (point-min))
- (insert (format "hg outgoing for %s\n\n" default-directory))
- (toggle-read-only 1)))))
- :error
- (dvc-capturing-lambda (output error status arguments)
- (with-current-buffer output
- (goto-char (point-max))
- (forward-line -1)
- (if (looking-at "no changes found")
- (progn
- (message "No changes found")
- (set-window-configuration (capture window-conf)))
- (dvc-default-error-function output error status arguments)))))))
- (defun xhg-get-all-heads-list ()
- "Get a list of all heads available from the output of hg heads."
- (let ((rev-list (with-temp-buffer
- (apply #'call-process "hg" nil t nil
- '("heads"
- "--template"
- "#rev#\n"))
- (buffer-string))))
- (setq rev-list (cons "auto"
- (remove "" (split-string rev-list "\n"))))
- rev-list))
- (defun xhg-changep ()
- (let ((change (with-temp-buffer
- (apply #'call-process "hg" nil t nil
- '("diff"))
- (buffer-string))))
- (setq change (remove "" (split-string change "\n")))
- (if change
- t
- nil)))
- ;;;###autoload
- (defun xhg-strip (rev)
- "Run hg strip."
- (interactive (list (dvc-completing-read "Remove head: "
- (xhg-get-all-heads-list))))
- (dvc-run-dvc-sync 'xhg (list "strip" rev)))
- ;;;###autoload
- (defun xhg-merge ()
- "Run hg merge.
- To merge from specific revision, choose it in completion with tab.
- If `auto' is choose use default revision (last) unless there is ONLY
- one more head.
- See \(hg help merge.\)"
- (interactive)
- (let* ((haschange (xhg-changep))
- (collection (xhg-get-all-heads-list))
- (revision (dvc-completing-read "Merge from hg revision: "
- collection nil t))
- (arg))
- (when (or (string= revision "")
- (string= revision "auto"))
- (setq revision nil))
- (setq arg (if revision
- '("merge" "--rev")
- '("merge")))
- (cond ((and (> (length collection) 3)
- (not revision))
- (error "Abort: branch 'default' has more than 2 heads - please merge with an explicit rev."))
- ((equal revision (xhg-dry-tip))
- (error "Abort:can't merge with ancestor."))
- ((and (not haschange)
- (> (length collection) 2))
- (dvc-run-dvc-async 'xhg `(,@arg ,revision)
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (message "hg %s %s %s finished => %s"
- (nth 0 arg)
- (if revision
- (nth 1 arg)
- "")
- (if revision
- revision
- "")
- (concat (dvc-buffer-content error)
- (dvc-buffer-content output))))
- :error
- ;; avoid dvc-error buffer to appear in ediff
- (lambda (output error status arguments)
- nil)))
- (haschange
- (error "abort: outstanding uncommitted merges, Please commit before merging"))
- ((< (length collection) 3)
- (error "There is nothing to merge here")))))
- ;;;###autoload
- (defun xhg-resolve (&optional file)
- "Run hg resolve --all or <spec file>.
- With current prefix arg, take a file as argument.
- You should run xhg-merge before this.
- This command will cleanly retry unresolved file merges
- using file revisions preserved from the last update or merge.
- If file is given resolve this file else resolve all files."
- (interactive)
- (let ((unresolved-files
- (loop for i in (xhg-resolve-list t)
- if (equal (car i) "U")
- collect (cadr i))))
- (when current-prefix-arg
- (setq file
- (file-name-nondirectory (read-file-name "File: "))))
- (if file
- (if (member file unresolved-files)
- (dvc-run-dvc-sync 'xhg (list "resolve" file)
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (message "ok finished with status %s" status)
- (xhg-resolve-list)))
- (message "%s have been already resolved" file))
- (dvc-run-dvc-sync 'xhg (list "resolve" "--all")
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (message "ok finished with status %s" status)
- (xhg-resolve-list))))))
- ;;;###autoload
- (defun xhg-resolve-list (&optional quiet)
- "Run hg resolve --list.
- Call interactively, show buffer with info.
- Non interactively, return an alist with
- string keys as:
- U = unresolved
- R = resolved"
- (interactive)
- (let ((resolve-alist nil))
- (if quiet
- (progn
- (save-window-excursion
- (dvc-run-dvc-display-as-info 'xhg (list "resolve" "--list"))
- (with-current-buffer "*xhg-info*"
- (setq resolve-alist
- (mapcar #'split-string
- (split-string (buffer-substring-no-properties
- (point-min)
- (point-max))
- "\n"))))
- (kill-buffer "*xhg-info*")
- resolve-alist))
- (dvc-run-dvc-display-as-info 'xhg (list "resolve" "--list")))))
- (defun xhg-command-version ()
- "Run hg version."
- (interactive)
- (let ((version (dvc-run-dvc-sync 'xhg '("version")
- :finished 'dvc-output-buffer-handler)))
- (when (interactive-p)
- (message "Mercurial version: %s" version))
- version))
- ;;;###autoload
- (defun xhg-branch (&optional new-name)
- "Run hg branch.
- When called with a prefix argument, ask for the new branch-name, otherwise
- display the current one."
- (interactive "P")
- (let ((branch (dvc-run-dvc-sync 'xhg (list "branch")
- :finished 'dvc-output-buffer-handler)))
- (if (not new-name)
- (progn
- (when (interactive-p)
- (message "xhg branch: %s" branch))
- branch)
- (when (interactive-p)
- (setq new-name (read-string (format "Change branch from '%s' to: " branch) nil nil branch)))
- (dvc-run-dvc-sync 'xhg (list "branch" new-name)))))
- ;;;###autoload
- (defun xhg-branches (&optional only-list)
- "run xhg-branches"
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("branches"))
- (let ((branchs-list (with-current-buffer "*xhg-info*"
- (split-string (buffer-string) "\n"))))
- (when only-list
- (kill-buffer "*xhg-info*")
- (loop for i in branchs-list
- for e = (car (split-string i))
- when e
- collect e))))
- (defun xhg-branches-sans-current ()
- "Run xhg-branches but remove current branch."
- (save-window-excursion
- (let ((cur-branch (xhg-branch))
- (branches (xhg-branches t)))
- (remove cur-branch branches))))
- ;;;###autoload
- (defun xhg-merge-branch ()
- "Run hg merge <branch-name>.
- Usually merge the change made in dev branch in default branch."
- (interactive)
- (let* ((current-branch (xhg-branch))
- (branch (dvc-completing-read "BranchName: "
- (xhg-branches-sans-current))))
- (when (y-or-n-p (format "Really merge %s in %s" branch current-branch))
- (dvc-run-dvc-sync 'xhg (list "merge" branch)
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (message "Updated! Don't forget to commit."))))))
- ;;todo: add support to specify a rev
- (defun xhg-manifest ()
- "Run hg manifest."
- (interactive)
- (let ((buffer (dvc-get-buffer-create 'xhg 'manifest)))
- (dvc-run-dvc-sync 'xhg '("manifest")
- :finished
- (dvc-capturing-lambda (output error status arguments)
- (progn
- (with-current-buffer (capture buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert-buffer-substring output)
- (toggle-read-only 1)))
- (dvc-switch-to-buffer (capture buffer)))))))
- ;;;###autoload
- (defun xhg-tip ()
- "Run hg tip."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("tip")))
- ;;;###autoload
- (defun xhg-heads ()
- "Run hg heads."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("heads")))
- ;;;###autoload
- (defun xhg-parents ()
- "Run hg parents."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("parents")))
- ;;;###autoload
- (defun xhg-identify ()
- "Run hg identify."
- (interactive)
- (let ((id))
- (dvc-run-dvc-sync 'xhg '("identify")
- :finished
- (lambda (output error status arguments)
- (set-buffer output)
- (goto-char (point-min))
- (setq id
- (buffer-substring-no-properties
- (point)
- (line-end-position))))
- :error
- (lambda (output error status arguments)
- (setq id "<unknown>")))
- (when (interactive-p)
- (message "hg identity for %s: %s" default-directory id))
- id))
- ;;;###autoload
- (defun xhg-verify ()
- "Run hg verify."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("verify")))
- ;;;###autoload
- (defun xhg-showconfig ()
- "Run hg showconfig."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("showconfig")))
- ;;;###autoload
- (defun xhg-paths (&optional type)
- "Run hg paths.
- When called interactive, display them in an *xhg-info* buffer.
- Otherwise the return value depends on TYPE:
- 'alias: Return only alias names
- 'path: Return only the paths
- 'both Return the aliases and the paths in a flat list
- otherwise: Return a list of two element sublists containing alias, path"
- (interactive)
- (if (interactive-p)
- (dvc-run-dvc-display-as-info 'xhg '("paths"))
- (let* ((path-list (dvc-run-dvc-sync 'xhg (list "paths")
- :finished 'dvc-output-buffer-split-handler))
- (lisp-path-list (mapcar '(lambda(arg) (dvc-split-string arg " = " arg)) path-list))
- (result-list))
- (cond ((eq type 'alias)
- (setq result-list (mapcar 'car lisp-path-list)))
- ((eq type 'path)
- (setq result-list (mapcar 'cadr lisp-path-list)))
- ((eq type 'both)
- (setq result-list (append (mapcar 'car lisp-path-list) (mapcar 'cadr lisp-path-list))))
- (t
- (setq result-list lisp-path-list))))))
- ;;;###autoload
- (defun xhg-tag (rev name)
- "Run hg tag -r <REV> NAME."
- (interactive (list (read-from-minibuffer "Revision: "
- nil nil nil nil
- (xhg-dry-tip))
- (read-string "TagName: ")))
- (dvc-run-dvc-sync 'xhg (list "tag" "-r" rev name)
- :finished (lambda (output error status arguments)
- (message "Ok revision %s tagged as %s"
- rev name))))
- ;;;###autoload
- (defun xhg-tags ()
- "Run hg tags."
- (interactive)
- (dvc-run-dvc-display-as-info 'xhg '("tags")))
- ;; hg annotate: add support to edit the parameters
- ;; -r --rev revision
- ;; -a --text treat all files as text
- ;; -u --user show user
- ;; -n --number show revision number
- ;; -c --changeset show changeset
- ;; (defun xhg-annotate ()
- ;; "Run hg annotate."
- ;; (interactive)
- ;; (dvc-run-dvc-display-as-info 'xhg (append '("annotate") (dvc-current-file-list))))
- ;;;###autoload
- (defun xhg-view ()
- "Run hg view."
- (interactive)
- (dvc-run-dvc-async 'xhg '("view")))
- ;;;###autoload
- (defun xhg-export (rev fname)
- "Run hg export.
- `xhg-export-git-style-patches' determines, if git style patches are created."
- (interactive (list (xhg-read-revision "Export revision: ")
- (read-file-name "Export hg revision to: ")))
- (dvc-run-dvc-sync 'xhg (list "export" (when xhg-export-git-style-patches "--git") "-o" (expand-file-name fname) rev)
- :finished
- (lambda (output error status arguments)
- (message "Exported revision %s to %s." rev fname))))
- ;;;###autoload
- (defun xhg-import (patch-file-name &optional force)
- "Run hg import."
- (interactive (list (read-file-name "Import hg patch: " nil nil t (when (eq major-mode 'dired-mode)
- (file-name-nondirectory (dired-get-filename))))))
- (dvc-run-dvc-sync 'xhg (delete nil (list "import" (when force "--force") (expand-file-name patch-file-name)))
- :finished
- (lambda (output error status arguments)
- (message "Imported hg patch from %s." patch-file-name))))
- ;;;###autoload
- (defun xhg-undo ()
- "Run hg undo."
- (interactive)
- (let ((undo-possible (file-exists-p (concat (xhg-tree-root) ".hg/undo"))))
- (if undo-possible
- (save-window-excursion
- (xhg-log "-1" nil t)
- (if (yes-or-no-p "Undo this transaction? ")
- (progn
- (dvc-run-dvc-sync 'xhg (list "undo")
- :finished
- (lambda (output error status arguments)
- (message "Finished xhg undo."))))
- (message "xhg undo aborted.")))
- (message "xhg: No undo information available."))))
- ;;;###autoload
- (defun xhg-update (&optional clean switch)
- "Run hg update.
- When called with one prefix-arg run hg update -C (clean).
- Called with two prefix-args run hg update -C <branch-name> (switch to branch)."
- (interactive)
- (let* ((opt-list (cond ((or clean
- (equal current-prefix-arg '(4)))
- (list "update" "-C"))
- ((or switch
- (equal current-prefix-arg '(16)))
- (list "update" "-C" (dvc-completing-read "BranchName: "
- (xhg-branches-sans-current))))
- (t
- (list "update"))))
- (opt-string (mapconcat 'identity opt-list " ")))
- (dvc-run-dvc-sync 'xhg opt-list
- :finished
- (lambda (output error status arguments)
- (dvc-default-finish-function output error status arguments)
- (message "hg %s complete for %s" opt-string default-directory)))))
- (defun xhg-convert (source target &optional revnum)
- "Convert a foreign SCM repository to a Mercurial one.
- With prefix arg prompt for REVNUM.
- Accepted source formats [identifiers]:(Mercurial-1.1.2)
- - Mercurial [hg]
- - CVS [cvs]
- - Darcs [darcs]
- - git [git]
- - Subversion [svn]
- - Monotone [mtn]
- - GNU Arch [gnuarch]
- - Bazaar [bzr]
- Be sure to add to your hgrc:
- \[extensions\]
- hgext.convert =
- Read also: hg help convert.
- "
- (interactive "DSource: \nsTarget: ")
- (let* ((src (expand-file-name source))
- (tget (expand-file-name target))
- (rev (if current-prefix-arg (read-string "Revision: ") revnum))
- (arg-list (if rev (list "convert" src tget "-r" rev) (list "convert" src tget))))
- (message "HG conversion of `%s' to `%s' ..." source target)
- (dvc-run-dvc-async 'xhg arg-list
- :finished (dvc-capturing-lambda (output error status arguments)
- (let ((default-directory (capture target)))
- (xhg-update))
- (message "HG conversion of `%s' to `%s' ... done."
- (capture source) (capture target))))))
- ;; --------------------------------------------------------------------------------
- ;; hg serve functionality
- ;; --------------------------------------------------------------------------------
- (defvar xhg-serve-parameter-list (make-hash-table :test 'equal)
- "A hash table that holds the mapping from work directory roots to
- extra parameters used for hg serve.
- The extra parameters are given as alist. The following example shows the supported settings:
- '((port 8235) (name \"my-project\"))")
- ;;;###autoload
- (defun xhg-serve-register-serve-parameter-list (working-copy-root parameter-list &optional start-server)
- "Register a mapping from a work directory root to a parameter list for hg serve.
- When START-SERVER is given, start the server immediately.
- Example usage:
- (xhg-serve-register-serve-parameter-list \"~/proj/simple-counter-1/\" '((port 8100) (name \"simple-counter\")))"
- (puthash (dvc-uniquify-file-name working-copy-root) parameter-list xhg-serve-parameter-list)
- (when start-server
- (let ((default-directory (dvc-uniquify-file-name working-copy-root)))
- (xhg-serve))))
- (defun xhg-serve ()
- "Run hg serve --daemon.
- See `xhg-serve-register-serve-parameter-list' to register specific parameters for the server process."
- (interactive)
- (let* ((tree-root (dvc-tree-root))
- (server-status-dir (concat tree-root ".xhg-serve/"))
- (parameter-alist (gethash (dvc-uniquify-file-name tree-root) xhg-serve-parameter-list))
- (port (or (cadr (assoc 'port parameter-alist)) 8000))
- (name (cadr (assoc 'name parameter-alist)))
- (errorlog (concat server-status-dir "error.log"))
- (accesslog (concat server-status-dir "access.log"))
- (pid-file (concat server-status-dir "server.pid")))
- (when (numberp port)
- (setq port (number-to-string port)))
- (unless (file-directory-p server-status-dir)
- (make-directory server-status-dir))
- (dvc-run-dvc-sync 'xhg (list "serve" "--daemon" (when port "--port") port (when name "--name") name
- "--pid-file" pid-file "--accesslog" accesslog "--errorlog" errorlog)
- :finished (dvc-capturing-lambda (output error status arguments)
- (message "hg server started for %s, using port %s" tree-root port)))))
- (defun xhg-serve-kill ()
- "Kill a hg serve process started with `xhg-serve'."
- (interactive)
- (let* ((tree-root (dvc-tree-root))
- (server-status-dir (concat tree-root ".xhg-serve/"))
- (pid-file (concat server-status-dir "server.pid"))
- (pid)
- (kill-status))
- (if (file-readable-p pid-file)
- (with-current-buffer
- (find-file-noselect pid-file)
- (setq pid (buffer-substring-no-properties (point-min) (- (point-max) 1)))
- (kill-buffer (current-buffer)))
- (message "no hg serve pid file found - aborting"))
- (when pid
- (setq kill-status (call-process "kill" nil nil nil pid))
- (if (eq kill-status 0)
- (progn
- (delete-file pid-file)
- (message "hg serve process killed."))
- (message "kill hg serve process failed, return status: %d" kill-status)))))
- ;; --------------------------------------------------------------------------------
- ;; dvc revision support
- ;; --------------------------------------------------------------------------------
- ;;;###autoload
- (defun xhg-revision-get-last-revision (file last-revision)
- "Insert the content of FILE in LAST-REVISION, in current buffer.
- LAST-REVISION looks like
- \(\"path\" NUM)"
- (dvc-trace "xhg-revision-get-last-revision file:%S last-revision:%S" file last-revision)
- (let ((xhg-rev (int-to-string (nth 1 last-revision)))
- (default-directory (car last-revision)))
- ;; TODO: support the last-revision parameter??
- (insert (dvc-run-dvc-sync
- 'xhg (list "cat" file)
- :finished 'dvc-output-buffer-handler-withnewline))))
- ;;;###autoload
- (defun xhg-revision-get-last-or-num-revision (infile outfile &optional revision)
- "Run the command:
- hg cat --rev <num revision> -o outputfile inputfile"
- (interactive
- (let* ((xhg-infile (read-file-name "InputFile: "))
- (xhg-outfile (read-file-name "OutputFile: "))
- (xhg-rev (if current-prefix-arg
- (read-string "Revision: ")
- "tip")))
- (setq xhg-infile (expand-file-name xhg-infile)
- xhg-outfile (concat (expand-file-name xhg-outfile)
- "."
- xhg-rev))
- (list xhg-infile xhg-outfile xhg-rev)))
- (dvc-run-dvc-sync 'xhg (list "cat"
- "--rev"
- revision
- "-o"
- outfile
- infile)
- :finished 'dvc-output-buffer-handler-withnewline)
- (message "%s extracted in %s at revision %s"
- (file-name-nondirectory infile)
- (file-relative-name outfile)
- revision))
- ;;;###autoload
- (defun xhg-ediff-file-at-rev (file rev1 rev2 &optional keep-variants)
- "Ediff file at rev1 against rev2.
- With prefix arg do not delete the files.
- If rev1 or rev2 are empty, ediff current file against last revision.
- Tip: to quit ediff, use C-u q to kill the ediffied buffers."
- (interactive (list (read-file-name "File:" nil (dvc-get-file-info-at-point))
- (read-from-minibuffer "Rev1: " nil nil nil nil (xhg-dry-tip))
- (read-string "Rev2: ")))
- (let* ((fname (expand-file-name file))
- (bfname (file-name-nondirectory file))
- (file1 (concat dvc-temp-directory "/" rev1 "-" bfname))
- (file2 (concat dvc-temp-directory "/" rev2 "-" bfname))
- (pref-arg (or keep-variants
- current-prefix-arg)))
- (if (or (equal "" rev1)
- (equal "" rev2))
- (dvc-file-ediff fname)
- (unless (equal rev1 rev2)
- (xhg-revision-get-last-or-num-revision fname file1 rev1)
- (xhg-revision-get-last-or-num-revision fname file2 rev2)
- (ediff-files file1 file2)
- (unless pref-arg
- (delete-file file1)
- (delete-file file2))))))
- ;; --------------------------------------------------------------------------------
- ;; higher level commands
- ;; --------------------------------------------------------------------------------
- (defvar xhg-submit-patch-mapping nil)
- ;;(add-to-list 'xhg-submit-patch-mapping '("~/data/wiki" ("joe@host.com" "my-wiki")))
- (defun xhg-export-via-mail (rev)
- (interactive (list (xhg-read-revision "Export revision: ")))
- (let ((file-name)
- (destination-email "")
- (base-file-name nil)
- (subject)
- (description))
- (dolist (m xhg-submit-patch-mapping)
- (when (string= (dvc-uniquify-file-name (car m)) (dvc-uniquify-file-name (xhg-tree-root)))
- ;;(message "%S" (cadr m))
- (setq destination-email (car (cadr m)))
- (setq base-file-name (cadr (cadr m)))))
- (setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory) (or base-file-name "") rev ".patch"))
- (xhg-export rev file-name)
- (setq description
- (dvc-run-dvc-sync 'xhg (list "log" "-r" rev)
- :finished 'dvc-output-buffer-handler))
- (require 'reporter)
- (delete-other-windows)
- (reporter-submit-bug-report
- destination-email
- nil
- nil
- nil
- nil
- description)
- (save-excursion
- (re-search-backward "^summary: +\\(.+\\)")
- (setq subject (match-string-no-properties 1)))
- ;; delete emacs version - its not needed here
- (delete-region (point) (point-max))
- (mml-attach-file file-name "text/x-patch")
- (goto-char (point-min))
- (mail-position-on-field "Subject")
- (insert (concat "[PATCH] " subject))))
- ;; hg log -r $(hg identify)
- ;; add one to that revision number -> actual-rev+1
- ;; hg log -r actual-rev+1:tip, e.g. hg log -r 5:tip
- ;;;###autoload
- (defun xhg-missing-1 ()
- "Shows the logs of the new ar…
Large files files are truncated, but you can click here to view the full file