Commit | Line | Data |
---|---|---|
92d1eebf ER |
1 | ;;; vc-dispatcher.el -- generic command-dispatcher facility. |
2 | ||
3 | ;; Copyright (C) 2008 | |
4 | ;; Free Software Foundation, Inc. | |
5 | ||
6 | ;; Author: FSF (see below for full credits) | |
7 | ;; Maintainer: Eric S. Raymond <esr@thyrsus.com> | |
8 | ;; Keywords: tools | |
9 | ||
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation; either version 3, or (at your option) | |
15 | ;; any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
25 | ;; Boston, MA 02110-1301, USA. | |
26 | ||
27 | ;;; Credits: | |
28 | ||
29 | ;; Designed and implemented by Eric S. Raymond, originally as part of VC mode. | |
30 | ||
31 | ;;; Commentary: | |
32 | ||
33 | ;; Goals: | |
34 | ;; | |
35 | ;; There is a class of front-ending problems that Emacs might be used | |
36 | ;; to address that involves selecting sets of files, or possibly | |
37 | ;; directories, and passing the selection set to slave commands. The | |
38 | ;; prototypical example, from which this code is derived, is talking | |
39 | ;; to version-control systems. | |
40 | ;; | |
41 | ;; vc-dispatcher.el is written to decouple the UI issues in such front | |
42 | ;; ends from their application-specific logic. It also provides a | |
43 | ;; service layer for running the slave commands either synchronously | |
44 | ;; or asynchronously and managing the message/error logs from the | |
45 | ;; command runs. | |
46 | ;; | |
47 | ;; Similar UI problems can be expected to come up in applications | |
48 | ;; areas other than VCSes; IDEs and document search are two obvious ones. | |
49 | ;; This mode is intended to ensure that the Emacs interfaces for all such | |
50 | ;; beasts are consistent and carefully designed. But even if nothing | |
51 | ;; but VC ever uses it, getting the layer separation right will be | |
52 | ;; a valuable thing. | |
53 | ||
54 | ;; Dispatcher's universe: | |
55 | ;; | |
56 | ;; The universe consists of the file tree rooted at the current | |
57 | ;; directory. The dispatcher's upper layer deduces some subset | |
58 | ;; of the file tree from the state of the currently visited buffer | |
59 | ;; and returns that subset, presumably to a client mode. | |
60 | ;; | |
61 | ;; The user may be attempting to select one of three contexts: an | |
62 | ;; explicitly selected fileset, the current working directory, or a | |
63 | ;; global (null) context. The user may be looking at either of two | |
64 | ;; different views; a buffer visiting a file, or a directory buffer | |
65 | ;; generated by vc-dispatcher. The main UI problem connected with | |
66 | ;; this mode is that the user may need to be able to select any of | |
67 | ;; these three contexts from either view. | |
68 | ;; | |
69 | ;; The lower layer of this mode runs commands in subprocesses, either | |
70 | ;; synchronously or asynchronously. Commands may be launched in one | |
71 | ;; of two ways: they may be run immediately, or the calling mode can | |
72 | ;; create a closure associated with a text-entry buffer, to be | |
73 | ;; executed when the user types C-c to ship the buffer contents. In | |
74 | ;; either case the command messages and error (if any) will remain | |
75 | ;; available in a status buffer. | |
76 | ||
77 | (provide 'vc-dispatcher) | |
78 | ||
92d1eebf ER |
79 | ;; Common command execution logic |
80 | ||
81 | (defun vc-process-filter (p s) | |
82 | "An alternative output filter for async process P. | |
83 | One difference with the default filter is that this inserts S after markers. | |
84 | Another is that undo information is not kept." | |
85 | (let ((buffer (process-buffer p))) | |
86 | (when (buffer-live-p buffer) | |
87 | (with-current-buffer buffer | |
88 | (save-excursion | |
89 | (let ((buffer-undo-list t) | |
90 | (inhibit-read-only t)) | |
91 | (goto-char (process-mark p)) | |
92 | (insert s) | |
93 | (set-marker (process-mark p) (point)))))))) | |
94 | ||
7265c6e8 ER |
95 | (defun vc-setup-buffer (buf) |
96 | "Prepare BUF for executing a slave command and make it current." | |
92d1eebf ER |
97 | (let ((camefrom (current-buffer)) |
98 | (olddir default-directory)) | |
99 | (set-buffer (get-buffer-create buf)) | |
100 | (kill-all-local-variables) | |
101 | (set (make-local-variable 'vc-parent-buffer) camefrom) | |
102 | (set (make-local-variable 'vc-parent-buffer-name) | |
103 | (concat " from " (buffer-name camefrom))) | |
104 | (setq default-directory olddir) | |
105 | (let ((buffer-undo-list t) | |
106 | (inhibit-read-only t)) | |
107 | (erase-buffer)))) | |
108 | ||
109 | (defvar vc-sentinel-movepoint) ;Dynamically scoped. | |
110 | ||
111 | (defun vc-process-sentinel (p s) | |
112 | (let ((previous (process-get p 'vc-previous-sentinel)) | |
113 | (buf (process-buffer p))) | |
114 | ;; Impatient users sometime kill "slow" buffers; check liveness | |
115 | ;; to avoid "error in process sentinel: Selecting deleted buffer". | |
116 | (when (buffer-live-p buf) | |
117 | (when previous (funcall previous p s)) | |
118 | (with-current-buffer buf | |
119 | (setq mode-line-process | |
120 | (let ((status (process-status p))) | |
121 | ;; Leave mode-line uncluttered, normally. | |
122 | (unless (eq 'exit status) | |
123 | (format " (%s)" status)))) | |
124 | (let (vc-sentinel-movepoint) | |
125 | ;; Normally, we want async code such as sentinels to not move point. | |
126 | (save-excursion | |
127 | (goto-char (process-mark p)) | |
128 | (let ((cmds (process-get p 'vc-sentinel-commands))) | |
129 | (process-put p 'vc-sentinel-commands nil) | |
130 | (dolist (cmd cmds) | |
131 | ;; Each sentinel may move point and the next one should be run | |
132 | ;; at that new point. We could get the same result by having | |
133 | ;; each sentinel read&set process-mark, but since `cmd' needs | |
134 | ;; to work both for async and sync processes, this would be | |
135 | ;; difficult to achieve. | |
136 | (vc-exec-after cmd)))) | |
137 | ;; But sometimes the sentinels really want to move point. | |
138 | (when vc-sentinel-movepoint | |
139 | (let ((win (get-buffer-window (current-buffer) 0))) | |
140 | (if (not win) | |
141 | (goto-char vc-sentinel-movepoint) | |
142 | (with-selected-window win | |
143 | (goto-char vc-sentinel-movepoint)))))))))) | |
144 | ||
145 | (defun vc-set-mode-line-busy-indicator () | |
146 | (setq mode-line-process | |
147 | (concat " " (propertize "[waiting...]" | |
148 | 'face 'mode-line-emphasis | |
149 | 'help-echo | |
150 | "A VC command is in progress in this buffer")))) | |
151 | ||
152 | (defun vc-exec-after (code) | |
153 | "Eval CODE when the current buffer's process is done. | |
154 | If the current buffer has no process, just evaluate CODE. | |
155 | Else, add CODE to the process' sentinel." | |
156 | (let ((proc (get-buffer-process (current-buffer)))) | |
157 | (cond | |
158 | ;; If there's no background process, just execute the code. | |
159 | ;; We used to explicitly call delete-process on exited processes, | |
160 | ;; but this led to timing problems causing process output to be | |
161 | ;; lost. Terminated processes get deleted automatically | |
162 | ;; anyway. -- cyd | |
163 | ((or (null proc) (eq (process-status proc) 'exit)) | |
164 | ;; Make sure we've read the process's output before going further. | |
165 | (when proc (accept-process-output proc)) | |
166 | (eval code)) | |
167 | ;; If a process is running, add CODE to the sentinel | |
168 | ((eq (process-status proc) 'run) | |
169 | (vc-set-mode-line-busy-indicator) | |
170 | (let ((previous (process-sentinel proc))) | |
171 | (unless (eq previous 'vc-process-sentinel) | |
172 | (process-put proc 'vc-previous-sentinel previous)) | |
173 | (set-process-sentinel proc 'vc-process-sentinel)) | |
174 | (process-put proc 'vc-sentinel-commands | |
175 | ;; We keep the code fragments in the order given | |
176 | ;; so that vc-diff-finish's message shows up in | |
177 | ;; the presence of non-nil vc-command-messages. | |
178 | (append (process-get proc 'vc-sentinel-commands) | |
179 | (list code)))) | |
180 | (t (error "Unexpected process state")))) | |
181 | nil) | |
182 | ||
183 | (defvar vc-post-command-functions nil | |
184 | "Hook run at the end of `vc-do-command'. | |
185 | Each function is called inside the buffer in which the command was run | |
186 | and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.") | |
187 | ||
188 | (defvar w32-quote-process-args) | |
189 | ||
190 | (defun vc-delistify (filelist) | |
191 | "Smash a FILELIST into a file list string suitable for info messages." | |
192 | ;; FIXME what about file names with spaces? | |
193 | (if (not filelist) "." (mapconcat 'identity filelist " "))) | |
194 | ||
195 | ;;;###autoload | |
196 | (defun vc-do-command (buffer okstatus command file-or-list &rest flags) | |
197 | "Execute a VC command, notifying user and checking for errors. | |
198 | Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil or the | |
199 | current buffer if BUFFER is t. If the destination buffer is not | |
200 | already current, set it up properly and erase it. The command is | |
201 | considered successful if its exit status does not exceed OKSTATUS (if | |
202 | OKSTATUS is nil, that means to ignore error status, if it is `async', that | |
203 | means not to wait for termination of the subprocess; if it is t it means to | |
204 | ignore all execution errors). FILE-OR-LIST is the name of a working file; | |
205 | it may be a list of files or be nil (to execute commands that don't expect | |
206 | a file name or set of files). If an optional list of FLAGS is present, | |
207 | that is inserted into the command line before the filename." | |
208 | ;; FIXME: file-relative-name can return a bogus result because | |
209 | ;; it doesn't look at the actual file-system to see if symlinks | |
210 | ;; come into play. | |
211 | (let* ((files | |
212 | (mapcar (lambda (f) (file-relative-name (expand-file-name f))) | |
213 | (if (listp file-or-list) file-or-list (list file-or-list)))) | |
214 | (full-command | |
215 | ;; What we're doing here is preparing a version of the command | |
216 | ;; for display in a debug-progess message. If it's fewer than | |
217 | ;; 20 characters display the entire command (without trailing | |
218 | ;; newline). Otherwise display the first 20 followed by an ellipsis. | |
219 | (concat (if (string= (substring command -1) "\n") | |
220 | (substring command 0 -1) | |
221 | command) | |
222 | " " | |
223 | (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags)) | |
224 | " " (vc-delistify files)))) | |
225 | (save-current-buffer | |
226 | (unless (or (eq buffer t) | |
227 | (and (stringp buffer) | |
228 | (string= (buffer-name) buffer)) | |
229 | (eq buffer (current-buffer))) | |
b1ddeeb7 | 230 | (vc-setup-buffer (or buffer "*vc*"))) |
92d1eebf ER |
231 | ;; If there's some previous async process still running, just kill it. |
232 | (let ((oldproc (get-buffer-process (current-buffer)))) | |
233 | ;; If we wanted to wait for oldproc to finish before doing | |
234 | ;; something, we'd have used vc-eval-after. | |
235 | ;; Use `delete-process' rather than `kill-process' because we don't | |
236 | ;; want any of its output to appear from now on. | |
237 | (if oldproc (delete-process oldproc))) | |
238 | (let ((squeezed (remq nil flags)) | |
239 | (inhibit-read-only t) | |
240 | (status 0)) | |
241 | (when files | |
242 | (setq squeezed (nconc squeezed files))) | |
243 | (let ((exec-path (append vc-path exec-path)) | |
244 | ;; Add vc-path to PATH for the execution of this command. | |
245 | (process-environment | |
246 | (cons (concat "PATH=" (getenv "PATH") | |
247 | path-separator | |
248 | (mapconcat 'identity vc-path path-separator)) | |
249 | process-environment)) | |
250 | (w32-quote-process-args t)) | |
251 | (when (and (eq okstatus 'async) (file-remote-p default-directory)) | |
252 | ;; start-process does not support remote execution | |
253 | (setq okstatus nil)) | |
254 | (if (eq okstatus 'async) | |
255 | ;; Run asynchronously. | |
256 | (let ((proc | |
257 | (let ((process-connection-type nil)) | |
258 | (apply 'start-file-process command (current-buffer) | |
259 | command squeezed)))) | |
260 | (if vc-command-messages | |
261 | (message "Running %s in background..." full-command)) | |
262 | ;;(set-process-sentinel proc (lambda (p msg) (delete-process p))) | |
263 | (set-process-filter proc 'vc-process-filter) | |
264 | (vc-exec-after | |
265 | `(if vc-command-messages | |
266 | (message "Running %s in background... done" ',full-command)))) | |
267 | ;; Run synchrously | |
268 | (when vc-command-messages | |
269 | (message "Running %s in foreground..." full-command)) | |
270 | (let ((buffer-undo-list t)) | |
271 | (setq status (apply 'process-file command nil t nil squeezed))) | |
272 | (when (and (not (eq t okstatus)) | |
273 | (or (not (integerp status)) | |
274 | (and okstatus (< okstatus status)))) | |
275 | (unless (eq ?\s (aref (buffer-name (current-buffer)) 0)) | |
276 | (pop-to-buffer (current-buffer)) | |
277 | (goto-char (point-min)) | |
278 | (shrink-window-if-larger-than-buffer)) | |
279 | (error "Running %s...FAILED (%s)" full-command | |
280 | (if (integerp status) (format "status %d" status) status)))) | |
281 | ;; We're done. But don't emit a status message if running | |
282 | ;; asychronously, it would just mislead. | |
283 | (if (and vc-command-messages (not (eq okstatus 'async))) | |
284 | (message "Running %s...OK = %d" full-command status))) | |
285 | (vc-exec-after | |
286 | `(run-hook-with-args 'vc-post-command-functions | |
287 | ',command ',file-or-list ',flags)) | |
288 | status)))) | |
289 | ||
b1ddeeb7 | 290 | ;;; vc-dispatcher.el ends here |