;; 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.
+;; 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
+;; 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.
;; 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
+;; 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
;; 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
+;; 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.
;; 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
+;; 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
-;; comand, synchronously or asynchronously, making the output available
+;; 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
-;; abbotation buffer so that when the user confirms the comment the closure
+;; 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)
;; (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
+;; 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
;; 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
+;; it should work for other async commands done through vc-do-command
;; as well,
;;
;; - log buffers need font-locking.
(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
(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-progess message. If it's fewer than
+ ;; 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")
(vc-exec-after
`(if vc-command-messages
(message "Running %s in background... done" ',full-command))))
- ;; Run synchrously
+ ;; Run synchronously
(when vc-command-messages
(message "Running %s in foreground..." full-command))
(let ((buffer-undo-list t))
(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
- ;; asychronously, it would just mislead.
+ ;; 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
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,
+;; 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))
(and (not view-mode)
(not (eq (get major-mode 'mode-class) 'special))
(view-mode-enter))))
- (run-hook-with-args 'modeline-hook buffer-file-name))
+ (run-hook-with-args 'mode-line-hook buffer-file-name))
(kill-buffer (current-buffer)))))
(defun vc-resynch-buffer (file &optional keep noquery)
(when buffer
(with-current-buffer buffer
(vc-resynch-window file keep noquery)))))
- (vc-directory-resynch-file file))
+ ;; 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.
(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-directory buffer.
+ ;; 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
;; To distinguish files and directories.
directory)
-;; Used to describe a dispatcher client mode.
+;; Used to describe a dispatcher client mode.
(defstruct (vc-client-object
(:copier nil)
(:constructor
- vc-create-client-object (name
- headers
+ vc-create-client-object (name
+ headers
file-to-info
- file-to-state
+ file-to-state
file-to-extra
updater
extra-menu))
(:conc-name vc-client-object->))
- name
+ name
headers
file-to-info
- file-to-state
+ file-to-state
file-to-extra
updater
extra-menu)
(current-buffer)))))
(defvar vc-dir-menu-map
- (let ((map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap "VC-dir")))
(define-key map [quit]
'(menu-item "Quit" quit-window
:help "Quit"))
map)
"Menu for dispatcher status")
-;; This is used to that vlient modes can add mode-specific menu
+;; 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
- (funcall (vc-client-object->extra-menu vc-client-mode))))
+ ;; 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
;; Movement.
(define-key map "n" 'vc-dir-next-line)
(define-key map " " 'vc-dir-next-line)
- (define-key map "\t" '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-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-prev-directory)
- (define-key map "\M-<down>" 'vc-dir-next-directory)
- (define-key map "\M-<up>" 'vc-dir-prev-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 "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)
+ (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
+ `(menu-item
;; This is used so that client modes can add mode-specific
;; menu items to vc-dir-menu-map.
- "*vc-dispatcher*" ,vc-dir-menu-map :filter vc-dir-menu-map-filter))
+ "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' wich point located at event-start of `event'.
+ "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 (gensym "vc-at-event-posn")))
+ (let ((posn (make-symbol "vc-at-event-posn")))
`(let ((,posn (event-start ,event)))
(save-excursion
(set-buffer (window-buffer (posn-window ,posn)))
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."
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
- (or (vc-dir-fileinfo->directory (ewoc-data node))
- (file-name-directory
- (expand-file-name
- (vc-dir-fileinfo->name (ewoc-data node)))))))
+ (nodedir (vc-dir-node-directory node)))
(cond
;; First try to find the directory.
((string-lessp nodedir entrydir)
(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) entry (car entries))
+ (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) entry (car entries))))))
+ (setq entries (cdr entries))
+ (setq entry (car entries))))))
(t
- ;; We need to insert a directory node
- (let ((rd (file-relative-name entrydir)))
- (ewoc-enter-last
- vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir)))
+ ;; 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* ((lastnode (ewoc-nth vc-ewoc -1))
- (lastdir
- (or (vc-dir-fileinfo->directory (ewoc-data lastnode))
- (file-name-directory
- (expand-file-name
- (vc-dir-fileinfo->name (ewoc-data lastnode)))))))
+ (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.
"Go to the next directory."
(interactive)
(let ((orig (point)))
- (if
+ (if
(catch 'foundit
(while t
(let* ((next (ewoc-next vc-ewoc (ewoc-locate vc-ewoc))))
(throw 'foundit nil))))))))
(goto-char orig))))
-(defun vc-dir-prev-directory ()
+(defun vc-dir-previous-directory ()
"Go to the previous directory."
(interactive)
(let ((orig (point)))
- (if
+ (if
(catch 'foundit
(while t
(let* ((prev (ewoc-prev vc-ewoc (ewoc-locate vc-ewoc))))
(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* ((argdata (ewoc-data arg))
- (argdir
- (let ((crtdir (vc-dir-fileinfo->directory argdata)))
- (if crtdir
- crtdir
- (file-name-directory (expand-file-name
- (vc-dir-fileinfo->name argdata))))))
+ (let* ((argdir (vc-dir-node-directory arg))
(arglen (length argdir))
(crt arg)
data dir)
;; a parent is marked.
(while (setq crt (ewoc-prev vc-ewoc crt))
(setq data (ewoc-data crt))
- (setq dir
- (let ((crtdir (vc-dir-fileinfo->directory data)))
- (if crtdir
- crtdir
- (file-name-directory (expand-file-name
- (vc-dir-fileinfo->name data))))))
-
+ (setq dir (vc-dir-node-directory crt))
(when (and (vc-dir-fileinfo->directory data)
- (string-equal (substring argdir 0 (length dir)) dir))
+ (vc-string-prefix-p dir argdir))
(when (vc-dir-fileinfo->marked data)
(error "Cannot mark `%s', parent directory `%s' marked"
- (vc-dir-fileinfo->name argdata)
+ (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* ((argdata (ewoc-data arg))
- (argdir (vc-dir-fileinfo->directory argdata))
+ (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
- (let ((crtdir (vc-dir-fileinfo->directory data)))
- (if crtdir
- crtdir
- (file-name-directory (expand-file-name
- (vc-dir-fileinfo->name data))))))
+ (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 argdata)
+ (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)))
(ewoc-map
(lambda (filearg)
(when (and (vc-dir-fileinfo->directory filearg)
- (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-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."
+ "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))
(substring
(progn
(setq data (ewoc-data crt))
- (let ((crtdir (vc-dir-fileinfo->directory data)))
- (if crtdir
- crtdir
- (file-name-directory
- (expand-file-name
- (vc-dir-fileinfo->name data))))))
+ (vc-dir-node-directory crt))
0 dirlen)
dir))
(unless (vc-dir-fileinfo->directory data)
- (push (vc-dir-fileinfo->name data) result))))
+ (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-directory-resynch-file (&optional fname)
+
+(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))))
- ;; The vc-dir case
- (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 (eq major-mode 'vc-dir-mode)
- (setq found-vc-dir-buf t)
- (let ((ddir (expand-file-name default-directory)))
- ;; This test is cvs-string-prefix-p
- (when (eq t (compare-strings file nil (length ddir) ddir nil nil))
- (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-directory-resynch-file))))))
+ (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.
(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-directory-resynch-file)
+ (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)
(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
+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 curreent line. If not in a directory
+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, temporatrily mark current file
+ ;; 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
;; 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.
- (if (not observer)
- (save-some-buffers
- nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
+ (unless observer
+ (save-some-buffers
+ nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
selection))
(provide 'vc-dispatcher)
HCoop / bpt / emacs.git / blobdiff