mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-19 10:22:27 +00:00
1434 lines
55 KiB
EmacsLisp
1434 lines
55 KiB
EmacsLisp
;;; vc-dispatcher.el -- generic command-dispatcher facility.
|
|
|
|
;; Copyright (C) 2008
|
|
;; Free Software Foundation, Inc.
|
|
|
|
;; Author: FSF (see below for full credits)
|
|
;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
|
|
;; Keywords: tools
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Credits:
|
|
|
|
;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
|
|
;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
|
|
;; vc-dir front end.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Goals:
|
|
;;
|
|
;; There is a class of front-ending problems that Emacs might be used
|
|
;; to address that involves selecting sets of files, or possibly
|
|
;; directories, and passing the selection set to slave commands. The
|
|
;; prototypical example, from which this code is derived, is talking
|
|
;; to version-control systems.
|
|
;;
|
|
;; vc-dispatcher.el is written to decouple the UI issues in such front
|
|
;; ends from their application-specific logic. It also provides a
|
|
;; service layer for running the slave commands either synchronously
|
|
;; or asynchronously and managing the message/error logs from the
|
|
;; command runs.
|
|
;;
|
|
;; Similar UI problems can be expected to come up in applications
|
|
;; areas other than VCSes; IDEs and document search are two obvious ones.
|
|
;; This mode is intended to ensure that the Emacs interfaces for all such
|
|
;; beasts are consistent and carefully designed. But even if nothing
|
|
;; but VC ever uses it, getting the layer separation right will be
|
|
;; a valuable thing.
|
|
|
|
;; Dispatcher's universe:
|
|
;;
|
|
;; The universe consists of the file tree rooted at the current
|
|
;; directory. The dispatcher's upper layer deduces some subset
|
|
;; of the file tree from the state of the currently visited buffer
|
|
;; and returns that subset, presumably to a client mode.
|
|
;;
|
|
;; The user may be looking at either of two different views; a buffer
|
|
;; visiting a file, or a directory buffer generated by vc-dispatcher.
|
|
;;
|
|
;; The lower layer of this mode runs commands in subprocesses, either
|
|
;; synchronously or asynchronously. Commands may be launched in one
|
|
;; of two ways: they may be run immediately, or the calling mode can
|
|
;; create a closure associated with a text-entry buffer, to be
|
|
;; executed when the user types C-c to ship the buffer contents. In
|
|
;; either case the command messages and error (if any) will remain
|
|
;; available in a status buffer.
|
|
|
|
;; Special behavior of dispatcher directory buffers:
|
|
;;
|
|
;; In dispatcher directory buffers, facilities to perform basic
|
|
;; navigation and selection operations are provided by keymap and menu
|
|
;; entries that dispatcher sets up itself, so they'll be uniform
|
|
;; across all dispatcher-using client modes. Client modes are
|
|
;; expected to append to these to provide mode-specific bindings.
|
|
;;
|
|
;; The standard map associates a 'state' slot (that the client mode
|
|
;; may set) with each directory entry. The dispatcher knows nothing
|
|
;; about the semantics of individual states, but mark and unmark commands
|
|
;; treat all entries with the same state as the currently selected one as
|
|
;; a unit.
|
|
|
|
;; The interface:
|
|
;;
|
|
;; The main interface to the lower level is vc-do-command. This launches a
|
|
;; command, synchronously or asynchronously, making the output available
|
|
;; in a command log buffer. Two other functions, (vc-start-annotation) and
|
|
;; (vc-finish-logentry), allow you to associate a command closure with an
|
|
;; annotation buffer so that when the user confirms the comment the closure
|
|
;; is run (with the comment as part of its context).
|
|
;;
|
|
;; The interface to the upper level has the two main entry points (vc-dir)
|
|
;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
|
|
;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
|
|
;; returns a selection set of files, either the marked files in a browsing
|
|
;; buffer or the singleton set consisting of the file visited by the current
|
|
;; buffer (when that is appropriate). It also does what is needed to ensure
|
|
;; that on-disk files and the contents of their visiting Emacs buffers
|
|
;; coincide.
|
|
;;
|
|
;; When the client mode adds a local mode-line-hook to a buffer, it
|
|
;; will be called with the buffer file name as argument whenever the
|
|
;; dispatcher resynchs the buffer.
|
|
|
|
;; To do:
|
|
;;
|
|
;; - vc-dir-kill-dir-status-process should not be specific to dir-status,
|
|
;; it should work for other async commands done through vc-do-command
|
|
;; as well,
|
|
;;
|
|
;; - log buffers need font-locking.
|
|
;;
|
|
;; - vc-dir needs mouse bindings.
|
|
;;
|
|
;; - vc-dir toolbar needs more icons.
|
|
;;
|
|
;; - vc-dir-menu-map-filter hook call needs to be moved to vc.el.
|
|
;;
|
|
|
|
(require 'ewoc)
|
|
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
;; General customization
|
|
(defcustom vc-logentry-check-hook nil
|
|
"Normal hook run by `vc-finish-logentry'.
|
|
Use this to impose your own rules on the entry in addition to any the
|
|
dispatcher client mode imposes itself."
|
|
:type 'hook
|
|
:group 'vc)
|
|
|
|
(defcustom vc-delete-logbuf-window t
|
|
"If non-nil, delete the log buffer and window after each logical action.
|
|
If nil, bury that buffer instead.
|
|
This is most useful if you have multiple windows on a frame and would like to
|
|
preserve the setting."
|
|
:type 'boolean
|
|
:group 'vc)
|
|
|
|
(defcustom vc-command-messages nil
|
|
"If non-nil, display run messages from back-end commands."
|
|
:type 'boolean
|
|
:group 'vc)
|
|
|
|
(defcustom vc-suppress-confirm nil
|
|
"If non-nil, treat user as expert; suppress yes-no prompts on some things."
|
|
:type 'boolean
|
|
:group 'vc)
|
|
|
|
;; Variables the user doesn't need to know about.
|
|
|
|
(defvar vc-log-operation nil)
|
|
(defvar vc-log-after-operation-hook nil)
|
|
(defvar vc-log-fileset)
|
|
(defvar vc-log-extra)
|
|
(defvar vc-client-mode)
|
|
|
|
;; In a log entry buffer, this is a local variable
|
|
;; that points to the buffer for which it was made
|
|
;; (either a file, or a directory buffer).
|
|
(defvar vc-parent-buffer nil)
|
|
(put 'vc-parent-buffer 'permanent-local t)
|
|
(defvar vc-parent-buffer-name nil)
|
|
(put 'vc-parent-buffer-name 'permanent-local t)
|
|
|
|
;; Common command execution logic
|
|
|
|
(defun vc-process-filter (p s)
|
|
"An alternative output filter for async process P.
|
|
One difference with the default filter is that this inserts S after markers.
|
|
Another is that undo information is not kept."
|
|
(let ((buffer (process-buffer p)))
|
|
(when (buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(save-excursion
|
|
(let ((buffer-undo-list t)
|
|
(inhibit-read-only t))
|
|
(goto-char (process-mark p))
|
|
(insert s)
|
|
(set-marker (process-mark p) (point))))))))
|
|
|
|
(defun vc-setup-buffer (buf)
|
|
"Prepare BUF for executing a slave command and make it current."
|
|
(let ((camefrom (current-buffer))
|
|
(olddir default-directory))
|
|
(set-buffer (get-buffer-create buf))
|
|
(kill-all-local-variables)
|
|
(set (make-local-variable 'vc-parent-buffer) camefrom)
|
|
(set (make-local-variable 'vc-parent-buffer-name)
|
|
(concat " from " (buffer-name camefrom)))
|
|
(setq default-directory olddir)
|
|
(let ((buffer-undo-list t)
|
|
(inhibit-read-only t))
|
|
(erase-buffer))))
|
|
|
|
(defvar vc-sentinel-movepoint) ;Dynamically scoped.
|
|
|
|
(defun vc-process-sentinel (p s)
|
|
(let ((previous (process-get p 'vc-previous-sentinel))
|
|
(buf (process-buffer p)))
|
|
;; Impatient users sometime kill "slow" buffers; check liveness
|
|
;; to avoid "error in process sentinel: Selecting deleted buffer".
|
|
(when (buffer-live-p buf)
|
|
(when previous (funcall previous p s))
|
|
(with-current-buffer buf
|
|
(setq mode-line-process
|
|
(let ((status (process-status p)))
|
|
;; Leave mode-line uncluttered, normally.
|
|
(unless (eq 'exit status)
|
|
(format " (%s)" status))))
|
|
(let (vc-sentinel-movepoint)
|
|
;; Normally, we want async code such as sentinels to not move point.
|
|
(save-excursion
|
|
(goto-char (process-mark p))
|
|
(let ((cmds (process-get p 'vc-sentinel-commands)))
|
|
(process-put p 'vc-sentinel-commands nil)
|
|
(dolist (cmd cmds)
|
|
;; Each sentinel may move point and the next one should be run
|
|
;; at that new point. We could get the same result by having
|
|
;; each sentinel read&set process-mark, but since `cmd' needs
|
|
;; to work both for async and sync processes, this would be
|
|
;; difficult to achieve.
|
|
(vc-exec-after cmd))))
|
|
;; But sometimes the sentinels really want to move point.
|
|
(when vc-sentinel-movepoint
|
|
(let ((win (get-buffer-window (current-buffer) 0)))
|
|
(if (not win)
|
|
(goto-char vc-sentinel-movepoint)
|
|
(with-selected-window win
|
|
(goto-char vc-sentinel-movepoint))))))))))
|
|
|
|
(defun vc-set-mode-line-busy-indicator ()
|
|
(setq mode-line-process
|
|
(concat " " (propertize "[waiting...]"
|
|
'face 'mode-line-emphasis
|
|
'help-echo
|
|
"A command is in progress in this buffer"))))
|
|
|
|
(defun vc-exec-after (code)
|
|
"Eval CODE when the current buffer's process is done.
|
|
If the current buffer has no process, just evaluate CODE.
|
|
Else, add CODE to the process' sentinel."
|
|
(let ((proc (get-buffer-process (current-buffer))))
|
|
(cond
|
|
;; If there's no background process, just execute the code.
|
|
;; We used to explicitly call delete-process on exited processes,
|
|
;; but this led to timing problems causing process output to be
|
|
;; lost. Terminated processes get deleted automatically
|
|
;; anyway. -- cyd
|
|
((or (null proc) (eq (process-status proc) 'exit))
|
|
;; Make sure we've read the process's output before going further.
|
|
(when proc (accept-process-output proc))
|
|
(eval code))
|
|
;; If a process is running, add CODE to the sentinel
|
|
((eq (process-status proc) 'run)
|
|
(vc-set-mode-line-busy-indicator)
|
|
(let ((previous (process-sentinel proc)))
|
|
(unless (eq previous 'vc-process-sentinel)
|
|
(process-put proc 'vc-previous-sentinel previous))
|
|
(set-process-sentinel proc 'vc-process-sentinel))
|
|
(process-put proc 'vc-sentinel-commands
|
|
;; We keep the code fragments in the order given
|
|
;; so that vc-diff-finish's message shows up in
|
|
;; the presence of non-nil vc-command-messages.
|
|
(append (process-get proc 'vc-sentinel-commands)
|
|
(list code))))
|
|
(t (error "Unexpected process state"))))
|
|
nil)
|
|
|
|
(defvar vc-post-command-functions nil
|
|
"Hook run at the end of `vc-do-command'.
|
|
Each function is called inside the buffer in which the command was run
|
|
and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
|
|
|
|
(defvar w32-quote-process-args)
|
|
|
|
(defun vc-delistify (filelist)
|
|
"Smash a FILELIST into a file list string suitable for info messages."
|
|
;; FIXME what about file names with spaces?
|
|
(if (not filelist) "." (mapconcat 'identity filelist " ")))
|
|
|
|
;;;###autoload
|
|
(defun vc-do-command (buffer okstatus command file-or-list &rest flags)
|
|
"Execute a slave command, notifying user and checking for errors.
|
|
Output from COMMAND goes to BUFFER, or the current buffer if
|
|
BUFFER is t. If the destination buffer is not already current,
|
|
set it up properly and erase it. The command is considered
|
|
successful if its exit status does not exceed OKSTATUS (if
|
|
OKSTATUS is nil, that means to ignore error status, if it is
|
|
`async', that means not to wait for termination of the
|
|
subprocess; if it is t it means to ignore all execution errors).
|
|
FILE-OR-LIST is the name of a working file; it may be a list of
|
|
files or be nil (to execute commands that don't expect a file
|
|
name or set of files). If an optional list of FLAGS is present,
|
|
that is inserted into the command line before the filename."
|
|
;; FIXME: file-relative-name can return a bogus result because
|
|
;; it doesn't look at the actual file-system to see if symlinks
|
|
;; come into play.
|
|
(let* ((files
|
|
(mapcar (lambda (f) (file-relative-name (expand-file-name f)))
|
|
(if (listp file-or-list) file-or-list (list file-or-list))))
|
|
(full-command
|
|
;; What we're doing here is preparing a version of the command
|
|
;; for display in a debug-progress message. If it's fewer than
|
|
;; 20 characters display the entire command (without trailing
|
|
;; newline). Otherwise display the first 20 followed by an ellipsis.
|
|
(concat (if (string= (substring command -1) "\n")
|
|
(substring command 0 -1)
|
|
command)
|
|
" "
|
|
(vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
|
|
" " (vc-delistify files))))
|
|
(save-current-buffer
|
|
(unless (or (eq buffer t)
|
|
(and (stringp buffer)
|
|
(string= (buffer-name) buffer))
|
|
(eq buffer (current-buffer)))
|
|
(vc-setup-buffer buffer))
|
|
;; If there's some previous async process still running, just kill it.
|
|
(let ((oldproc (get-buffer-process (current-buffer))))
|
|
;; If we wanted to wait for oldproc to finish before doing
|
|
;; something, we'd have used vc-eval-after.
|
|
;; Use `delete-process' rather than `kill-process' because we don't
|
|
;; want any of its output to appear from now on.
|
|
(if oldproc (delete-process oldproc)))
|
|
(let ((squeezed (remq nil flags))
|
|
(inhibit-read-only t)
|
|
(status 0))
|
|
(when files
|
|
(setq squeezed (nconc squeezed files)))
|
|
(let ((exec-path (append vc-path exec-path))
|
|
;; Add vc-path to PATH for the execution of this command.
|
|
(process-environment
|
|
(cons (concat "PATH=" (getenv "PATH")
|
|
path-separator
|
|
(mapconcat 'identity vc-path path-separator))
|
|
process-environment))
|
|
(w32-quote-process-args t))
|
|
(when (and (eq okstatus 'async) (file-remote-p default-directory))
|
|
;; start-process does not support remote execution
|
|
(setq okstatus nil))
|
|
(if (eq okstatus 'async)
|
|
;; Run asynchronously.
|
|
(let ((proc
|
|
(let ((process-connection-type nil))
|
|
(apply 'start-file-process command (current-buffer)
|
|
command squeezed))))
|
|
(if vc-command-messages
|
|
(message "Running %s in background..." full-command))
|
|
;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
|
|
(set-process-filter proc 'vc-process-filter)
|
|
(vc-exec-after
|
|
`(if vc-command-messages
|
|
(message "Running %s in background... done" ',full-command))))
|
|
;; Run synchronously
|
|
(when vc-command-messages
|
|
(message "Running %s in foreground..." full-command))
|
|
(let ((buffer-undo-list t))
|
|
(setq status (apply 'process-file command nil t nil squeezed)))
|
|
(when (and (not (eq t okstatus))
|
|
(or (not (integerp status))
|
|
(and okstatus (< okstatus status))))
|
|
(unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
|
|
(pop-to-buffer (current-buffer))
|
|
(goto-char (point-min))
|
|
(shrink-window-if-larger-than-buffer))
|
|
(error "Running %s...FAILED (%s)" full-command
|
|
(if (integerp status) (format "status %d" status) status))))
|
|
;; We're done. But don't emit a status message if running
|
|
;; asynchronously, it would just mislead.
|
|
(if (and vc-command-messages (not (eq okstatus 'async)))
|
|
(message "Running %s...OK = %d" full-command status)))
|
|
(vc-exec-after
|
|
`(run-hook-with-args 'vc-post-command-functions
|
|
',command ',file-or-list ',flags))
|
|
status))))
|
|
|
|
;; These functions are used to ensure that the view the user sees is up to date
|
|
;; even if the dispatcher client mode has messed with file contents (as in,
|
|
;; for example, VCS keyword expansion).
|
|
|
|
(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
|
|
|
|
(defun vc-position-context (posn)
|
|
"Save a bit of the text around POSN in the current buffer.
|
|
Used to help us find the corresponding position again later
|
|
if markers are destroyed or corrupted."
|
|
;; A lot of this was shamelessly lifted from Sebastian Kremer's
|
|
;; rcs.el mode.
|
|
(list posn
|
|
(buffer-size)
|
|
(buffer-substring posn
|
|
(min (point-max) (+ posn 100)))))
|
|
|
|
(defun vc-find-position-by-context (context)
|
|
"Return the position of CONTEXT in the current buffer.
|
|
If CONTEXT cannot be found, return nil."
|
|
(let ((context-string (nth 2 context)))
|
|
(if (equal "" context-string)
|
|
(point-max)
|
|
(save-excursion
|
|
(let ((diff (- (nth 1 context) (buffer-size))))
|
|
(when (< diff 0) (setq diff (- diff)))
|
|
(goto-char (nth 0 context))
|
|
(if (or (search-forward context-string nil t)
|
|
;; Can't use search-backward since the match may continue
|
|
;; after point.
|
|
(progn (goto-char (- (point) diff (length context-string)))
|
|
;; goto-char doesn't signal an error at
|
|
;; beginning of buffer like backward-char would
|
|
(search-forward context-string nil t)))
|
|
;; to beginning of OSTRING
|
|
(- (point) (length context-string))))))))
|
|
|
|
(defun vc-context-matches-p (posn context)
|
|
"Return t if POSN matches CONTEXT, nil otherwise."
|
|
(let* ((context-string (nth 2 context))
|
|
(len (length context-string))
|
|
(end (+ posn len)))
|
|
(if (> end (1+ (buffer-size)))
|
|
nil
|
|
(string= context-string (buffer-substring posn end)))))
|
|
|
|
(defun vc-buffer-context ()
|
|
"Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
|
|
Used by `vc-restore-buffer-context' to later restore the context."
|
|
(let ((point-context (vc-position-context (point)))
|
|
;; Use mark-marker to avoid confusion in transient-mark-mode.
|
|
(mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
|
|
(vc-position-context (mark-marker))))
|
|
;; Make the right thing happen in transient-mark-mode.
|
|
(mark-active nil))
|
|
(list point-context mark-context nil)))
|
|
|
|
(defun vc-restore-buffer-context (context)
|
|
"Restore point/mark, and reparse any affected compilation buffers.
|
|
CONTEXT is that which `vc-buffer-context' returns."
|
|
(let ((point-context (nth 0 context))
|
|
(mark-context (nth 1 context)))
|
|
;; if necessary, restore point and mark
|
|
(if (not (vc-context-matches-p (point) point-context))
|
|
(let ((new-point (vc-find-position-by-context point-context)))
|
|
(when new-point (goto-char new-point))))
|
|
(and mark-active
|
|
mark-context
|
|
(not (vc-context-matches-p (mark) mark-context))
|
|
(let ((new-mark (vc-find-position-by-context mark-context)))
|
|
(when new-mark (set-mark new-mark))))))
|
|
|
|
(defun vc-revert-buffer-internal (&optional arg no-confirm)
|
|
"Revert buffer, keeping point and mark where user expects them.
|
|
Try to be clever in the face of changes due to expanded version-control
|
|
key words. This is important for typeahead to work as expected.
|
|
ARG and NO-CONFIRM are passed on to `revert-buffer'."
|
|
(interactive "P")
|
|
(widen)
|
|
(let ((context (vc-buffer-context)))
|
|
;; Use save-excursion here, because it may be able to restore point
|
|
;; and mark properly even in cases where vc-restore-buffer-context
|
|
;; would fail. However, save-excursion might also get it wrong --
|
|
;; in this case, vc-restore-buffer-context gives it a second try.
|
|
(save-excursion
|
|
;; t means don't call normal-mode;
|
|
;; that's to preserve various minor modes.
|
|
(revert-buffer arg no-confirm t))
|
|
(vc-restore-buffer-context context)))
|
|
|
|
(defun vc-resynch-window (file &optional keep noquery)
|
|
"If FILE is in the current buffer, either revert or unvisit it.
|
|
The choice between revert (to see expanded keywords) and unvisit
|
|
depends on KEEP. NOQUERY if non-nil inhibits confirmation for
|
|
reverting. NOQUERY should be t *only* if it is known the only
|
|
difference between the buffer and the file is due to
|
|
modifications by the dispatcher client code, rather than user
|
|
editing!"
|
|
(and (string= buffer-file-name file)
|
|
(if keep
|
|
(progn
|
|
(vc-revert-buffer-internal t noquery)
|
|
;; TODO: Adjusting view mode might no longer be necessary
|
|
;; after RMS change to files.el of 1999-08-08. Investigate
|
|
;; this when we install the new VC.
|
|
(and view-read-only
|
|
(if (file-writable-p file)
|
|
(and view-mode
|
|
(let ((view-old-buffer-read-only nil))
|
|
(view-mode-exit)))
|
|
(and (not view-mode)
|
|
(not (eq (get major-mode 'mode-class) 'special))
|
|
(view-mode-enter))))
|
|
(run-hook-with-args 'mode-line-hook buffer-file-name))
|
|
(kill-buffer (current-buffer)))))
|
|
|
|
(defun vc-resynch-buffer (file &optional keep noquery)
|
|
"If FILE is currently visited, resynch its buffer."
|
|
(if (string= buffer-file-name file)
|
|
(vc-resynch-window file keep noquery)
|
|
(let ((buffer (get-file-buffer file)))
|
|
(when buffer
|
|
(with-current-buffer buffer
|
|
(vc-resynch-window file keep noquery)))))
|
|
;; Try to avoid unnecessary work, a *vc-dir* buffer is only present
|
|
;; if this is true.
|
|
(when (memq 'vc-dir-resynch-file after-save-hook)
|
|
(vc-dir-resynch-file file)))
|
|
|
|
(defun vc-buffer-sync (&optional not-urgent)
|
|
"Make sure the current buffer and its working file are in sync.
|
|
NOT-URGENT means it is ok to continue if the user says not to save."
|
|
(when (buffer-modified-p)
|
|
(if (or vc-suppress-confirm
|
|
(y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
|
|
(save-buffer)
|
|
(unless not-urgent
|
|
(error "Aborted")))))
|
|
|
|
;; Command closures
|
|
|
|
;; Set up key bindings for use while editing log messages
|
|
|
|
(defun vc-log-edit (fileset)
|
|
"Set up `log-edit' for use on FILE."
|
|
(setq default-directory
|
|
(with-current-buffer vc-parent-buffer default-directory))
|
|
(log-edit 'vc-finish-logentry
|
|
nil
|
|
`((log-edit-listfun . (lambda () ',fileset))
|
|
(log-edit-diff-function . (lambda () (vc-diff nil)))))
|
|
(set (make-local-variable 'vc-log-fileset) fileset)
|
|
(make-local-variable 'vc-log-extra)
|
|
(set-buffer-modified-p nil)
|
|
(setq buffer-file-name nil))
|
|
|
|
(defun vc-start-logentry (files extra comment initial-contents msg logbuf action &optional after-hook)
|
|
"Accept a comment for an operation on FILES with extra data EXTRA.
|
|
If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the
|
|
action on close to ACTION. If COMMENT is a string and
|
|
INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
|
|
contents of the log entry buffer. If COMMENT is a string and
|
|
INITIAL-CONTENTS is nil, do action immediately as if the user had
|
|
entered COMMENT. If COMMENT is t, also do action immediately with an
|
|
empty comment. Remember the file's buffer in `vc-parent-buffer'
|
|
\(current one if no file). AFTER-HOOK specifies the local value
|
|
for `vc-log-after-operation-hook'."
|
|
(let ((parent
|
|
(if (vc-dispatcher-browsing)
|
|
;; If we are called from a directory browser, the parent buffer is
|
|
;; the current buffer.
|
|
(current-buffer)
|
|
(if (and files (equal (length files) 1))
|
|
(get-file-buffer (car files))
|
|
(current-buffer)))))
|
|
(if (and comment (not initial-contents))
|
|
(set-buffer (get-buffer-create logbuf))
|
|
(pop-to-buffer (get-buffer-create logbuf)))
|
|
(set (make-local-variable 'vc-parent-buffer) parent)
|
|
(set (make-local-variable 'vc-parent-buffer-name)
|
|
(concat " from " (buffer-name vc-parent-buffer)))
|
|
(vc-log-edit files)
|
|
(make-local-variable 'vc-log-after-operation-hook)
|
|
(when after-hook
|
|
(setq vc-log-after-operation-hook after-hook))
|
|
(setq vc-log-operation action)
|
|
(setq vc-log-extra extra)
|
|
(when comment
|
|
(erase-buffer)
|
|
(when (stringp comment) (insert comment)))
|
|
(if (or (not comment) initial-contents)
|
|
(message "%s Type C-c C-c when done" msg)
|
|
(vc-finish-logentry (eq comment t)))))
|
|
|
|
(defun vc-finish-logentry (&optional nocomment)
|
|
"Complete the operation implied by the current log entry.
|
|
Use the contents of the current buffer as a check-in or registration
|
|
comment. If the optional arg NOCOMMENT is non-nil, then don't check
|
|
the buffer contents as a comment."
|
|
(interactive)
|
|
;; Check and record the comment, if any.
|
|
(unless nocomment
|
|
(run-hooks 'vc-logentry-check-hook))
|
|
;; Sync parent buffer in case the user modified it while editing the comment.
|
|
;; But not if it is a vc-dir buffer.
|
|
(with-current-buffer vc-parent-buffer
|
|
(or (vc-dispatcher-browsing) (vc-buffer-sync)))
|
|
(unless vc-log-operation
|
|
(error "No log operation is pending"))
|
|
;; save the parameters held in buffer-local variables
|
|
(let ((logbuf (current-buffer))
|
|
(log-operation vc-log-operation)
|
|
(log-fileset vc-log-fileset)
|
|
(log-extra vc-log-extra)
|
|
(log-entry (buffer-string))
|
|
(after-hook vc-log-after-operation-hook)
|
|
(tmp-vc-parent-buffer vc-parent-buffer))
|
|
(pop-to-buffer vc-parent-buffer)
|
|
;; OK, do it to it
|
|
(save-excursion
|
|
(funcall log-operation
|
|
log-fileset
|
|
log-extra
|
|
log-entry))
|
|
;; Remove checkin window (after the checkin so that if that fails
|
|
;; we don't zap the log buffer and the typing therein).
|
|
;; -- IMO this should be replaced with quit-window
|
|
(cond ((and logbuf vc-delete-logbuf-window)
|
|
(delete-windows-on logbuf (selected-frame))
|
|
;; Kill buffer and delete any other dedicated windows/frames.
|
|
(kill-buffer logbuf))
|
|
(logbuf (pop-to-buffer logbuf)
|
|
(bury-buffer)
|
|
(pop-to-buffer tmp-vc-parent-buffer)))
|
|
;; Now make sure we see the expanded headers
|
|
(when log-fileset
|
|
(mapc
|
|
(lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
|
|
log-fileset))
|
|
(when (vc-dispatcher-browsing)
|
|
(vc-dir-move-to-goal-column))
|
|
(run-hooks after-hook 'vc-finish-logentry-hook)))
|
|
|
|
;; The ewoc-based vc-directory implementation
|
|
|
|
(defcustom vc-dir-mode-hook nil
|
|
"Normal hook run by `vc-dir-mode'.
|
|
See `run-hooks'."
|
|
:type 'hook
|
|
:group 'vc)
|
|
|
|
;; Used to store information for the files displayed in the directory buffer.
|
|
;; Each item displayed corresponds to one of these defstructs.
|
|
(defstruct (vc-dir-fileinfo
|
|
(:copier nil)
|
|
(:type list) ;So we can use `member' on lists of FIs.
|
|
(:constructor
|
|
;; We could define it as an alias for `list'.
|
|
vc-dir-create-fileinfo (name state &optional extra marked directory))
|
|
(:conc-name vc-dir-fileinfo->))
|
|
name ;Keep it as first, for `member'.
|
|
state
|
|
;; For storing client-mode specific information.
|
|
extra
|
|
marked
|
|
;; To keep track of not updated files during a global refresh
|
|
needs-update
|
|
;; To distinguish files and directories.
|
|
directory)
|
|
|
|
;; Used to describe a dispatcher client mode.
|
|
(defstruct (vc-client-object
|
|
(:copier nil)
|
|
(:constructor
|
|
vc-create-client-object (name
|
|
headers
|
|
file-to-info
|
|
file-to-state
|
|
file-to-extra
|
|
updater
|
|
extra-menu))
|
|
(:conc-name vc-client-object->))
|
|
name
|
|
headers
|
|
file-to-info
|
|
file-to-state
|
|
file-to-extra
|
|
updater
|
|
extra-menu)
|
|
|
|
(defvar vc-ewoc nil)
|
|
(defvar vc-dir-process-buffer nil
|
|
"The buffer used for the asynchronous call that computes status.")
|
|
|
|
(defun vc-dir-move-to-goal-column ()
|
|
;; Used to keep the cursor on the file name column.
|
|
(beginning-of-line)
|
|
;; Must be in sync with vc-default-status-printer.
|
|
(forward-char 25))
|
|
|
|
(defun vc-dir-prepare-status-buffer (bname dir &optional create-new)
|
|
"Find a buffer named BNAME showing DIR, or create a new one."
|
|
(setq dir (expand-file-name dir))
|
|
(let*
|
|
;; Look for another buffer name BNAME visiting the same directory.
|
|
((buf (save-excursion
|
|
(unless create-new
|
|
(dolist (buffer (buffer-list))
|
|
(set-buffer buffer)
|
|
(when (and (vc-dispatcher-browsing)
|
|
(string= (expand-file-name default-directory) dir))
|
|
(return buffer)))))))
|
|
(or buf
|
|
;; Create a new buffer named BNAME.
|
|
(with-current-buffer (create-file-buffer bname)
|
|
(cd dir)
|
|
(vc-setup-buffer (current-buffer))
|
|
;; Reset the vc-parent-buffer-name so that it does not appear
|
|
;; in the mode-line.
|
|
(setq vc-parent-buffer-name nil)
|
|
(current-buffer)))))
|
|
|
|
(defvar vc-dir-menu-map
|
|
(let ((map (make-sparse-keymap "VC-dir")))
|
|
(define-key map [quit]
|
|
'(menu-item "Quit" quit-window
|
|
:help "Quit"))
|
|
(define-key map [kill]
|
|
'(menu-item "Kill Update Command" vc-dir-kill-dir-status-process
|
|
:enable (vc-dir-busy)
|
|
:help "Kill the command that updates the directory buffer"))
|
|
(define-key map [refresh]
|
|
'(menu-item "Refresh" vc-dir-refresh
|
|
:enable (not (vc-dir-busy))
|
|
:help "Refresh the contents of the directory buffer"))
|
|
;; Movement.
|
|
(define-key map [sepmv] '("--"))
|
|
(define-key map [next-line]
|
|
'(menu-item "Next line" vc-dir-next-line
|
|
:help "Go to the next line" :keys "n"))
|
|
(define-key map [previous-line]
|
|
'(menu-item "Previous line" vc-dir-previous-line
|
|
:help "Go to the previous line"))
|
|
;; Marking.
|
|
(define-key map [sepmrk] '("--"))
|
|
(define-key map [unmark-all]
|
|
'(menu-item "Unmark All" vc-dir-unmark-all-files
|
|
:help "Unmark all files that are in the same state as the current file\
|
|
\nWith prefix argument unmark all files"))
|
|
(define-key map [unmark-previous]
|
|
'(menu-item "Unmark previous " vc-dir-unmark-file-up
|
|
:help "Move to the previous line and unmark the file"))
|
|
|
|
(define-key map [mark-all]
|
|
'(menu-item "Mark All" vc-dir-mark-all-files
|
|
:help "Mark all files that are in the same state as the current file\
|
|
\nWith prefix argument mark all files"))
|
|
(define-key map [unmark]
|
|
'(menu-item "Unmark" vc-dir-unmark
|
|
:help "Unmark the current file or all files in the region"))
|
|
|
|
(define-key map [mark]
|
|
'(menu-item "Mark" vc-dir-mark
|
|
:help "Mark the current file or all files in the region"))
|
|
|
|
(define-key map [sepopn] '("--"))
|
|
(define-key map [open-other]
|
|
'(menu-item "Open in other window" vc-dir-find-file-other-window
|
|
:help "Find the file on the current line, in another window"))
|
|
(define-key map [open]
|
|
'(menu-item "Open file" vc-dir-find-file
|
|
:help "Find the file on the current line"))
|
|
map)
|
|
"Menu for dispatcher status")
|
|
|
|
;; This is used so that client modes can add mode-specific menu
|
|
;; items to vc-dir-menu-map.
|
|
(defun vc-dir-menu-map-filter (orig-binding)
|
|
(when (and (symbolp orig-binding) (fboundp orig-binding))
|
|
(setq orig-binding (indirect-function orig-binding)))
|
|
(let ((ext-binding
|
|
;; This may be executed at load-time for tool-bar-local-item-from-menu
|
|
;; but at that time vc-client-mode is not known (or even bound) yet.
|
|
(when (and (boundp 'vc-client-mode) vc-client-mode)
|
|
(funcall (vc-client-object->extra-menu vc-client-mode)))))
|
|
(if (null ext-binding)
|
|
orig-binding
|
|
(append orig-binding
|
|
'("----")
|
|
ext-binding))))
|
|
|
|
(defvar vc-dir-mode-map
|
|
(let ((map (make-keymap)))
|
|
(suppress-keymap map)
|
|
;; Marking.
|
|
(define-key map "m" 'vc-dir-mark)
|
|
(define-key map "M" 'vc-dir-mark-all-files)
|
|
(define-key map "u" 'vc-dir-unmark)
|
|
(define-key map "U" 'vc-dir-unmark-all-files)
|
|
(define-key map "\C-?" 'vc-dir-unmark-file-up)
|
|
(define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
|
|
;; Movement.
|
|
(define-key map "n" 'vc-dir-next-line)
|
|
(define-key map " " 'vc-dir-next-line)
|
|
(define-key map "\t" 'vc-dir-next-directory)
|
|
(define-key map "p" 'vc-dir-previous-line)
|
|
(define-key map [backtab] 'vc-dir-previous-directory)
|
|
;;; Rebind paragraph-movement commands.
|
|
(define-key map "\M-}" 'vc-dir-next-directory)
|
|
(define-key map "\M-{" 'vc-dir-previous-directory)
|
|
(define-key map [C-down] 'vc-dir-next-directory)
|
|
(define-key map [C-up] 'vc-dir-previous-directory)
|
|
;; The remainder.
|
|
(define-key map "f" 'vc-dir-find-file)
|
|
(define-key map "\C-m" 'vc-dir-find-file)
|
|
(define-key map "o" 'vc-dir-find-file-other-window)
|
|
(define-key map "q" 'quit-window)
|
|
(define-key map "g" 'vc-dir-refresh)
|
|
(define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
|
|
(define-key map [down-mouse-3] 'vc-dir-menu)
|
|
(define-key map [mouse-2] 'vc-dir-toggle-mark)
|
|
|
|
;; Hook up the menu.
|
|
(define-key map [menu-bar vc-dir-mode]
|
|
`(menu-item
|
|
;; This is used so that client modes can add mode-specific
|
|
;; menu items to vc-dir-menu-map.
|
|
"VC-dir" ,vc-dir-menu-map :filter vc-dir-menu-map-filter))
|
|
map)
|
|
"Keymap for directory buffer.")
|
|
|
|
(defmacro vc-at-event (event &rest body)
|
|
"Evaluate `body' with point located at event-start of `event'.
|
|
If `body' uses `event', it should be a variable,
|
|
otherwise it will be evaluated twice."
|
|
(let ((posn (make-symbol "vc-at-event-posn")))
|
|
`(let ((,posn (event-start ,event)))
|
|
(save-excursion
|
|
(set-buffer (window-buffer (posn-window ,posn)))
|
|
(goto-char (posn-point ,posn))
|
|
,@body))))
|
|
|
|
(defun vc-dir-menu (e)
|
|
"Popup the dispatcher status menu."
|
|
(interactive "e")
|
|
(vc-at-event e (popup-menu vc-dir-menu-map e)))
|
|
|
|
(defvar vc-dir-tool-bar-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(tool-bar-local-item-from-menu 'vc-dir-find-file "open"
|
|
map vc-dir-mode-map)
|
|
(tool-bar-local-item "bookmark_add"
|
|
'vc-dir-toggle-mark 'vc-dir-toggle-mark map
|
|
:help "Toggle mark on current item")
|
|
(tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
|
|
map vc-dir-mode-map
|
|
:rtl "right-arrow")
|
|
(tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow"
|
|
map vc-dir-mode-map
|
|
:rtl "left-arrow")
|
|
(tool-bar-local-item-from-menu 'vc-print-log "info"
|
|
map vc-dir-mode-map)
|
|
(tool-bar-local-item-from-menu 'vc-dir-refresh "refresh"
|
|
map vc-dir-mode-map)
|
|
(tool-bar-local-item-from-menu 'nonincremental-search-forward
|
|
"search" map)
|
|
(tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
|
|
map vc-dir-mode-map)
|
|
(tool-bar-local-item-from-menu 'quit-window "exit"
|
|
map vc-dir-mode-map)
|
|
map))
|
|
|
|
(defun vc-dir-node-directory (node)
|
|
;; Compute the directory for NODE.
|
|
;; If it's a directory node, get it from the the node.
|
|
(let ((data (ewoc-data node)))
|
|
(or (vc-dir-fileinfo->directory data)
|
|
;; Otherwise compute it from the file name.
|
|
(file-name-directory
|
|
(expand-file-name
|
|
(vc-dir-fileinfo->name data))))))
|
|
|
|
(defun vc-dir-update (entries buffer &optional noinsert)
|
|
"Update BUFFER's ewoc from the list of ENTRIES.
|
|
If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
|
|
;; Add ENTRIES to the vc-dir buffer BUFFER.
|
|
(with-current-buffer buffer
|
|
;; Insert the entries sorted by name into the ewoc.
|
|
;; We assume the ewoc is sorted too, which should be the
|
|
;; case if we always add entries with vc-dir-update.
|
|
(setq entries
|
|
;; Sort: first files and then subdirectories.
|
|
;; XXX: this is VERY inefficient, it computes the directory
|
|
;; names too many times
|
|
(sort entries
|
|
(lambda (entry1 entry2)
|
|
(let ((dir1 (file-name-directory (expand-file-name (car entry1))))
|
|
(dir2 (file-name-directory (expand-file-name (car entry2)))))
|
|
(cond
|
|
((string< dir1 dir2) t)
|
|
((not (string= dir1 dir2)) nil)
|
|
((string< (car entry1) (car entry2))))))))
|
|
;; Insert directory entries in the right places.
|
|
(let ((entry (car entries))
|
|
(node (ewoc-nth vc-ewoc 0)))
|
|
;; Insert . if it is not present.
|
|
(unless node
|
|
(let ((rd (file-relative-name default-directory)))
|
|
(ewoc-enter-last
|
|
vc-ewoc (vc-dir-create-fileinfo
|
|
rd nil nil nil (expand-file-name default-directory))))
|
|
(setq node (ewoc-nth vc-ewoc 0)))
|
|
|
|
(while (and entry node)
|
|
(let* ((entryfile (car entry))
|
|
(entrydir (file-name-directory (expand-file-name entryfile)))
|
|
(nodedir (vc-dir-node-directory node)))
|
|
(cond
|
|
;; First try to find the directory.
|
|
((string-lessp nodedir entrydir)
|
|
(setq node (ewoc-next vc-ewoc node)))
|
|
((string-equal nodedir entrydir)
|
|
;; Found the directory, find the place for the file name.
|
|
(let ((nodefile (vc-dir-fileinfo->name (ewoc-data node))))
|
|
(cond
|
|
((string-lessp nodefile entryfile)
|
|
(setq node (ewoc-next vc-ewoc node)))
|
|
((string-equal nodefile entryfile)
|
|
(setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
|
|
(setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
|
|
(setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
|
|
(ewoc-invalidate vc-ewoc node)
|
|
(setq entries (cdr entries))
|
|
(setq entry (car entries))
|
|
(setq node (ewoc-next vc-ewoc node)))
|
|
(t
|
|
(ewoc-enter-before vc-ewoc node
|
|
(apply 'vc-dir-create-fileinfo entry))
|
|
(setq entries (cdr entries))
|
|
(setq entry (car entries))))))
|
|
(t
|
|
;; We might need to insert a directory node if the
|
|
;; previous node was in a different directory.
|
|
(let* ((rd (file-relative-name entrydir))
|
|
(prev-node (ewoc-prev vc-ewoc node))
|
|
(prev-dir (vc-dir-node-directory prev-node)))
|
|
(unless (string-equal entrydir prev-dir)
|
|
(ewoc-enter-before
|
|
vc-ewoc node (vc-dir-create-fileinfo rd nil nil nil entrydir))))
|
|
;; Now insert the node itself.
|
|
(ewoc-enter-before vc-ewoc node
|
|
(apply 'vc-dir-create-fileinfo entry))
|
|
(setq entries (cdr entries) entry (car entries))))))
|
|
;; We're past the last node, all remaining entries go to the end.
|
|
(unless (or node noinsert)
|
|
(let ((lastdir (vc-dir-node-directory (ewoc-nth vc-ewoc -1))))
|
|
(dolist (entry entries)
|
|
(let ((entrydir (file-name-directory (expand-file-name (car entry)))))
|
|
;; Insert a directory node if needed.
|
|
(unless (string-equal lastdir entrydir)
|
|
(setq lastdir entrydir)
|
|
(let ((rd (file-relative-name entrydir)))
|
|
(ewoc-enter-last
|
|
vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))))
|
|
;; Now insert the node itself.
|
|
(ewoc-enter-last vc-ewoc
|
|
(apply 'vc-dir-create-fileinfo entry)))))))))
|
|
|
|
(defun vc-dir-busy ()
|
|
(and (buffer-live-p vc-dir-process-buffer)
|
|
(get-buffer-process vc-dir-process-buffer)))
|
|
|
|
(defun vc-dir-kill-dir-status-process ()
|
|
"Kill the temporary buffer and associated process."
|
|
(interactive)
|
|
(when (buffer-live-p vc-dir-process-buffer)
|
|
(let ((proc (get-buffer-process vc-dir-process-buffer)))
|
|
(when proc (delete-process proc))
|
|
(setq vc-dir-process-buffer nil)
|
|
(setq mode-line-process nil))))
|
|
|
|
(defun vc-dir-kill-query ()
|
|
;; Make sure that when the status buffer is killed the update
|
|
;; process running in background is also killed.
|
|
(if (vc-dir-busy)
|
|
(when (y-or-n-p "Status update process running, really kill status buffer?")
|
|
(vc-dir-kill-dir-status-process)
|
|
t)
|
|
t))
|
|
|
|
(defun vc-dir-next-line (arg)
|
|
"Go to the next line.
|
|
If a prefix argument is given, move by that many lines."
|
|
(interactive "p")
|
|
(with-no-warnings
|
|
(ewoc-goto-next vc-ewoc arg)
|
|
(vc-dir-move-to-goal-column)))
|
|
|
|
(defun vc-dir-previous-line (arg)
|
|
"Go to the previous line.
|
|
If a prefix argument is given, move by that many lines."
|
|
(interactive "p")
|
|
(ewoc-goto-prev vc-ewoc arg)
|
|
(vc-dir-move-to-goal-column))
|
|
|
|
(defun vc-dir-next-directory ()
|
|
"Go to the next directory."
|
|
(interactive)
|
|
(let ((orig (point)))
|
|
(if
|
|
(catch 'foundit
|
|
(while t
|
|
(let* ((next (ewoc-next vc-ewoc (ewoc-locate vc-ewoc))))
|
|
(cond ((not next)
|
|
(throw 'foundit t))
|
|
(t
|
|
(progn
|
|
(ewoc-goto-node vc-ewoc next)
|
|
(vc-dir-move-to-goal-column)
|
|
(if (vc-dir-fileinfo->directory (ewoc-data next))
|
|
(throw 'foundit nil))))))))
|
|
(goto-char orig))))
|
|
|
|
(defun vc-dir-previous-directory ()
|
|
"Go to the previous directory."
|
|
(interactive)
|
|
(let ((orig (point)))
|
|
(if
|
|
(catch 'foundit
|
|
(while t
|
|
(let* ((prev (ewoc-prev vc-ewoc (ewoc-locate vc-ewoc))))
|
|
(cond ((not prev)
|
|
(throw 'foundit t))
|
|
(t
|
|
(progn
|
|
(ewoc-goto-node vc-ewoc prev)
|
|
(vc-dir-move-to-goal-column)
|
|
(if (vc-dir-fileinfo->directory (ewoc-data prev))
|
|
(throw 'foundit nil))))))))
|
|
(goto-char orig))))
|
|
|
|
(defun vc-dir-mark-unmark (mark-unmark-function)
|
|
(if (use-region-p)
|
|
(let ((firstl (line-number-at-pos (region-beginning)))
|
|
(lastl (line-number-at-pos (region-end))))
|
|
(save-excursion
|
|
(goto-char (region-beginning))
|
|
(while (<= (line-number-at-pos) lastl)
|
|
(funcall mark-unmark-function))))
|
|
(funcall mark-unmark-function)))
|
|
|
|
(defun vc-string-prefix-p (prefix string)
|
|
(let ((lpref (length prefix)))
|
|
(and (>= (length string) lpref)
|
|
(eq t (compare-strings prefix nil nil string nil lpref)))))
|
|
|
|
(defun vc-dir-parent-marked-p (arg)
|
|
;; Return nil if none of the parent directories of arg is marked.
|
|
(let* ((argdir (vc-dir-node-directory arg))
|
|
(arglen (length argdir))
|
|
(crt arg)
|
|
data dir)
|
|
;; Go through the predecessors, checking if any directory that is
|
|
;; a parent is marked.
|
|
(while (setq crt (ewoc-prev vc-ewoc crt))
|
|
(setq data (ewoc-data crt))
|
|
(setq dir (vc-dir-node-directory crt))
|
|
(when (and (vc-dir-fileinfo->directory data)
|
|
(vc-string-prefix-p dir argdir))
|
|
(when (vc-dir-fileinfo->marked data)
|
|
(error "Cannot mark `%s', parent directory `%s' marked"
|
|
(vc-dir-fileinfo->name (ewoc-data arg))
|
|
(vc-dir-fileinfo->name data)))))
|
|
nil))
|
|
|
|
(defun vc-dir-children-marked-p (arg)
|
|
;; Return nil if none of the children of arg is marked.
|
|
(let* ((argdir (vc-dir-node-directory arg))
|
|
(arglen (length argdir))
|
|
(is-child t)
|
|
(crt arg)
|
|
data dir)
|
|
(while (and is-child (setq crt (ewoc-next vc-ewoc crt)))
|
|
(setq data (ewoc-data crt))
|
|
(setq dir (vc-dir-node-directory crt))
|
|
(if (string-equal argdir (substring dir 0 arglen))
|
|
(when (vc-dir-fileinfo->marked data)
|
|
(error "Cannot mark `%s', child `%s' marked"
|
|
(vc-dir-fileinfo->name (ewoc-data arg))
|
|
(vc-dir-fileinfo->name data)))
|
|
;; We are done, we got to an entry that is not a child of `arg'.
|
|
(setq is-child nil)))
|
|
nil))
|
|
|
|
(defun vc-dir-mark-file (&optional arg)
|
|
;; Mark ARG or the current file and move to the next line.
|
|
(let* ((crt (or arg (ewoc-locate vc-ewoc)))
|
|
(file (ewoc-data crt))
|
|
(isdir (vc-dir-fileinfo->directory file)))
|
|
(when (or (and isdir (not (vc-dir-children-marked-p crt)))
|
|
(and (not isdir) (not (vc-dir-parent-marked-p crt))))
|
|
(setf (vc-dir-fileinfo->marked file) t)
|
|
(ewoc-invalidate vc-ewoc crt)
|
|
(unless (or arg (mouse-event-p last-command-event))
|
|
(vc-dir-next-line 1)))))
|
|
|
|
(defun vc-dir-mark ()
|
|
"Mark the current file or all files in the region.
|
|
If the region is active, mark all the files in the region.
|
|
Otherwise mark the file on the current line and move to the next
|
|
line."
|
|
(interactive)
|
|
(vc-dir-mark-unmark 'vc-dir-mark-file))
|
|
|
|
(defun vc-dir-mark-all-files (arg)
|
|
"Mark all files with the same state as the current one.
|
|
With a prefix argument mark all files.
|
|
If the current entry is a directory, mark all child files.
|
|
|
|
The commands operate on files that are on the same state.
|
|
This command is intended to make it easy to select all files that
|
|
share the same state."
|
|
(interactive "P")
|
|
(if arg
|
|
;; Mark all files.
|
|
(progn
|
|
;; First check that no directory is marked, we can't mark
|
|
;; files in that case.
|
|
(ewoc-map
|
|
(lambda (filearg)
|
|
(when (and (vc-dir-fileinfo->directory filearg)
|
|
(vc-dir-fileinfo->marked filearg))
|
|
(error "Cannot mark all files, directory `%s' marked"
|
|
(vc-dir-fileinfo->name filearg))))
|
|
vc-ewoc)
|
|
(ewoc-map
|
|
(lambda (filearg)
|
|
(unless (vc-dir-fileinfo->marked filearg)
|
|
(setf (vc-dir-fileinfo->marked filearg) t)
|
|
t))
|
|
vc-ewoc))
|
|
(let ((data (ewoc-data (ewoc-locate vc-ewoc))))
|
|
(if (vc-dir-fileinfo->directory data)
|
|
;; It's a directory, mark child files.
|
|
(let ((crt (ewoc-locate vc-ewoc)))
|
|
(unless (vc-dir-children-marked-p crt)
|
|
(while (setq crt (ewoc-next vc-ewoc crt))
|
|
(let ((crt-data (ewoc-data crt)))
|
|
(unless (vc-dir-fileinfo->directory crt-data)
|
|
(setf (vc-dir-fileinfo->marked crt-data) t)
|
|
(ewoc-invalidate vc-ewoc crt))))))
|
|
;; It's a file
|
|
(let ((state (vc-dir-fileinfo->state data))
|
|
(crt (ewoc-nth vc-ewoc 0)))
|
|
(while crt
|
|
(let ((crt-data (ewoc-data crt)))
|
|
(when (and (not (vc-dir-fileinfo->marked crt-data))
|
|
(eq (vc-dir-fileinfo->state crt-data) state)
|
|
(not (vc-dir-fileinfo->directory crt-data)))
|
|
(vc-dir-mark-file crt)))
|
|
(setq crt (ewoc-next vc-ewoc crt))))))))
|
|
|
|
(defun vc-dir-unmark-file ()
|
|
;; Unmark the current file and move to the next line.
|
|
(let* ((crt (ewoc-locate vc-ewoc))
|
|
(file (ewoc-data crt)))
|
|
(setf (vc-dir-fileinfo->marked file) nil)
|
|
(ewoc-invalidate vc-ewoc crt)
|
|
(unless (mouse-event-p last-command-event)
|
|
(vc-dir-next-line 1))))
|
|
|
|
(defun vc-dir-unmark ()
|
|
"Unmark the current file or all files in the region.
|
|
If the region is active, unmark all the files in the region.
|
|
Otherwise mark the file on the current line and move to the next
|
|
line."
|
|
(interactive)
|
|
(vc-dir-mark-unmark 'vc-dir-unmark-file))
|
|
|
|
(defun vc-dir-unmark-file-up ()
|
|
"Move to the previous line and unmark the file."
|
|
(interactive)
|
|
;; If we're on the first line, we won't move up, but we will still
|
|
;; remove the mark. This seems a bit odd but it is what buffer-menu
|
|
;; does.
|
|
(let* ((prev (ewoc-goto-prev vc-ewoc 1))
|
|
(file (ewoc-data prev)))
|
|
(setf (vc-dir-fileinfo->marked file) nil)
|
|
(ewoc-invalidate vc-ewoc prev)
|
|
(vc-dir-move-to-goal-column)))
|
|
|
|
(defun vc-dir-unmark-all-files (arg)
|
|
"Unmark all files with the same state as the current one.
|
|
With a prefix argument unmark all files.
|
|
If the current entry is a directory, unmark all the child files.
|
|
|
|
The commands operate on files that are on the same state.
|
|
This command is intended to make it easy to deselect all files
|
|
that share the same state."
|
|
(interactive "P")
|
|
(if arg
|
|
(ewoc-map
|
|
(lambda (filearg)
|
|
(when (vc-dir-fileinfo->marked filearg)
|
|
(setf (vc-dir-fileinfo->marked filearg) nil)
|
|
t))
|
|
vc-ewoc)
|
|
(let* ((crt (ewoc-locate vc-ewoc))
|
|
(data (ewoc-data crt)))
|
|
(if (vc-dir-fileinfo->directory data)
|
|
;; It's a directory, unmark child files.
|
|
(while (setq crt (ewoc-next vc-ewoc crt))
|
|
(let ((crt-data (ewoc-data crt)))
|
|
(unless (vc-dir-fileinfo->directory crt-data)
|
|
(setf (vc-dir-fileinfo->marked crt-data) nil)
|
|
(ewoc-invalidate vc-ewoc crt))))
|
|
;; It's a file
|
|
(let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt))))
|
|
(ewoc-map
|
|
(lambda (filearg)
|
|
(when (and (vc-dir-fileinfo->marked filearg)
|
|
(eq (vc-dir-fileinfo->state filearg) crt-state))
|
|
(setf (vc-dir-fileinfo->marked filearg) nil)
|
|
t))
|
|
vc-ewoc))))))
|
|
|
|
(defun vc-dir-toggle-mark-file ()
|
|
(let* ((crt (ewoc-locate vc-ewoc))
|
|
(file (ewoc-data crt)))
|
|
(if (vc-dir-fileinfo->marked file)
|
|
(vc-dir-unmark-file)
|
|
(vc-dir-mark-file))))
|
|
|
|
(defun vc-dir-toggle-mark (e)
|
|
(interactive "e")
|
|
(vc-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file)))
|
|
|
|
(defun vc-dir-delete-file ()
|
|
"Delete the marked files, or the current file if no marks."
|
|
(interactive)
|
|
(mapc 'vc-delete-file (or (vc-dir-marked-files)
|
|
(list (vc-dir-current-file)))))
|
|
|
|
(defun vc-dir-find-file ()
|
|
"Find the file on the current line."
|
|
(interactive)
|
|
(find-file (vc-dir-current-file)))
|
|
|
|
(defun vc-dir-find-file-other-window ()
|
|
"Find the file on the current line, in another window."
|
|
(interactive)
|
|
(find-file-other-window (vc-dir-current-file)))
|
|
|
|
(defun vc-dir-current-file ()
|
|
(let ((node (ewoc-locate vc-ewoc)))
|
|
(unless node
|
|
(error "No file available."))
|
|
(expand-file-name (vc-dir-fileinfo->name (ewoc-data node)))))
|
|
|
|
(defun vc-dir-marked-files ()
|
|
"Return the list of marked files."
|
|
(mapcar
|
|
(lambda (elem) (expand-file-name (vc-dir-fileinfo->name elem)))
|
|
(ewoc-collect vc-ewoc 'vc-dir-fileinfo->marked)))
|
|
|
|
(defun vc-dir-marked-only-files ()
|
|
"Return the list of marked files, for marked directories return child files."
|
|
(let ((crt (ewoc-nth vc-ewoc 0))
|
|
result)
|
|
(while crt
|
|
(let ((crt-data (ewoc-data crt)))
|
|
(if (vc-dir-fileinfo->marked crt-data)
|
|
;; FIXME: use vc-dir-child-files here instead of duplicating it.
|
|
(if (vc-dir-fileinfo->directory crt-data)
|
|
(let* ((dir (vc-dir-fileinfo->directory crt-data))
|
|
(dirlen (length dir))
|
|
data)
|
|
(while
|
|
(and (setq crt (ewoc-next vc-ewoc crt))
|
|
(string-equal
|
|
(substring
|
|
(progn
|
|
(setq data (ewoc-data crt))
|
|
(vc-dir-node-directory crt))
|
|
0 dirlen)
|
|
dir))
|
|
(unless (vc-dir-fileinfo->directory data)
|
|
(push (expand-file-name (vc-dir-fileinfo->name data)) result))))
|
|
(push (expand-file-name (vc-dir-fileinfo->name crt-data)) result)
|
|
(setq crt (ewoc-next vc-ewoc crt)))
|
|
(setq crt (ewoc-next vc-ewoc crt)))))
|
|
result))
|
|
|
|
(defun vc-dir-child-files ()
|
|
"Return the list of child files for the current entry if it's a directory.
|
|
If it is a file, return the file itself."
|
|
(let* ((crt (ewoc-locate vc-ewoc))
|
|
(crt-data (ewoc-data crt))
|
|
result)
|
|
(if (vc-dir-fileinfo->directory crt-data)
|
|
(let* ((dir (vc-dir-fileinfo->directory crt-data))
|
|
(dirlen (length dir))
|
|
data)
|
|
(while
|
|
(and (setq crt (ewoc-next vc-ewoc crt))
|
|
(string-equal
|
|
(substring
|
|
(progn
|
|
(setq data (ewoc-data crt))
|
|
(vc-dir-node-directory crt))
|
|
0 dirlen)
|
|
dir))
|
|
(unless (vc-dir-fileinfo->directory data)
|
|
(push (expand-file-name (vc-dir-fileinfo->name data)) result))))
|
|
(push (expand-file-name (vc-dir-fileinfo->name crt-data)) result))
|
|
result))
|
|
|
|
(defun vc-dir-resynch-file (&optional fname)
|
|
"Update the entries for FILE in any directory buffers that list it."
|
|
(let ((file (or fname (expand-file-name buffer-file-name))))
|
|
(if (file-directory-p file)
|
|
;; FIXME: Maybe this should never happen?
|
|
;; FIXME: But it is useful to update the state of a directory
|
|
;; (more precisely the files in the directory) after some VC
|
|
;; operations.
|
|
nil
|
|
(let ((found-vc-dir-buf nil))
|
|
(save-excursion
|
|
(dolist (status-buf (buffer-list))
|
|
(set-buffer status-buf)
|
|
;; look for a vc-dir buffer that might show this file.
|
|
(when (derived-mode-p 'vc-dir-mode)
|
|
(setq found-vc-dir-buf t)
|
|
(let ((ddir (expand-file-name default-directory)))
|
|
(when (vc-string-prefix-p ddir file)
|
|
(let*
|
|
((file-short (substring file (length ddir)))
|
|
(state
|
|
(funcall (vc-client-object->file-to-state vc-client-mode)
|
|
file))
|
|
(extra
|
|
(funcall (vc-client-object->file-to-extra vc-client-mode)
|
|
file))
|
|
(entry
|
|
(list file-short state extra)))
|
|
(vc-dir-update (list entry) status-buf))))))
|
|
;; We didn't find any vc-dir buffers, remove the hook, it is
|
|
;; not needed.
|
|
(unless found-vc-dir-buf (remove-hook 'after-save-hook 'vc-dir-resynch-file)))))))
|
|
|
|
(defun vc-dir-mode (client-object)
|
|
"Major mode for dispatcher directory buffers.
|
|
Marking/Unmarking key bindings and actions:
|
|
m - marks a file/directory or if the region is active, mark all the files
|
|
in region.
|
|
Restrictions: - a file cannot be marked if any parent directory is marked
|
|
- a directory cannot be marked if any child file or
|
|
directory is marked
|
|
u - marks a file/directory or if the region is active, unmark all the files
|
|
in region.
|
|
M - if the cursor is on a file: mark all the files with the same state as
|
|
the current file
|
|
- if the cursor is on a directory: mark all child files
|
|
- with a prefix argument: mark all files
|
|
U - if the cursor is on a file: unmark all the files with the same state
|
|
as the current file
|
|
- if the cursor is on a directory: unmark all child files
|
|
- with a prefix argument: unmark all files
|
|
|
|
|
|
\\{vc-dir-mode-map}"
|
|
(setq mode-name (vc-client-object->name client-object))
|
|
(setq major-mode 'vc-dir-mode)
|
|
(setq buffer-read-only t)
|
|
(use-local-map vc-dir-mode-map)
|
|
(set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)
|
|
(set (make-local-variable 'vc-client-mode) client-object)
|
|
(let ((buffer-read-only nil))
|
|
(erase-buffer)
|
|
(set (make-local-variable 'vc-dir-process-buffer) nil)
|
|
(set (make-local-variable 'vc-ewoc)
|
|
(ewoc-create (vc-client-object->file-to-info client-object)
|
|
(vc-client-object->headers client-object)))
|
|
(add-hook 'after-save-hook 'vc-dir-resynch-file)
|
|
;; Make sure that if the directory buffer is killed, the update
|
|
;; process running in the background is also killed.
|
|
(add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
|
|
(funcall (vc-client-object->updater client-object)))
|
|
(run-hooks 'vc-dir-mode-hook))
|
|
|
|
(put 'vc-dir-mode 'mode-class 'special)
|
|
|
|
(defun vc-dispatcher-browsing ()
|
|
"Are we in a directory browser buffer?"
|
|
(derived-mode-p 'vc-dir-mode))
|
|
|
|
(defun vc-dispatcher-in-fileset-p (fileset)
|
|
(let ((member nil))
|
|
(while (and (not member) fileset)
|
|
(let ((elem (pop fileset)))
|
|
(if (if (file-directory-p elem)
|
|
(eq t (compare-strings buffer-file-name nil (length elem)
|
|
elem nil nil))
|
|
(eq (current-buffer) (get-file-buffer elem)))
|
|
(setq member t))))
|
|
member))
|
|
|
|
(defun vc-dispatcher-selection-set (&optional observer)
|
|
"Deduce a set of files to which to apply an operation. Return a cons
|
|
cell (SELECTION . FILESET), where SELECTION is what the user chose
|
|
and FILES is the flist with any directories replaced by the listed files
|
|
within them.
|
|
|
|
If we're in a directory display, the fileset is the list of marked files (if
|
|
there is one) else the file on the current line. If not in a directory
|
|
display, but the current buffer visits a file, the fileset is a singleton
|
|
containing that file. Otherwise, throw an error."
|
|
(let ((selection
|
|
(cond
|
|
;; Browsing with vc-dir
|
|
((vc-dispatcher-browsing)
|
|
;; If no files are marked, temporarily mark current file
|
|
;; and choose on that basis (so we get subordinate files)
|
|
(if (not (vc-dir-marked-files))
|
|
(prog2
|
|
(vc-dir-mark-file)
|
|
(cons (vc-dir-marked-files) (vc-dir-marked-only-files))
|
|
(vc-dir-unmark-all-files t))
|
|
(cons (vc-dir-marked-files) (vc-dir-marked-only-files))))
|
|
;; Visiting an eligible file
|
|
((buffer-file-name)
|
|
(cons (list buffer-file-name) (list buffer-file-name)))
|
|
;; No eligible file -- if there's a parent buffer, deduce from there
|
|
((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
|
|
(with-current-buffer vc-parent-buffer
|
|
(vc-dispatcher-browsing))))
|
|
(with-current-buffer vc-parent-buffer
|
|
(vc-dispatcher-selection-set)))
|
|
;; No good set here, throw error
|
|
(t (error "No fileset is available here")))))
|
|
;; We assume, in order to avoid unpleasant surprises to the user,
|
|
;; that a fileset is not in good shape to be handed to the user if the
|
|
;; buffers visiting the fileset don't match the on-disk contents.
|
|
(unless observer
|
|
(save-some-buffers
|
|
nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
|
|
selection))
|
|
|
|
(provide 'vc-dispatcher)
|
|
|
|
;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
|
|
;;; vc-dispatcher.el ends here
|