761 lines
29 KiB
EmacsLisp
761 lines
29 KiB
EmacsLisp
;;; dvc-buffers.el --- Buffer management for DVC
|
|
|
|
;; Copyright (C) 2005-2010 by all contributors
|
|
|
|
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
|
|
;; Contributions from:
|
|
;; 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:
|
|
|
|
;;
|
|
|
|
(eval-when-compile (require 'cl))
|
|
(eval-and-compile (require 'dvc-utils))
|
|
(require 'dvc-ui)
|
|
(require 'dvc-defs)
|
|
(require 'dvc-register)
|
|
|
|
(defvar dvc-buffers-tree nil
|
|
"Tree containing all dvc buffers.
|
|
|
|
Must be of the form
|
|
((tla
|
|
(type1 (\"path1\" buffer \"original name of buffer\")
|
|
(\"path2\" buffer2 \"original name of buffer2\"))
|
|
(type2 (\"path1\" buffer3 \"original name of buffer3\")
|
|
(\"path3\" buffer4 \"original name of buffer4\")))
|
|
(bzr
|
|
(type1 (\"path4\" buffer5 \"original name of buffer5\")))
|
|
(xhg
|
|
(type3 (...))))
|
|
Used to keep track of all the dvc related buffers.")
|
|
|
|
(defvar dvc-buffer-type-alist
|
|
'(
|
|
(alog "log*" path)
|
|
;; alog for "absolute log", i.e., assume path supplied is already
|
|
;; the root path
|
|
(add-patch "add-patch*" path)
|
|
(annotate "annotate*" path)
|
|
(archives "archives*" single)
|
|
(bookmark "bookmarks*" single)
|
|
(branches "branches(%s)*" string)
|
|
(browse "browse*" single)
|
|
(categories "categories(%s)*" string)
|
|
(changelog "changelog*" root)
|
|
(changeset "changeset(%s)*" string)
|
|
(commit "commit*" root)
|
|
(conflicts "conflicts*" root)
|
|
(diff "diff*" root)
|
|
(errors "error*" multiple)
|
|
(file-diff "file-diff*" path)
|
|
(generic "process*" multiple)
|
|
(info "info*" root)
|
|
(inventory "inventory*" path)
|
|
(log "log*" root)
|
|
(log-edit "log-edit*" root)
|
|
(manifest "manifest*" root)
|
|
(missing "missing*" root)
|
|
(patch-queue "patch-queue*" root)
|
|
(pull "pull*" root)
|
|
(remote-log "log(%s)*" string)
|
|
(revision-diff "diff(%s)*" string)
|
|
(revisions "revisions(%s)*" string)
|
|
(revlog "revlog(%s)*" string-multiple)
|
|
(status "status*" root)
|
|
(tips "tips*" single)
|
|
(tla-missing "missing*" single)
|
|
(tree-lint "tree-lint*" root)
|
|
(unknowns "unknowns*" root)
|
|
(versions "versions(%s)*" string)
|
|
)
|
|
"List of (type name mode) used to generate a name for a buffer.
|
|
|
|
TYPE is the type of buffer to create, passed as the first argument to
|
|
`dvc-get-buffer-create'.
|
|
|
|
NAME is a string, used as a name for the returned buffer.
|
|
|
|
MODE is a symbol defining the way to manage (value of
|
|
`default-directory' in the created buffer) paths for this type of
|
|
buffers. It can have the following values:
|
|
|
|
* 'root: `default-directory' will be the tree-root of the specified
|
|
directory.
|
|
|
|
* 'path: `default-directory' will be the path specified. Can also be
|
|
a file.
|
|
|
|
For 'root and 'path, `dvc-get-buffer-create' will return the existing
|
|
buffer for this type and this path if it exists, or create a new one
|
|
otherwise.
|
|
|
|
* 'single: There is only one buffer of this type for each Emacs
|
|
instance. If a path is provided, `default-directory' is set to that
|
|
path. Otherwise, the path is left unchanged when a buffer is
|
|
reused, and set to the current directory on buffer creation.
|
|
|
|
* 'multiple: `default-directory' is set to the path specified. A new
|
|
buffer is returned anyway. (No buffer reuse).
|
|
|
|
* 'string: The path specified is actually a string. It won't be used
|
|
to set `default-directory'. The name of the created buffer will be
|
|
(format name string).
|
|
|
|
* 'string-multiple: combination of 'string and 'multiple.")
|
|
|
|
(defun dvc-buffers-tree-remove (buffer)
|
|
"Remove BUFFER from the buffers tree."
|
|
(dolist (dvc-cons dvc-buffers-tree)
|
|
(dolist (type-cons (cdr dvc-cons))
|
|
(dolist (path-buffer (cdr type-cons))
|
|
(when (eq (cadr path-buffer) buffer)
|
|
(setcdr type-cons (delete path-buffer (cdr type-cons))))))))
|
|
|
|
(defun dvc-buffers-tree-add (dvc type path buffer)
|
|
"Add a buffer for back-end DVC, of TYPE visiting PATH to the buffers tree.
|
|
BUFFER should be the buffer to add."
|
|
(let* ((to-add (list path buffer (buffer-name buffer)))
|
|
(dvc-assoc (assoc dvc dvc-buffers-tree))
|
|
(tree-assoc (assoc type dvc-assoc)))
|
|
(if dvc-assoc
|
|
(if tree-assoc
|
|
(push to-add
|
|
(cdr tree-assoc))
|
|
(push (list type to-add)
|
|
(cdr dvc-assoc)))
|
|
(push (list dvc (list type to-add))
|
|
dvc-buffers-tree))))
|
|
|
|
(defun dvc-create-buffer (name)
|
|
"Create a buffer for a dvc-mode.
|
|
`create-file-buffer' is used to allow uniquify to modify the name."
|
|
(with-current-buffer (create-file-buffer name)
|
|
(setq list-buffers-directory (concat default-directory name))
|
|
(current-buffer)))
|
|
|
|
(defun dvc-get-buffer-create (dvc type &optional path)
|
|
"Get a buffer of type TYPE for the path PATH.
|
|
|
|
Maybe reuse one if it exists, according to the value of
|
|
`dvc-buffer-type-alist' (see its docstring), or, call
|
|
`generate-new-buffer' to create the buffer.
|
|
|
|
See also `dvc-get-buffer'"
|
|
;; Inspired from `cvs-get-buffer-create'
|
|
(let ((return-buffer
|
|
(let* ((path (or path default-directory))
|
|
(elem (assoc type dvc-buffer-type-alist))
|
|
(mode (car (cddr elem))))
|
|
(or (dvc-get-buffer dvc type path mode)
|
|
;; Buffer couldn't be reused. Create one
|
|
(let ((path (cond
|
|
((eq mode 'root)
|
|
(dvc-uniquify-file-name
|
|
(dvc-tree-root path)))
|
|
((or (eq mode 'string)
|
|
(eq mode 'string-multiple))
|
|
path)
|
|
(t (dvc-uniquify-file-name path))))
|
|
(name (concat "*" (symbol-name dvc) "-"
|
|
(cadr (assoc type dvc-buffer-type-alist)))))
|
|
(let ((buffer
|
|
(if (or (eq mode 'string)
|
|
(eq mode 'string-multiple))
|
|
(generate-new-buffer (format name path))
|
|
(let ((default-directory
|
|
(or (file-name-directory path)
|
|
default-directory)))
|
|
(dvc-create-buffer name)))))
|
|
(with-current-buffer buffer
|
|
(if (featurep 'xemacs)
|
|
(dvc-install-buffer-menu))
|
|
(dvc-buffers-tree-add dvc type path buffer)
|
|
buffer)))))))
|
|
(with-current-buffer return-buffer
|
|
;; We do not set dvc-buffer-current-active-dvc here, because any
|
|
;; subsequent mode function will call kill-all-local-variables.
|
|
(dvc-trace "create buffer %S with back-end %S in %S"
|
|
return-buffer dvc default-directory)
|
|
return-buffer)))
|
|
|
|
(defun dvc-get-matching-buffers (dvc type path)
|
|
"Return the list of all dvc-buffers-tree entries matching DVC, TYPE, PATH.
|
|
|
|
If DVC is nil, it matches any back-end. TYPE must match exactly.
|
|
PATH matches if the entry in dvc-buffers-tree is a prefix of
|
|
PATH."
|
|
(let ((result nil)
|
|
(true-path (file-truename path))
|
|
tree)
|
|
|
|
(if dvc
|
|
(setq tree (cdr (assoc type (cdr (assoc dvc dvc-buffers-tree)))))
|
|
;; flatten tree to cover all back-ends
|
|
(let ((temp dvc-buffers-tree)
|
|
buffers)
|
|
(while temp
|
|
(setq buffers (cdr (assoc type (cdar temp))))
|
|
(setq tree (append tree buffers))
|
|
(setq temp (cdr temp)))))
|
|
|
|
;; Filter for path
|
|
(while tree
|
|
(let* ((root (caar tree))
|
|
(index (string-match (regexp-quote root) true-path)))
|
|
(if (and index (= 0 index))
|
|
(setq result (cons (car tree) result)))
|
|
(setq tree (cdr tree))))
|
|
result))
|
|
|
|
(defun dvc-get-buffer (dvc type &optional path mode)
|
|
"Get a buffer of type TYPE for the path PATH.
|
|
|
|
Maybe reuse one if it exists, depending on the value of MODE (see
|
|
`dvc-buffer-type-alist' 's third element), otherwise, return nil. See
|
|
also `dvc-get-buffer-create'."
|
|
(let ((mode (or mode (car (cddr (assoc type dvc-buffer-type-alist)))))
|
|
(path (or path default-directory))
|
|
(subtree (cdr (assoc dvc dvc-buffers-tree))))
|
|
(if (eq mode 'single)
|
|
;; nothing to do about PATH. Reuse anyway
|
|
(let* ((dvc-path subtree)
|
|
(list-path (cdr (assoc type dvc-path)))
|
|
(first-elem (car list-path)))
|
|
(if list-path
|
|
(if (string= (buffer-name (cadr first-elem))
|
|
(car (cddr first-elem)))
|
|
(cadr first-elem)
|
|
(setcdr (assoc type subtree) nil)
|
|
nil)
|
|
nil))
|
|
;; not 'single
|
|
(let ((path (and path
|
|
(cond
|
|
((eq mode 'root)
|
|
(dvc-uniquify-file-name
|
|
(dvc-tree-root path)))
|
|
((or (eq mode 'string)
|
|
(eq mode 'string-multiple))
|
|
path)
|
|
(t (dvc-uniquify-file-name path))))))
|
|
(if (or (eq mode 'multiple)
|
|
(eq mode 'string-multiple))
|
|
;; no need to search an existing buffer
|
|
nil
|
|
(let* ((list-path (assoc type subtree))
|
|
(elem (assoc path (cdr list-path)))
|
|
(buffer (cadr elem)))
|
|
(when buffer
|
|
(if (buffer-live-p buffer)
|
|
;; This used to check for buffer not renamed, but
|
|
;; that conflicts with uniquify.
|
|
buffer
|
|
;; remove the buffer and try again
|
|
(setcdr list-path
|
|
(delq (assoc path (cdr list-path))
|
|
(cdr list-path)))
|
|
(dvc-get-buffer type path mode)))))))))
|
|
|
|
(defun dvc-add-buffer-type (type name)
|
|
"Define a new TYPE of buffer whose buffer will be named NAME."
|
|
(unless (assoc type dvc-buffer-type-alist)
|
|
(push (list type name) dvc-buffer-type-alist)))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Process buffers
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; TODO unify with above alist.
|
|
(defcustom dvc-process-buffer " *%s-process*"
|
|
"*Name of the process buffer."
|
|
:type 'string
|
|
:group 'dvc-internal)
|
|
|
|
(defcustom dvc-error-buffer " *%s-errors*"
|
|
"*Name of the buffer to which the process's stderr is redirected."
|
|
:type 'string
|
|
:group 'dvc-internal)
|
|
|
|
(defcustom dvc-number-of-dead-process-buffer 0
|
|
"*Number of process buffers to keep after process termination.
|
|
When the number of process buffers exceeds this number, the most ancient
|
|
is killed. This includes both the process buffer and the error
|
|
buffer (to which stderr is redirected).
|
|
|
|
A nil value here means \"Never kill any process buffer\". Useful for
|
|
debugging, but this will eat the memory of your computer ;-)"
|
|
:type 'integer
|
|
:group 'dvc-internal)
|
|
|
|
(defcustom dvc-show-internal-buffers-on-menu nil
|
|
"Toggle display of dead process buffers in the buffer menu."
|
|
:type 'boolean
|
|
:group 'dvc-internal)
|
|
|
|
(defcustom dvc-other-frame-width 80
|
|
"Width of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil."
|
|
:type 'integer
|
|
:group 'dvc)
|
|
|
|
(defcustom dvc-other-frame-height 20
|
|
"Height of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil."
|
|
:type 'integer
|
|
:group 'dvc)
|
|
|
|
(defvar dvc-dead-process-buffer-queue nil
|
|
"List of process buffers belonging to terminated processes.
|
|
When the list is greater than `dvc-number-of-dead-process-buffer', the last
|
|
ones are killed.")
|
|
|
|
(defun dvc-kill-process-buffer (buffer)
|
|
"Don't actually kill BUFFER, but add it to `dvc-dead-process-buffer-queue'.
|
|
It will eventually be killed when the number of buffers in
|
|
`dvc-dead-process-buffer-queue'exceeds `dvc-number-of-dead-process-buffer'."
|
|
(dvc-add-to-list 'dvc-dead-process-buffer-queue buffer t)
|
|
(when dvc-number-of-dead-process-buffer
|
|
(while (> (length dvc-dead-process-buffer-queue)
|
|
(max 2 dvc-number-of-dead-process-buffer))
|
|
(let ((buf (car dvc-dead-process-buffer-queue)))
|
|
(when (buffer-live-p buf) (kill-buffer buf)))
|
|
(setq dvc-dead-process-buffer-queue
|
|
(cdr dvc-dead-process-buffer-queue)))))
|
|
|
|
(defvar dvc-last-process-buffer nil
|
|
"The last created process buffer.")
|
|
|
|
(defvar dvc-last-error-buffer nil
|
|
"The last created process buffer.")
|
|
|
|
(defun dvc-new-process-buffer (to-be-deleted back-end)
|
|
"Create a new process buffer.
|
|
If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
|
|
being deleted."
|
|
(let ((buffer (generate-new-buffer
|
|
(format dvc-process-buffer
|
|
back-end))))
|
|
(setq dvc-last-process-buffer buffer)
|
|
(when to-be-deleted (dvc-kill-process-buffer buffer))
|
|
buffer))
|
|
|
|
(defun dvc-new-error-buffer (to-be-deleted back-end)
|
|
"Create a new error buffer.
|
|
If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
|
|
being deleted."
|
|
(let ((buffer (generate-new-buffer
|
|
(format dvc-error-buffer
|
|
back-end))))
|
|
(setq dvc-last-error-buffer buffer)
|
|
(when to-be-deleted (dvc-kill-process-buffer buffer))
|
|
buffer))
|
|
|
|
;;
|
|
;; Process buffer mode section
|
|
;;
|
|
(defvar dvc-process-buffer-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
|
|
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
|
|
map)
|
|
"Keymap used in dvc's log buffer.")
|
|
|
|
(define-derived-mode dvc-process-buffer-mode fundamental-mode
|
|
"DVC Process"
|
|
"Major mode for process buffers. Mainly defines \\[bury-buffer]
|
|
to quit the buffer"
|
|
(dvc-install-buffer-menu)
|
|
(toggle-read-only 1))
|
|
|
|
|
|
(defvar dvc-switched-buffer nil)
|
|
(defvar dvc-switched-from-buffer nil)
|
|
|
|
(defun dvc-switch-to-buffer (buffer &optional other-frame)
|
|
"Switch to BUFFER using the user's preferred method.
|
|
See `dvc-switch-to-buffer-mode' for possible settings."
|
|
(setq dvc-switched-from-buffer (current-buffer))
|
|
(cond
|
|
(other-frame
|
|
(let ((display-reuse-frames t)
|
|
(pop-up-frames t)
|
|
(pop-up-frame-alist `((width . ,dvc-other-frame-width)
|
|
(height . ,dvc-other-frame-height)
|
|
(minibuffer . nil))))
|
|
(pop-to-buffer buffer)))
|
|
((eq dvc-switch-to-buffer-mode 'pop-to-buffer)
|
|
(pop-to-buffer buffer))
|
|
((eq dvc-switch-to-buffer-mode 'single-window)
|
|
(switch-to-buffer buffer))
|
|
((eq dvc-switch-to-buffer-mode 'show-in-other-window)
|
|
(pop-to-buffer buffer)
|
|
(setq dvc-switched-buffer (current-buffer))
|
|
(pop-to-buffer dvc-switched-from-buffer))
|
|
(t
|
|
(error "Switch mode %s not implemented" dvc-switch-to-buffer-mode))))
|
|
|
|
(defun dvc-switch-to-buffer-maybe (buffer &optional setup-as-partner)
|
|
"Either switch to buffer BUFFER or just set-buffer.
|
|
Depends on the value of `dvc-switch-to-buffer-first'.
|
|
|
|
When SETUP-AS-PARTNER, set the `dvc-partner-buffer' variable in BUFFER to current-buffer and vice versa."
|
|
;; (message "dvc-switch-to-buffer-maybe, curr-buff: %s switch-to: %s" (current-buffer) buffer)
|
|
(when setup-as-partner
|
|
(setq dvc-partner-buffer buffer)
|
|
(let ((cur-buff (current-buffer)))
|
|
(with-current-buffer buffer
|
|
(setq dvc-partner-buffer cur-buff))))
|
|
(if dvc-switch-to-buffer-first
|
|
(dvc-switch-to-buffer buffer)
|
|
(set-buffer buffer)))
|
|
|
|
(defun dvc-post-switch-to-buffer ()
|
|
"Executed when showing a changeset.
|
|
|
|
If `dvc-switched-buffer' is non-nil, show this buffer, but keep
|
|
cursor position in previous buffer."
|
|
(when dvc-switched-buffer
|
|
(pop-to-buffer dvc-switched-buffer)
|
|
(setq dvc-switched-buffer nil)
|
|
(goto-char (point-min))
|
|
(pop-to-buffer dvc-switched-from-buffer)))
|
|
|
|
|
|
(defun dvc-show-process-buffer ()
|
|
"Show the process buffer of the last started DVC command."
|
|
(interactive)
|
|
(dvc-switch-to-buffer dvc-last-process-buffer)
|
|
(unless (member dvc-last-process-buffer
|
|
(mapcar (lambda (p)
|
|
(process-buffer (car p)))
|
|
dvc-process-running))
|
|
(dvc-process-buffer-mode)))
|
|
|
|
(defun dvc-show-last-error-buffer ()
|
|
"Show the error buffer of the last started DVC command."
|
|
(interactive)
|
|
(dvc-switch-to-buffer dvc-last-error-buffer)
|
|
(dvc-process-buffer-mode))
|
|
|
|
(defun dvc-show-last-process-buffer (&optional type mode path)
|
|
"Switch to the last used process buffer in a new buffer of TYPE.
|
|
If MODE is specified, it is a function that will be run in the
|
|
new buffer. Otherwise, the buffer will remain in fundamental mode, in
|
|
read-only.
|
|
|
|
If PATH is specified, it will be passed to `dvc-get-buffer-create'."
|
|
(when (buffer-live-p dvc-last-process-buffer)
|
|
(let ((content (with-current-buffer dvc-last-process-buffer
|
|
(buffer-string))))
|
|
(dvc-switch-to-buffer (dvc-get-buffer-create
|
|
'dvc (or type 'generic) path))
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert content)))
|
|
(if mode
|
|
(funcall mode)
|
|
(dvc-process-buffer-mode))))
|
|
|
|
(defun dvc-show-error-buffer (buffer &optional type mode)
|
|
"Pops up a new buffer displaying contents of BUFFER.
|
|
New buffer has type TYPE (default 'errors), mode MODE (default
|
|
`dvc-process-buffer-mode')."
|
|
(when (buffer-live-p buffer)
|
|
(let ((content (with-current-buffer buffer
|
|
(buffer-string))))
|
|
(dvc-switch-to-buffer (dvc-get-buffer-create
|
|
'dvc (or type 'errors)))
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert content)))
|
|
(if mode
|
|
(funcall mode)
|
|
(dvc-process-buffer-mode))))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Buffers menu
|
|
;; ----------------------------------------------------------------------------
|
|
(defun dvc-buffers-menu ()
|
|
"Return menus for buffers managed in DVC."
|
|
(let ((menu (make-sparse-keymap (concat "DVC-Buffers")))
|
|
(submenu (make-sparse-keymap "Queue"))
|
|
(i dvc-number-of-dead-process-buffer))
|
|
;; Debug QUEUE
|
|
(mapcar
|
|
(lambda (buffer)
|
|
(when (buffer-live-p buffer)
|
|
(define-key submenu (vector (make-symbol (buffer-name buffer)))
|
|
`(menu-item ,(format "%d: %s%s"
|
|
i
|
|
(if (zerop (buffer-size buffer)) "[empty] " "")
|
|
(buffer-name buffer))
|
|
(lambda () (interactive) (switch-to-buffer ,buffer))
|
|
:enable t)))
|
|
(setq i (1- i)))
|
|
dvc-dead-process-buffer-queue)
|
|
(define-key menu [queue]
|
|
`(menu-item "Queue(DEBUG)"
|
|
,submenu
|
|
:enable dvc-show-internal-buffers-on-menu))
|
|
(mapcar
|
|
(lambda (item)
|
|
(let* ((dvc (car item))
|
|
(type-list (cdr item))
|
|
(dvc-label (capitalize (symbol-name dvc)))
|
|
(submenu (make-sparse-keymap dvc-label)))
|
|
(mapcar
|
|
(lambda (type-list)
|
|
(let* ((type-label
|
|
(concat dvc-label "-"
|
|
(capitalize (symbol-name (car type-list)))))
|
|
(type-submenu (make-sparse-keymap type-label)))
|
|
(mapcar
|
|
(lambda (subitem)
|
|
(let ((path (car subitem))
|
|
(buffer (cadr subitem)))
|
|
(when (buffer-live-p buffer)
|
|
(unless path
|
|
(setq path (buffer-name buffer)))
|
|
(define-key type-submenu (vector (make-symbol path))
|
|
`(menu-item ,path
|
|
(lambda () (interactive)
|
|
(switch-to-buffer ,buffer))
|
|
:enable t)))))
|
|
(cdr type-list))
|
|
(define-key submenu (vector (car type-list))
|
|
`(menu-item ,type-label
|
|
,type-submenu
|
|
:enable t))))
|
|
type-list)
|
|
(when type-list
|
|
(define-key menu (vector dvc)
|
|
`(menu-item ,dvc-label
|
|
,submenu
|
|
:enable t))
|
|
)))
|
|
dvc-buffers-tree)
|
|
(define-key menu [list-separator]
|
|
'(menu-item "--"))
|
|
(define-key menu [process-buffer]
|
|
'(menu-item "Show Process Bufffer" dvc-show-process-buffer))
|
|
(define-key menu [error-buffer]
|
|
'(menu-item "Show Error Bufffer" dvc-show-last-error-buffer))
|
|
(define-key menu [log-buffer]
|
|
'(menu-item "Open Log Bufffer" dvc-open-internal-log-buffer))
|
|
menu))
|
|
|
|
(eval-when-compile
|
|
(unless (functionp 'add-submenu)
|
|
(defun add-submenu (&rest arg)
|
|
"Avoids a byte-compiler warning for GNU Emacs")))
|
|
|
|
(defun dvc-install-buffer-menu ()
|
|
"Install the buffer menu."
|
|
(if (featurep 'xemacs)
|
|
;; See dvc-xemacs-buffers-menu in dvc-xemacs.el
|
|
(dvc-do-in-xemacs
|
|
(add-submenu nil (list "DVC-Buffers"
|
|
:filter 'dvc-xemacs-buffers-menu) nil))
|
|
;; GNU Emacs
|
|
(dvc-do-in-gnu-emacs
|
|
(let ((dvc-menu (or (lookup-key global-map [menu-bar tools dvc])
|
|
(lookup-key global-map [menu-bar tools DVC]))))
|
|
(when (and dvc-menu (not (integerp dvc-menu)))
|
|
(define-key-after
|
|
dvc-menu
|
|
[dvc-buffers]
|
|
(cons "DVC-Buffers"
|
|
(dvc-buffers-menu)))))
|
|
(let ((map (and
|
|
(current-local-map)
|
|
(or (lookup-key (current-local-map) [menu-bar])
|
|
(define-key (current-local-map) [menu-bar]
|
|
(make-keymap))))))
|
|
(when map
|
|
(apply (if (functionp 'define-key-after)
|
|
'define-key-after
|
|
'define-key)
|
|
map
|
|
[dvc-buffers]
|
|
(cons "DVC-Buffers"
|
|
(dvc-buffers-menu))
|
|
nil)))
|
|
(add-hook 'menu-bar-update-hook 'dvc-install-buffer-menu nil t))))
|
|
|
|
(defvar dvc-buffer-previous-window-config nil
|
|
"Window-configuration to return to on buffer quit.
|
|
|
|
If nil, nothing is done special. Otherwise, must be a
|
|
window-configuration. `dvc-buffer-quit' will restore this
|
|
window-configuration.")
|
|
|
|
(make-variable-buffer-local 'dvc-buffer-previous-window-config)
|
|
|
|
;; TODO: eventually implement dvc-buffer-previous-window-config as list
|
|
;; That does not work at the moment, because it is buffer local.
|
|
;; I (Stefan) will play a bit with a global list
|
|
(defun dvc-buffer-push-previous-window-config (&optional window-config)
|
|
"Store WINDOW-CONFIG in `dvc-buffer-previous-window-config'.
|
|
When WINDOW-CONFIG is nil, store `current-window-configuration' instead."
|
|
(setq dvc-buffer-previous-window-config (or window-config (current-window-configuration))))
|
|
|
|
(defun dvc-buffer-quit ()
|
|
"Quit the current buffer.
|
|
|
|
If `dvc-buffer-quit-mode' is 'kill, then kill the buffer. Otherwise,
|
|
just bury it."
|
|
(interactive)
|
|
;; Value is buffer local => keep it before killing the buffer!
|
|
(let ((prev-wind-conf dvc-buffer-previous-window-config))
|
|
(if (eq dvc-buffer-quit-mode 'kill)
|
|
(kill-buffer (current-buffer))
|
|
(bury-buffer))
|
|
(when prev-wind-conf
|
|
(set-window-configuration prev-wind-conf))))
|
|
|
|
(defun dvc-kill-all-buffers ()
|
|
"Kill all dvc buffers."
|
|
(interactive)
|
|
(let ((number 0))
|
|
(dolist (dvc-kind dvc-buffers-tree)
|
|
(dolist (type-cons (cdr dvc-kind))
|
|
(dolist (path-buffer (cdr type-cons))
|
|
(setq number (1+ number))
|
|
(kill-buffer (cadr path-buffer)))))
|
|
(message "Killed %d buffer%s" number
|
|
(if (> number 1) "s" "")))
|
|
(setq dvc-buffers-tree nil))
|
|
|
|
(defun dvc-kill-all-type (type)
|
|
"Kill all buffers of type TYPE."
|
|
(let ((number 0))
|
|
(dolist (dvc-kind dvc-buffers-tree)
|
|
(dolist (type-cons (cdr dvc-kind))
|
|
(if (equal type (car type-cons))
|
|
(dolist (path-buffer (cdr type-cons))
|
|
(setq number (1+ number))
|
|
(kill-buffer (cadr path-buffer))))))
|
|
(message "Killed %d buffer%s" number
|
|
(if (> number 1) "s" ""))))
|
|
|
|
(defun dvc-kill-all-review ()
|
|
"Kill all buffers used in reviews; showing previous revisions."
|
|
(interactive)
|
|
(dvc-kill-all-type 'revision)
|
|
(dvc-kill-all-type 'last-revision))
|
|
|
|
(defun dvc-kill-all-workspace (workspace)
|
|
"Kill all buffers whose files are in the WORKSPACE tree."
|
|
(interactive "Dkill buffers in workspace: ")
|
|
(let ((workspace (expand-file-name workspace))
|
|
(count 0))
|
|
(dolist (buffer (buffer-list))
|
|
(let ((file-name (buffer-file-name buffer)))
|
|
(and file-name ;; some buffers don't have a file name
|
|
(string= workspace (substring file-name 0 (min (length file-name) (length workspace))))
|
|
(kill-buffer buffer)
|
|
(setq count (+ 1 count)))))
|
|
(message "killed %d buffers" count)))
|
|
|
|
(defvar dvc-save-some-buffers-ignored-modes '(dvc-log-edit-mode))
|
|
(defun dvc-save-some-buffers (&optional tree)
|
|
"Save all buffers visiting a file in TREE."
|
|
(interactive)
|
|
(let ((ok t)
|
|
(tree (or (dvc-tree-root tree t)
|
|
tree)))
|
|
(unless tree
|
|
(error "Not in a project tree"))
|
|
(dolist (buffer (buffer-list))
|
|
(with-current-buffer buffer
|
|
(when (and (buffer-modified-p) (not (member major-mode dvc-save-some-buffers-ignored-modes)))
|
|
(let ((file (buffer-file-name)))
|
|
(when file
|
|
(let ((root (dvc-uniquify-file-name
|
|
(dvc-tree-root (file-name-directory file) t)))
|
|
(tree-exp (dvc-uniquify-file-name tree)))
|
|
(when (and root
|
|
(string= root tree-exp)
|
|
;; buffer is modified and in the tree TREE.
|
|
(or dvc-do-not-prompt-for-save
|
|
(y-or-n-p (concat "Save buffer "
|
|
(buffer-name)
|
|
"? "))
|
|
(setq ok nil)))
|
|
(save-buffer))))))))
|
|
ok))
|
|
|
|
(defun dvc-revert-some-buffers (&optional tree)
|
|
"Reverts all buffers visiting a file in TREE that aren't modified.
|
|
To be run after an update or a merge."
|
|
(interactive)
|
|
(let ((tree (dvc-tree-root tree)))
|
|
(dolist (buffer (buffer-list))
|
|
(with-current-buffer buffer
|
|
(when (not (buffer-modified-p))
|
|
(let ((file (buffer-file-name)))
|
|
(when file
|
|
(let ((root (dvc-uniquify-file-name
|
|
(dvc-tree-root (file-name-directory file) t)))
|
|
(tree-exp (dvc-uniquify-file-name
|
|
(expand-file-name tree))))
|
|
(when (and (string= root tree-exp)
|
|
;; buffer is not modified and in the tree TREE.
|
|
dvc-automatically-revert-buffers)
|
|
;; Keep the buffer if the file doesn't exist
|
|
(if (file-exists-p file)
|
|
(revert-buffer t t t)))))))))))
|
|
|
|
(defun dvc-buffer-visible-p (buffer)
|
|
"Return non-nil if BUFFER is visible in frame."
|
|
(save-window-excursion
|
|
(let ((buf (current-buffer))
|
|
(window-conf (current-window-configuration)))
|
|
(pop-to-buffer buffer)
|
|
(pop-to-buffer buf)
|
|
(dvc-do-in-xemacs
|
|
(and (setq window-conf (get-buffer-window buffer))
|
|
window-conf ;; we use window-conf only to get rid of warnings
|
|
(equal (window-frame (get-buffer-window buffer))
|
|
(selected-frame))))
|
|
(dvc-do-in-gnu-emacs
|
|
(compare-window-configurations window-conf
|
|
(current-window-configuration))))))
|
|
|
|
(defun dvc-buffer-show-or-scroll (buffer &optional down)
|
|
"If BUFFER is visible, scroll it. Otherwise, show it.
|
|
|
|
if DOWN is non-nil, scroll down, otherwise, scroll up."
|
|
(if (dvc-buffer-visible-p buffer)
|
|
(progn
|
|
(pop-to-buffer buffer)
|
|
(condition-case nil
|
|
(if down
|
|
(scroll-down 2)
|
|
(save-excursion
|
|
(move-to-window-line -1)
|
|
(if (> (point-max) (point))
|
|
(scroll-up 2)
|
|
(message "end of buffer"))))
|
|
(error (message "Can't scroll anymore."))
|
|
))
|
|
(dvc-switch-to-buffer buffer)))
|
|
|
|
(provide 'dvc-buffers)
|
|
;;; dvc-buffers.el ends here
|