(vc-dispatcher-selection-set): Typo.
[bpt/emacs.git] / lisp / vc-dispatcher.el
CommitLineData
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
eb3fa2cf 12;; GNU Emacs is free software: you can redistribute it and/or modify
92d1eebf 13;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
92d1eebf
ER
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
eb3fa2cf 23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
92d1eebf
ER
24
25;;; Credits:
26
27;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
dbf2c858 28;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
821677fb 29;; vc-dir front end.
92d1eebf
ER
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
d99d06ec
ER
77;; Special behavior of dispatcher directory buffers:
78;;
038608c7 79;; In dispatcher directory buffers, facilities to perform basic
d99d06ec
ER
80;; navigation and selection operations are provided by keymap and menu
81;; entries that dispatcher sets up itself, so they'll be uniform
038608c7 82;; across all dispatcher-using client modes. Client modes are
d99d06ec
ER
83;; expected to append to these to provide mode-specific bindings.
84;;
85;; The standard map associates a 'state' slot (that the client mode
86;; may set) with each directory entry. The dispatcher knows nothing
87;; about the semantics of individual states, but mark and unmark commands
038608c7
ER
88;; treat all entries with the same state as the currently selected one as
89;; a unit.
821677fb
ER
90
91;; The interface
92;;
93;; The main interface to the lower level is vc-do-command. This launches a
94;; comand, synchronously or asynchronously, making the output available
95;; in a command log buffer. Two other functions, (vc-start-annotation) and
96;; (vc-finish-logentry), allow you to associate a command closure with an
97;; abbotation buffer so that when the user confirms the comment the closure
98;; is run (with the comment as part of its context).
99;;
100;; The interface to the upper level has the two main entry points (vc-dir)
101;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
102;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
103;; returns a selection set of files, either the marked files in a browsing
104;; buffer or the singleton set consisting of the file visited by the current
c8d4f1a0
ER
105;; buffer (when that is appropriate). It also does what is needed to ensure
106;; that on-disk files and the contents of their visiting Emacs buffers
107;; coincide.
108;;
109;; When the client mode adds a local mode-line-hook to a buffer, it
110;; will be called with the buffer file name as argument whenever the
111;; dispatcher resynchs the buffer.
821677fb 112
d99d06ec
ER
113;; To do:
114;;
115;; - vc-dir-kill-dir-status-process should not be specific to dir-status,
116;; it should work for other async commands as well (pull/push/...).
117;;
118;; - the *VC-log* buffer needs font-locking.
119;;
120;; - Set `vc-dir-insert-directories' to t and check what operations
121;; and backends do not support directory arguments and fix them.
122;;
123;; - vc-dir needs mouse bindings.
124;;
125;; - vc-dir needs more key bindings for VC actions.
126;;
127;; - vc-dir toolbar needs more icons.
128;;
129;; - vc-dir-next-line should not print an "end of buffer" message when
130;; invoked with the cursor on the last file.
131;;
132;; - add commands to move to the prev/next directory in vc-dir.
133;;
134;; - document vc-dir in the manual.
135;;
136
92d1eebf
ER
137(provide 'vc-dispatcher)
138
4f61cc3e 139(eval-when-compile
4903369a 140 (require 'cl))
4f61cc3e 141
83affd96
ER
142;; General customization
143
144(defcustom vc-logentry-check-hook nil
145 "Normal hook run by `vc-finish-logentry'.
146Use this to impose your own rules on the entry in addition to any the
4f61cc3e 147dispatcher client mode imposes itself."
83affd96
ER
148 :type 'hook
149 :group 'vc)
150
17f039f3
ER
151(defcustom vc-delete-logbuf-window t
152 "If non-nil, delete the *VC-log* buffer and window after each logical action.
153If nil, bury that buffer instead.
154This is most useful if you have multiple windows on a frame and would like to
155preserve the setting."
156 :type 'boolean
157 :group 'vc)
158
159(defcustom vc-command-messages nil
160 "If non-nil, display run messages from back-end commands."
161 :type 'boolean
162 :group 'vc)
163
821677fb
ER
164(defcustom vc-suppress-confirm nil
165 "If non-nil, treat user as expert; suppress yes-no prompts on some things."
166 :type 'boolean
167 :group 'vc)
168
83affd96 169;; Variables the user doesn't need to know about.
17f039f3 170
83affd96
ER
171(defvar vc-log-operation nil)
172(defvar vc-log-after-operation-hook nil)
173(defvar vc-log-fileset)
174(defvar vc-log-extra)
175
176;; In a log entry buffer, this is a local variable
177;; that points to the buffer for which it was made
4903369a 178;; (either a file, or a VC directory buffer).
83affd96
ER
179(defvar vc-parent-buffer nil)
180(put 'vc-parent-buffer 'permanent-local t)
181(defvar vc-parent-buffer-name nil)
182(put 'vc-parent-buffer-name 'permanent-local t)
183
92d1eebf
ER
184;; Common command execution logic
185
186(defun vc-process-filter (p s)
187 "An alternative output filter for async process P.
188One difference with the default filter is that this inserts S after markers.
189Another is that undo information is not kept."
190 (let ((buffer (process-buffer p)))
191 (when (buffer-live-p buffer)
192 (with-current-buffer buffer
193 (save-excursion
194 (let ((buffer-undo-list t)
195 (inhibit-read-only t))
196 (goto-char (process-mark p))
197 (insert s)
198 (set-marker (process-mark p) (point))))))))
199
7265c6e8
ER
200(defun vc-setup-buffer (buf)
201 "Prepare BUF for executing a slave command and make it current."
92d1eebf
ER
202 (let ((camefrom (current-buffer))
203 (olddir default-directory))
204 (set-buffer (get-buffer-create buf))
205 (kill-all-local-variables)
206 (set (make-local-variable 'vc-parent-buffer) camefrom)
207 (set (make-local-variable 'vc-parent-buffer-name)
208 (concat " from " (buffer-name camefrom)))
209 (setq default-directory olddir)
210 (let ((buffer-undo-list t)
211 (inhibit-read-only t))
212 (erase-buffer))))
213
214(defvar vc-sentinel-movepoint) ;Dynamically scoped.
215
216(defun vc-process-sentinel (p s)
217 (let ((previous (process-get p 'vc-previous-sentinel))
218 (buf (process-buffer p)))
219 ;; Impatient users sometime kill "slow" buffers; check liveness
220 ;; to avoid "error in process sentinel: Selecting deleted buffer".
221 (when (buffer-live-p buf)
222 (when previous (funcall previous p s))
223 (with-current-buffer buf
224 (setq mode-line-process
225 (let ((status (process-status p)))
226 ;; Leave mode-line uncluttered, normally.
227 (unless (eq 'exit status)
228 (format " (%s)" status))))
229 (let (vc-sentinel-movepoint)
230 ;; Normally, we want async code such as sentinels to not move point.
231 (save-excursion
232 (goto-char (process-mark p))
233 (let ((cmds (process-get p 'vc-sentinel-commands)))
234 (process-put p 'vc-sentinel-commands nil)
235 (dolist (cmd cmds)
236 ;; Each sentinel may move point and the next one should be run
237 ;; at that new point. We could get the same result by having
238 ;; each sentinel read&set process-mark, but since `cmd' needs
239 ;; to work both for async and sync processes, this would be
240 ;; difficult to achieve.
241 (vc-exec-after cmd))))
242 ;; But sometimes the sentinels really want to move point.
243 (when vc-sentinel-movepoint
244 (let ((win (get-buffer-window (current-buffer) 0)))
245 (if (not win)
246 (goto-char vc-sentinel-movepoint)
247 (with-selected-window win
248 (goto-char vc-sentinel-movepoint))))))))))
249
250(defun vc-set-mode-line-busy-indicator ()
251 (setq mode-line-process
252 (concat " " (propertize "[waiting...]"
253 'face 'mode-line-emphasis
254 'help-echo
255 "A VC command is in progress in this buffer"))))
256
257(defun vc-exec-after (code)
258 "Eval CODE when the current buffer's process is done.
259If the current buffer has no process, just evaluate CODE.
260Else, add CODE to the process' sentinel."
261 (let ((proc (get-buffer-process (current-buffer))))
262 (cond
263 ;; If there's no background process, just execute the code.
264 ;; We used to explicitly call delete-process on exited processes,
265 ;; but this led to timing problems causing process output to be
266 ;; lost. Terminated processes get deleted automatically
267 ;; anyway. -- cyd
268 ((or (null proc) (eq (process-status proc) 'exit))
269 ;; Make sure we've read the process's output before going further.
270 (when proc (accept-process-output proc))
271 (eval code))
272 ;; If a process is running, add CODE to the sentinel
273 ((eq (process-status proc) 'run)
274 (vc-set-mode-line-busy-indicator)
275 (let ((previous (process-sentinel proc)))
276 (unless (eq previous 'vc-process-sentinel)
277 (process-put proc 'vc-previous-sentinel previous))
278 (set-process-sentinel proc 'vc-process-sentinel))
279 (process-put proc 'vc-sentinel-commands
280 ;; We keep the code fragments in the order given
281 ;; so that vc-diff-finish's message shows up in
282 ;; the presence of non-nil vc-command-messages.
283 (append (process-get proc 'vc-sentinel-commands)
284 (list code))))
285 (t (error "Unexpected process state"))))
286 nil)
287
288(defvar vc-post-command-functions nil
289 "Hook run at the end of `vc-do-command'.
290Each function is called inside the buffer in which the command was run
291and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
292
293(defvar w32-quote-process-args)
294
295(defun vc-delistify (filelist)
296 "Smash a FILELIST into a file list string suitable for info messages."
297 ;; FIXME what about file names with spaces?
298 (if (not filelist) "." (mapconcat 'identity filelist " ")))
299
300;;;###autoload
301(defun vc-do-command (buffer okstatus command file-or-list &rest flags)
302 "Execute a VC command, notifying user and checking for errors.
303Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil or the
304current buffer if BUFFER is t. If the destination buffer is not
305already current, set it up properly and erase it. The command is
306considered successful if its exit status does not exceed OKSTATUS (if
307OKSTATUS is nil, that means to ignore error status, if it is `async', that
308means not to wait for termination of the subprocess; if it is t it means to
309ignore all execution errors). FILE-OR-LIST is the name of a working file;
310it may be a list of files or be nil (to execute commands that don't expect
311a file name or set of files). If an optional list of FLAGS is present,
312that is inserted into the command line before the filename."
313 ;; FIXME: file-relative-name can return a bogus result because
314 ;; it doesn't look at the actual file-system to see if symlinks
315 ;; come into play.
316 (let* ((files
317 (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
318 (if (listp file-or-list) file-or-list (list file-or-list))))
319 (full-command
320 ;; What we're doing here is preparing a version of the command
321 ;; for display in a debug-progess message. If it's fewer than
322 ;; 20 characters display the entire command (without trailing
323 ;; newline). Otherwise display the first 20 followed by an ellipsis.
324 (concat (if (string= (substring command -1) "\n")
325 (substring command 0 -1)
326 command)
327 " "
328 (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
329 " " (vc-delistify files))))
330 (save-current-buffer
331 (unless (or (eq buffer t)
332 (and (stringp buffer)
333 (string= (buffer-name) buffer))
334 (eq buffer (current-buffer)))
b1ddeeb7 335 (vc-setup-buffer (or buffer "*vc*")))
92d1eebf
ER
336 ;; If there's some previous async process still running, just kill it.
337 (let ((oldproc (get-buffer-process (current-buffer))))
338 ;; If we wanted to wait for oldproc to finish before doing
339 ;; something, we'd have used vc-eval-after.
340 ;; Use `delete-process' rather than `kill-process' because we don't
341 ;; want any of its output to appear from now on.
342 (if oldproc (delete-process oldproc)))
343 (let ((squeezed (remq nil flags))
344 (inhibit-read-only t)
345 (status 0))
346 (when files
347 (setq squeezed (nconc squeezed files)))
348 (let ((exec-path (append vc-path exec-path))
349 ;; Add vc-path to PATH for the execution of this command.
350 (process-environment
351 (cons (concat "PATH=" (getenv "PATH")
352 path-separator
353 (mapconcat 'identity vc-path path-separator))
354 process-environment))
355 (w32-quote-process-args t))
356 (when (and (eq okstatus 'async) (file-remote-p default-directory))
357 ;; start-process does not support remote execution
358 (setq okstatus nil))
359 (if (eq okstatus 'async)
360 ;; Run asynchronously.
361 (let ((proc
362 (let ((process-connection-type nil))
363 (apply 'start-file-process command (current-buffer)
364 command squeezed))))
365 (if vc-command-messages
366 (message "Running %s in background..." full-command))
367 ;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
368 (set-process-filter proc 'vc-process-filter)
369 (vc-exec-after
370 `(if vc-command-messages
371 (message "Running %s in background... done" ',full-command))))
372 ;; Run synchrously
373 (when vc-command-messages
374 (message "Running %s in foreground..." full-command))
375 (let ((buffer-undo-list t))
376 (setq status (apply 'process-file command nil t nil squeezed)))
377 (when (and (not (eq t okstatus))
378 (or (not (integerp status))
379 (and okstatus (< okstatus status))))
380 (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
381 (pop-to-buffer (current-buffer))
382 (goto-char (point-min))
383 (shrink-window-if-larger-than-buffer))
384 (error "Running %s...FAILED (%s)" full-command
385 (if (integerp status) (format "status %d" status) status))))
386 ;; We're done. But don't emit a status message if running
387 ;; asychronously, it would just mislead.
388 (if (and vc-command-messages (not (eq okstatus 'async)))
389 (message "Running %s...OK = %d" full-command status)))
390 (vc-exec-after
391 `(run-hook-with-args 'vc-post-command-functions
392 ',command ',file-or-list ',flags))
393 status))))
394
17f039f3
ER
395;; These functions are used to ensure that the view the user sees is up to date
396;; even if the dispatcher client mode has messed with file contents (as in,
397;; for example, VCS keyword expansion).
398
399(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
400
401(defun vc-position-context (posn)
402 "Save a bit of the text around POSN in the current buffer.
403Used to help us find the corresponding position again later
404if markers are destroyed or corrupted."
405 ;; A lot of this was shamelessly lifted from Sebastian Kremer's
406 ;; rcs.el mode.
407 (list posn
408 (buffer-size)
409 (buffer-substring posn
410 (min (point-max) (+ posn 100)))))
411
412(defun vc-find-position-by-context (context)
413 "Return the position of CONTEXT in the current buffer.
414If CONTEXT cannot be found, return nil."
415 (let ((context-string (nth 2 context)))
416 (if (equal "" context-string)
417 (point-max)
418 (save-excursion
419 (let ((diff (- (nth 1 context) (buffer-size))))
420 (when (< diff 0) (setq diff (- diff)))
421 (goto-char (nth 0 context))
422 (if (or (search-forward context-string nil t)
423 ;; Can't use search-backward since the match may continue
424 ;; after point.
425 (progn (goto-char (- (point) diff (length context-string)))
426 ;; goto-char doesn't signal an error at
427 ;; beginning of buffer like backward-char would
428 (search-forward context-string nil t)))
429 ;; to beginning of OSTRING
430 (- (point) (length context-string))))))))
431
432(defun vc-context-matches-p (posn context)
433 "Return t if POSN matches CONTEXT, nil otherwise."
434 (let* ((context-string (nth 2 context))
435 (len (length context-string))
436 (end (+ posn len)))
437 (if (> end (1+ (buffer-size)))
438 nil
439 (string= context-string (buffer-substring posn end)))))
440
441(defun vc-buffer-context ()
442 "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
443Used by `vc-restore-buffer-context' to later restore the context."
444 (let ((point-context (vc-position-context (point)))
445 ;; Use mark-marker to avoid confusion in transient-mark-mode.
9ba4a350 446 (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
17f039f3
ER
447 (vc-position-context (mark-marker))))
448 ;; Make the right thing happen in transient-mark-mode.
9ba4a350
ER
449 (mark-active nil))
450 (list point-context mark-context nil)))
17f039f3
ER
451
452(defun vc-restore-buffer-context (context)
453 "Restore point/mark, and reparse any affected compilation buffers.
454CONTEXT is that which `vc-buffer-context' returns."
455 (let ((point-context (nth 0 context))
9ba4a350 456 (mark-context (nth 1 context)))
17f039f3
ER
457 ;; if necessary, restore point and mark
458 (if (not (vc-context-matches-p (point) point-context))
459 (let ((new-point (vc-find-position-by-context point-context)))
460 (when new-point (goto-char new-point))))
461 (and mark-active
462 mark-context
463 (not (vc-context-matches-p (mark) mark-context))
464 (let ((new-mark (vc-find-position-by-context mark-context)))
465 (when new-mark (set-mark new-mark))))))
466
467(defun vc-revert-buffer-internal (&optional arg no-confirm)
468 "Revert buffer, keeping point and mark where user expects them.
469Try to be clever in the face of changes due to expanded version-control
470key words. This is important for typeahead to work as expected.
471ARG and NO-CONFIRM are passed on to `revert-buffer'."
472 (interactive "P")
473 (widen)
474 (let ((context (vc-buffer-context)))
475 ;; Use save-excursion here, because it may be able to restore point
476 ;; and mark properly even in cases where vc-restore-buffer-context
477 ;; would fail. However, save-excursion might also get it wrong --
478 ;; in this case, vc-restore-buffer-context gives it a second try.
479 (save-excursion
480 ;; t means don't call normal-mode;
481 ;; that's to preserve various minor modes.
482 (revert-buffer arg no-confirm t))
483 (vc-restore-buffer-context context)))
484
485(defun vc-resynch-window (file &optional keep noquery)
486 "If FILE is in the current buffer, either revert or unvisit it.
487The choice between revert (to see expanded keywords) and unvisit
488depends on KEEP. NOQUERY if non-nil inhibits confirmation for
489reverting. NOQUERY should be t *only* if it is known the only
490difference between the buffer and the file is due to
491modifications by the dispatcher client code, rather than user
492editing!"
493 (and (string= buffer-file-name file)
494 (if keep
495 (progn
496 (vc-revert-buffer-internal t noquery)
497 ;; TODO: Adjusting view mode might no longer be necessary
498 ;; after RMS change to files.el of 1999-08-08. Investigate
499 ;; this when we install the new VC.
500 (and view-read-only
501 (if (file-writable-p file)
502 (and view-mode
503 (let ((view-old-buffer-read-only nil))
504 (view-mode-exit)))
505 (and (not view-mode)
506 (not (eq (get major-mode 'mode-class) 'special))
507 (view-mode-enter))))
c8d4f1a0 508 (run-hook-with-args 'modeline-hook buffer-file-name))
17f039f3
ER
509 (kill-buffer (current-buffer)))))
510
511(defun vc-resynch-buffer (file &optional keep noquery)
512 "If FILE is currently visited, resynch its buffer."
513 (if (string= buffer-file-name file)
514 (vc-resynch-window file keep noquery)
515 (let ((buffer (get-file-buffer file)))
516 (when buffer
517 (with-current-buffer buffer
518 (vc-resynch-window file keep noquery)))))
4fe2e5ed 519 (vc-directory-resynch-file file))
17f039f3 520
83affd96
ER
521;; Command closures
522
523(defun vc-start-logentry (files extra comment initial-contents msg action &optional after-hook)
524 "Accept a comment for an operation on FILES with extra data EXTRA.
525If COMMENT is nil, pop up a VC-log buffer, emit MSG, and set the
526action on close to ACTION. If COMMENT is a string and
527INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
528contents of the log entry buffer. If COMMENT is a string and
529INITIAL-CONTENTS is nil, do action immediately as if the user had
530entered COMMENT. If COMMENT is t, also do action immediately with an
531empty comment. Remember the file's buffer in `vc-parent-buffer'
532\(current one if no file). AFTER-HOOK specifies the local value
533for `vc-log-after-operation-hook'."
534 (let ((parent
4903369a
ER
535 (if (vc-dispatcher-browsing)
536 ;; If we are called from a directory browser, the parent buffer is
83affd96
ER
537 ;; the current buffer.
538 (current-buffer)
539 (if (and files (equal (length files) 1))
540 (get-file-buffer (car files))
541 (current-buffer)))))
83affd96
ER
542 (if (and comment (not initial-contents))
543 (set-buffer (get-buffer-create "*VC-log*"))
544 (pop-to-buffer (get-buffer-create "*VC-log*")))
545 (set (make-local-variable 'vc-parent-buffer) parent)
546 (set (make-local-variable 'vc-parent-buffer-name)
547 (concat " from " (buffer-name vc-parent-buffer)))
83affd96
ER
548 (vc-log-edit files)
549 (make-local-variable 'vc-log-after-operation-hook)
550 (when after-hook
551 (setq vc-log-after-operation-hook after-hook))
552 (setq vc-log-operation action)
553 (setq vc-log-extra extra)
554 (when comment
555 (erase-buffer)
556 (when (stringp comment) (insert comment)))
557 (if (or (not comment) initial-contents)
558 (message "%s Type C-c C-c when done" msg)
559 (vc-finish-logentry (eq comment t)))))
560
561(defun vc-finish-logentry (&optional nocomment)
562 "Complete the operation implied by the current log entry.
563Use the contents of the current buffer as a check-in or registration
564comment. If the optional arg NOCOMMENT is non-nil, then don't check
565the buffer contents as a comment."
566 (interactive)
567 ;; Check and record the comment, if any.
568 (unless nocomment
569 (run-hooks 'vc-logentry-check-hook))
570 ;; Sync parent buffer in case the user modified it while editing the comment.
4903369a 571 ;; But not if it is a vc-directory buffer.
83affd96 572 (with-current-buffer vc-parent-buffer
4903369a 573 (or (vc-dispatcher-browsing) (vc-buffer-sync)))
83affd96
ER
574 (unless vc-log-operation
575 (error "No log operation is pending"))
576 ;; save the parameters held in buffer-local variables
577 (let ((log-operation vc-log-operation)
578 (log-fileset vc-log-fileset)
579 (log-extra vc-log-extra)
580 (log-entry (buffer-string))
581 (after-hook vc-log-after-operation-hook)
582 (tmp-vc-parent-buffer vc-parent-buffer))
583 (pop-to-buffer vc-parent-buffer)
584 ;; OK, do it to it
585 (save-excursion
586 (funcall log-operation
587 log-fileset
588 log-extra
589 log-entry))
590 ;; Remove checkin window (after the checkin so that if that fails
591 ;; we don't zap the *VC-log* buffer and the typing therein).
592 ;; -- IMO this should be replaced with quit-window
593 (let ((logbuf (get-buffer "*VC-log*")))
594 (cond ((and logbuf vc-delete-logbuf-window)
595 (delete-windows-on logbuf (selected-frame))
596 ;; Kill buffer and delete any other dedicated windows/frames.
597 (kill-buffer logbuf))
598 (logbuf (pop-to-buffer "*VC-log*")
599 (bury-buffer)
600 (pop-to-buffer tmp-vc-parent-buffer))))
601 ;; Now make sure we see the expanded headers
602 (when log-fileset
603 (mapc
604 (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
605 log-fileset))
4903369a 606 (when (vc-dispatcher-browsing)
83affd96
ER
607 (vc-dir-move-to-goal-column))
608 (run-hooks after-hook 'vc-finish-logentry-hook)))
609
783b505b
ER
610;; The ewoc-based vc-directory implementation
611
612(defcustom vc-dir-mode-hook nil
613 "Normal hook run by `vc-dir-mode'.
614See `run-hooks'."
615 :type 'hook
616 :group 'vc)
617
618;; Used to store information for the files displayed in the *VC status* buffer.
619;; Each item displayed corresponds to one of these defstructs.
620(defstruct (vc-dir-fileinfo
621 (:copier nil)
622 (:type list) ;So we can use `member' on lists of FIs.
623 (:constructor
624 ;; We could define it as an alias for `list'.
625 vc-dir-create-fileinfo (name state &optional extra marked directory))
626 (:conc-name vc-dir-fileinfo->))
627 name ;Keep it as first, for `member'.
628 state
629 ;; For storing client-mode specific information.
630 extra
631 marked
632 ;; To keep track of not updated files during a global refresh
633 needs-update
634 ;; To distinguish files and directories.
635 directory)
636
cb625535
ER
637;; Used to describe a dispatcher client mode.
638(defstruct (vc-client-object
639 (:copier nil)
640 (:constructor
641 vc-create-client-object (name
642 headers
643 file-to-info
644 file-to-state
645 file-to-extra
646 updater))
647 (:conc-name vc-client-object->))
648 name
649 headers
650 file-to-info
651 file-to-state
652 file-to-extra
653 updater)
654
783b505b
ER
655(defvar vc-ewoc nil)
656(defvar vc-dir-process-buffer nil
657 "The buffer used for the asynchronous call that computes the VC status.")
658
659(defun vc-dir-move-to-goal-column ()
660 ;; Used to keep the cursor on the file name column.
661 (beginning-of-line)
662 ;; Must be in sync with vc-default-status-printer.
663 (forward-char 25))
664
665(defun vc-dir-prepare-status-buffer (dir &optional create-new)
666 "Find a *vc-dir* buffer showing DIR, or create a new one."
667 (setq dir (expand-file-name dir))
668 (let* ((bname "*vc-dir*")
669 ;; Look for another *vc-dir* buffer visiting the same directory.
670 (buf (save-excursion
671 (unless create-new
672 (dolist (buffer (buffer-list))
673 (set-buffer buffer)
8243c746 674 (when (and (vc-dispatcher-browsing)
783b505b
ER
675 (string= (expand-file-name default-directory) dir))
676 (return buffer)))))))
677 (or buf
678 ;; Create a new *vc-dir* buffer.
679 (with-current-buffer (create-file-buffer bname)
680 (cd dir)
681 (vc-setup-buffer (current-buffer))
682 ;; Reset the vc-parent-buffer-name so that it does not appear
683 ;; in the mode-line.
684 (setq vc-parent-buffer-name nil)
685 (current-buffer)))))
686
687(defvar vc-dir-menu-map
688 (let ((map (make-sparse-keymap "VC-dir")))
689 (define-key map [quit]
690 '(menu-item "Quit" quit-window
691 :help "Quit"))
692 (define-key map [kill]
693 '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process
694 :enable (vc-dir-busy)
695 :help "Kill the command that updates VC status buffer"))
696 (define-key map [refresh]
697 '(menu-item "Refresh" vc-dir-refresh
698 :enable (not (vc-dir-busy))
699 :help "Refresh the contents of the VC status buffer"))
700 ;; Movement.
701 (define-key map [sepmv] '("--"))
702 (define-key map [next-line]
703 '(menu-item "Next line" vc-dir-next-line
704 :help "Go to the next line" :keys "n"))
705 (define-key map [previous-line]
706 '(menu-item "Previous line" vc-dir-previous-line
707 :help "Go to the previous line"))
708 ;; Marking.
709 (define-key map [sepmrk] '("--"))
710 (define-key map [unmark-all]
711 '(menu-item "Unmark All" vc-dir-unmark-all-files
712 :help "Unmark all files that are in the same state as the current file\
713\nWith prefix argument unmark all files"))
714 (define-key map [unmark-previous]
715 '(menu-item "Unmark previous " vc-dir-unmark-file-up
716 :help "Move to the previous line and unmark the file"))
717
718 (define-key map [mark-all]
719 '(menu-item "Mark All" vc-dir-mark-all-files
720 :help "Mark all files that are in the same state as the current file\
721\nWith prefix argument mark all files"))
722 (define-key map [unmark]
723 '(menu-item "Unmark" vc-dir-unmark
724 :help "Unmark the current file or all files in the region"))
725
726 (define-key map [mark]
727 '(menu-item "Mark" vc-dir-mark
728 :help "Mark the current file or all files in the region"))
729
730 (define-key map [sepopn] '("--"))
731 (define-key map [open-other]
732 '(menu-item "Open in other window" vc-dir-find-file-other-window
733 :help "Find the file on the current line, in another window"))
734 (define-key map [open]
735 '(menu-item "Open file" vc-dir-find-file
736 :help "Find the file on the current line"))
783b505b 737 map)
9a6b551b 738 "Menu for dispatcher status")
783b505b
ER
739
740(defalias 'vc-dir-menu-map vc-dir-menu-map)
741
742(defvar vc-dir-mode-map
743 (let ((map (make-keymap)))
744 (suppress-keymap map)
745 ;; Marking.
746 (define-key map "m" 'vc-dir-mark)
747 (define-key map "M" 'vc-dir-mark-all-files)
748 (define-key map "u" 'vc-dir-unmark)
749 (define-key map "U" 'vc-dir-unmark-all-files)
750 (define-key map "\C-?" 'vc-dir-unmark-file-up)
751 (define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
752 ;; Movement.
753 (define-key map "n" 'vc-dir-next-line)
754 (define-key map " " 'vc-dir-next-line)
755 (define-key map "\t" 'vc-dir-next-line)
756 (define-key map "p" 'vc-dir-previous-line)
757 (define-key map [backtab] 'vc-dir-previous-line)
783b505b
ER
758 ;; The remainder.
759 (define-key map "f" 'vc-dir-find-file)
760 (define-key map "\C-m" 'vc-dir-find-file)
761 (define-key map "o" 'vc-dir-find-file-other-window)
783b505b
ER
762 (define-key map "q" 'quit-window)
763 (define-key map "g" 'vc-dir-refresh)
764 (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
765 (define-key map [(down-mouse-3)] 'vc-dir-menu)
766 (define-key map [(mouse-2)] 'vc-dir-toggle-mark)
9852a51d
ER
767
768 ;; FIXME: Calls back into vc.el
769 ;; Hook up the menu.
770 (define-key map [menu-bar vc-dir-mode]
771 '(menu-item
772 ;; This is used so that client modes can add mode-specific
773 ;; menu items to vc-dir-menu-map.
774 "VC Status" vc-dir-menu-map :filter vc-dir-menu-map-filter))
783b505b 775 map)
9852a51d 776 "Keymap for VC status")
783b505b
ER
777
778(defmacro vc-at-event (event &rest body)
779 "Evaluate `body' wich point located at event-start of `event'.
780If `body' uses `event', it should be a variable,
781 otherwise it will be evaluated twice."
782 (let ((posn (gensym "vc-at-event-posn")))
783 `(let ((,posn (event-start ,event)))
784 (save-excursion
785 (set-buffer (window-buffer (posn-window ,posn)))
786 (goto-char (posn-point ,posn))
787 ,@body))))
788
789(defun vc-dir-menu (e)
790 "Popup the VC status menu."
791 (interactive "e")
9852a51d 792 (vc-at-event e (popup-menu vc-dir-menu-map e)))
783b505b
ER
793
794(defvar vc-dir-tool-bar-map
795 (let ((map (make-sparse-keymap)))
796 (tool-bar-local-item-from-menu 'vc-dir-find-file "open"
797 map vc-dir-mode-map)
798 (tool-bar-local-item "bookmark_add"
799 'vc-dir-toggle-mark 'vc-dir-toggle-mark map
800 :help "Toggle mark on current item")
801 (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
802 map vc-dir-mode-map
803 :rtl "right-arrow")
804 (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow"
805 map vc-dir-mode-map
806 :rtl "left-arrow")
807 (tool-bar-local-item-from-menu 'vc-print-log "info"
808 map vc-dir-mode-map)
809 (tool-bar-local-item-from-menu 'vc-dir-refresh "refresh"
810 map vc-dir-mode-map)
811 (tool-bar-local-item-from-menu 'nonincremental-search-forward
812 "search" map)
813 (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
814 map vc-dir-mode-map)
815 (tool-bar-local-item-from-menu 'quit-window "exit"
816 map vc-dir-mode-map)
817 map))
818
819;; t if directories should be shown in vc-dir.
23532cb1
DN
820;; WORK IN PROGRESS! This variable will likely disappear when the
821;; work is done.
822(defvar vc-dir-insert-directories t)
783b505b
ER
823
824(defun vc-dir-update (entries buffer &optional noinsert)
825 "Update BUFFER's ewoc from the list of ENTRIES.
826If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
827 ;; Add ENTRIES to the vc-dir buffer BUFFER.
828 (with-current-buffer buffer
829 ;; Insert the entries sorted by name into the ewoc.
830 ;; We assume the ewoc is sorted too, which should be the
831 ;; case if we always add entries with vc-dir-update.
832 (setq entries
833 ;; Sort: first files and then subdirectories.
834 ;; XXX: this is VERY inefficient, it computes the directory
835 ;; names too many times
836 (sort entries
837 (lambda (entry1 entry2)
838 (let ((dir1 (file-name-directory (expand-file-name (car entry1))))
839 (dir2 (file-name-directory (expand-file-name (car entry2)))))
840 (cond
841 ((string< dir1 dir2) t)
842 ((not (string= dir1 dir2)) nil)
843 ((string< (car entry1) (car entry2))))))))
844 (if (not vc-dir-insert-directories)
845 (let ((entry (car entries))
846 (node (ewoc-nth vc-ewoc 0)))
847 (while (and entry node)
848 (let ((entryfile (car entry))
849 (nodefile (vc-dir-fileinfo->name (ewoc-data node))))
850 (cond
851 ((string-lessp nodefile entryfile)
852 (setq node (ewoc-next vc-ewoc node)))
853 ((string-lessp entryfile nodefile)
854 (unless noinsert
855 (ewoc-enter-before vc-ewoc node
856 (apply 'vc-dir-create-fileinfo entry)))
857 (setq entries (cdr entries) entry (car entries)))
858 (t
859 (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
860 (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
861 (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
862 (ewoc-invalidate vc-ewoc node)
863 (setq entries (cdr entries) entry (car entries))
864 (setq node (ewoc-next vc-ewoc node))))))
865 (unless (or node noinsert)
866 ;; We're past the last node, all remaining entries go to the end.
867 (while entries
868 (ewoc-enter-last vc-ewoc
869 (apply 'vc-dir-create-fileinfo (pop entries))))))
870 ;; Insert directory entries in the right places.
871 (let ((entry (car entries))
872 (node (ewoc-nth vc-ewoc 0)))
873 ;; Insert . if it is not present.
874 (unless node
875 (let ((rd (file-relative-name default-directory)))
876 (ewoc-enter-last
877 vc-ewoc (vc-dir-create-fileinfo
878 rd nil nil nil (expand-file-name default-directory))))
879 (setq node (ewoc-nth vc-ewoc 0)))
880
881 (while (and entry node)
882 (let* ((entryfile (car entry))
883 (entrydir (file-name-directory (expand-file-name entryfile)))
884 (nodedir
885 (or (vc-dir-fileinfo->directory (ewoc-data node))
886 (file-name-directory
887 (expand-file-name
888 (vc-dir-fileinfo->name (ewoc-data node)))))))
889 (cond
890 ;; First try to find the directory.
891 ((string-lessp nodedir entrydir)
892 (setq node (ewoc-next vc-ewoc node)))
893 ((string-equal nodedir entrydir)
894 ;; Found the directory, find the place for the file name.
895 (let ((nodefile (vc-dir-fileinfo->name (ewoc-data node))))
896 (cond
897 ((string-lessp nodefile entryfile)
898 (setq node (ewoc-next vc-ewoc node)))
899 ((string-equal nodefile entryfile)
900 (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
901 (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
902 (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
903 (ewoc-invalidate vc-ewoc node)
904 (setq entries (cdr entries) entry (car entries))
905 (setq node (ewoc-next vc-ewoc node)))
906 (t
907 (ewoc-enter-before vc-ewoc node
908 (apply 'vc-dir-create-fileinfo entry))
909 (setq entries (cdr entries) entry (car entries))))))
910 (t
911 ;; We need to insert a directory node
912 (let ((rd (file-relative-name entrydir)))
913 (ewoc-enter-last
914 vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir)))
915 ;; Now insert the node itself.
916 (ewoc-enter-before vc-ewoc node
917 (apply 'vc-dir-create-fileinfo entry))
918 (setq entries (cdr entries) entry (car entries))))))
919 ;; We're past the last node, all remaining entries go to the end.
920 (unless (or node noinsert)
921 (let* ((lastnode (ewoc-nth vc-ewoc -1))
922 (lastdir
923 (or (vc-dir-fileinfo->directory (ewoc-data lastnode))
924 (file-name-directory
925 (expand-file-name
926 (vc-dir-fileinfo->name (ewoc-data lastnode)))))))
927 (dolist (entry entries)
928 (let ((entrydir (file-name-directory (expand-file-name (car entry)))))
929 ;; Insert a directory node if needed.
930 (unless (string-equal lastdir entrydir)
931 (setq lastdir entrydir)
932 (let ((rd (file-relative-name entrydir)))
933 (ewoc-enter-last
934 vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))))
935 ;; Now insert the node itself.
936 (ewoc-enter-last vc-ewoc
937 (apply 'vc-dir-create-fileinfo entry))))))))))
938
939(defun vc-dir-busy ()
940 (and (buffer-live-p vc-dir-process-buffer)
941 (get-buffer-process vc-dir-process-buffer)))
942
943(defun vc-dir-kill-dir-status-process ()
944 "Kill the temporary buffer and associated process."
945 (interactive)
946 (when (buffer-live-p vc-dir-process-buffer)
947 (let ((proc (get-buffer-process vc-dir-process-buffer)))
948 (when proc (delete-process proc))
949 (setq vc-dir-process-buffer nil)
950 (setq mode-line-process nil))))
951
952(defun vc-dir-kill-query ()
953 ;; Make sure that when the VC status buffer is killed the update
954 ;; process running in background is also killed.
955 (if (vc-dir-busy)
956 (when (y-or-n-p "Status update process running, really kill status buffer?")
957 (vc-dir-kill-dir-status-process)
958 t)
959 t))
960
961(defun vc-dir-next-line (arg)
962 "Go to the next line.
963If a prefix argument is given, move by that many lines."
964 (interactive "p")
965 (ewoc-goto-next vc-ewoc arg)
966 (vc-dir-move-to-goal-column))
967
968(defun vc-dir-previous-line (arg)
969 "Go to the previous line.
970If a prefix argument is given, move by that many lines."
971 (interactive "p")
972 (ewoc-goto-prev vc-ewoc arg)
973 (vc-dir-move-to-goal-column))
974
975(defun vc-dir-mark-unmark (mark-unmark-function)
976 (if (use-region-p)
977 (let ((firstl (line-number-at-pos (region-beginning)))
978 (lastl (line-number-at-pos (region-end))))
979 (save-excursion
980 (goto-char (region-beginning))
981 (while (<= (line-number-at-pos) lastl)
982 (funcall mark-unmark-function))))
983 (funcall mark-unmark-function)))
984
985(defun vc-dir-parent-marked-p (arg)
986 (when vc-dir-insert-directories
987 ;; Return nil if none of the parent directories of arg is marked.
988 (let* ((argdata (ewoc-data arg))
989 (argdir
990 (let ((crtdir (vc-dir-fileinfo->directory argdata)))
991 (if crtdir
992 crtdir
993 (file-name-directory (expand-file-name
994 (vc-dir-fileinfo->name argdata))))))
995 (arglen (length argdir))
996 (crt arg)
997 data dir)
998 ;; Go through the predecessors, checking if any directory that is
999 ;; a parent is marked.
1000 (while (setq crt (ewoc-prev vc-ewoc crt))
1001 (setq data (ewoc-data crt))
1002 (setq dir
1003 (let ((crtdir (vc-dir-fileinfo->directory data)))
1004 (if crtdir
1005 crtdir
1006 (file-name-directory (expand-file-name
1007 (vc-dir-fileinfo->name data))))))
1008
1009 (when (and (vc-dir-fileinfo->directory data)
1010 (string-equal (substring argdir 0 (length dir)) dir))
1011 (when (vc-dir-fileinfo->marked data)
1012 (error "Cannot mark `%s', parent directory `%s' marked"
1013 (vc-dir-fileinfo->name argdata)
1014 (vc-dir-fileinfo->name data)))))
1015 nil)))
1016
1017(defun vc-dir-children-marked-p (arg)
1018 ;; Return nil if none of the children of arg is marked.
1019 (when vc-dir-insert-directories
1020 (let* ((argdata (ewoc-data arg))
1021 (argdir (vc-dir-fileinfo->directory argdata))
1022 (arglen (length argdir))
1023 (is-child t)
1024 (crt arg)
1025 data dir)
1026 (while (and is-child (setq crt (ewoc-next vc-ewoc crt)))
1027 (setq data (ewoc-data crt))
1028 (setq dir
1029 (let ((crtdir (vc-dir-fileinfo->directory data)))
1030 (if crtdir
1031 crtdir
1032 (file-name-directory (expand-file-name
1033 (vc-dir-fileinfo->name data))))))
1034 (if (string-equal argdir (substring dir 0 arglen))
1035 (when (vc-dir-fileinfo->marked data)
1036 (error "Cannot mark `%s', child `%s' marked"
1037 (vc-dir-fileinfo->name argdata)
1038 (vc-dir-fileinfo->name data)))
1039 ;; We are done, we got to an entry that is not a child of `arg'.
1040 (setq is-child nil)))
1041 nil)))
1042
1043(defun vc-dir-mark-file (&optional arg)
1044 ;; Mark ARG or the current file and move to the next line.
1045 (let* ((crt (or arg (ewoc-locate vc-ewoc)))
1046 (file (ewoc-data crt))
1047 (isdir (vc-dir-fileinfo->directory file)))
1048 (when (or (and isdir (not (vc-dir-children-marked-p crt)))
1049 (and (not isdir) (not (vc-dir-parent-marked-p crt))))
1050 (setf (vc-dir-fileinfo->marked file) t)
1051 (ewoc-invalidate vc-ewoc crt)
1052 (unless (or arg (mouse-event-p last-command-event))
1053 (vc-dir-next-line 1)))))
1054
1055(defun vc-dir-mark ()
1056 "Mark the current file or all files in the region.
1057If the region is active, mark all the files in the region.
1058Otherwise mark the file on the current line and move to the next
1059line."
1060 (interactive)
1061 (vc-dir-mark-unmark 'vc-dir-mark-file))
1062
1063(defun vc-dir-mark-all-files (arg)
1064 "Mark all files with the same state as the current one.
1065With a prefix argument mark all files.
1066If the current entry is a directory, mark all child files.
1067
1068The VC commands operate on files that are on the same state.
1069This command is intended to make it easy to select all files that
1070share the same state."
1071 (interactive "P")
1072 (if arg
1073 ;; Mark all files.
1074 (progn
1075 ;; First check that no directory is marked, we can't mark
1076 ;; files in that case.
1077 (ewoc-map
1078 (lambda (filearg)
1079 (when (and (vc-dir-fileinfo->directory filearg)
1080 (vc-dir-fileinfo->directory filearg))
1081 (error "Cannot mark all files, directory `%s' marked"
1082 (vc-dir-fileinfo->name filearg))))
1083 vc-ewoc)
1084 (ewoc-map
1085 (lambda (filearg)
1086 (unless (vc-dir-fileinfo->marked filearg)
1087 (setf (vc-dir-fileinfo->marked filearg) t)
1088 t))
1089 vc-ewoc))
1090 (let ((data (ewoc-data (ewoc-locate vc-ewoc))))
1091 (if (vc-dir-fileinfo->directory data)
1092 ;; It's a directory, mark child files.
1093 (let ((crt (ewoc-locate vc-ewoc)))
1094 (unless (vc-dir-children-marked-p crt)
1095 (while (setq crt (ewoc-next vc-ewoc crt))
1096 (let ((crt-data (ewoc-data crt)))
1097 (unless (vc-dir-fileinfo->directory crt-data)
1098 (setf (vc-dir-fileinfo->marked crt-data) t)
1099 (ewoc-invalidate vc-ewoc crt))))))
1100 ;; It's a file
1101 (let ((state (vc-dir-fileinfo->state data))
1102 (crt (ewoc-nth vc-ewoc 0)))
1103 (while crt
1104 (let ((crt-data (ewoc-data crt)))
1105 (when (and (not (vc-dir-fileinfo->marked crt-data))
1106 (eq (vc-dir-fileinfo->state crt-data) state)
1107 (not (vc-dir-fileinfo->directory crt-data)))
1108 (vc-dir-mark-file crt)))
1109 (setq crt (ewoc-next vc-ewoc crt))))))))
1110
1111(defun vc-dir-unmark-file ()
1112 ;; Unmark the current file and move to the next line.
1113 (let* ((crt (ewoc-locate vc-ewoc))
1114 (file (ewoc-data crt)))
1115 (setf (vc-dir-fileinfo->marked file) nil)
1116 (ewoc-invalidate vc-ewoc crt)
1117 (unless (mouse-event-p last-command-event)
1118 (vc-dir-next-line 1))))
1119
1120(defun vc-dir-unmark ()
1121 "Unmark the current file or all files in the region.
1122If the region is active, unmark all the files in the region.
1123Otherwise mark the file on the current line and move to the next
1124line."
1125 (interactive)
1126 (vc-dir-mark-unmark 'vc-dir-unmark-file))
1127
1128(defun vc-dir-unmark-file-up ()
1129 "Move to the previous line and unmark the file."
1130 (interactive)
1131 ;; If we're on the first line, we won't move up, but we will still
1132 ;; remove the mark. This seems a bit odd but it is what buffer-menu
1133 ;; does.
1134 (let* ((prev (ewoc-goto-prev vc-ewoc 1))
1135 (file (ewoc-data prev)))
1136 (setf (vc-dir-fileinfo->marked file) nil)
1137 (ewoc-invalidate vc-ewoc prev)
1138 (vc-dir-move-to-goal-column)))
1139
1140(defun vc-dir-unmark-all-files (arg)
1141 "Unmark all files with the same state as the current one.
1142With a prefix argument unmark all files.
1143If the current entry is a directory, unmark all the child files.
1144
1145The VC commands operate on files that are on the same state.
1146This command is intended to make it easy to deselect all files
1147that share the same state."
1148 (interactive "P")
1149 (if arg
1150 (ewoc-map
1151 (lambda (filearg)
1152 (when (vc-dir-fileinfo->marked filearg)
1153 (setf (vc-dir-fileinfo->marked filearg) nil)
1154 t))
1155 vc-ewoc)
1156 (let* ((crt (ewoc-locate vc-ewoc))
1157 (data (ewoc-data crt)))
1158 (if (vc-dir-fileinfo->directory data)
1159 ;; It's a directory, unmark child files.
1160 (while (setq crt (ewoc-next vc-ewoc crt))
1161 (let ((crt-data (ewoc-data crt)))
1162 (unless (vc-dir-fileinfo->directory crt-data)
1163 (setf (vc-dir-fileinfo->marked crt-data) nil)
1164 (ewoc-invalidate vc-ewoc crt))))
1165 ;; It's a file
1166 (let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt))))
1167 (ewoc-map
1168 (lambda (filearg)
1169 (when (and (vc-dir-fileinfo->marked filearg)
1170 (eq (vc-dir-fileinfo->state filearg) crt-state))
1171 (setf (vc-dir-fileinfo->marked filearg) nil)
1172 t))
1173 vc-ewoc))))))
1174
1175(defun vc-dir-toggle-mark-file ()
1176 (let* ((crt (ewoc-locate vc-ewoc))
1177 (file (ewoc-data crt)))
1178 (if (vc-dir-fileinfo->marked file)
1179 (vc-dir-unmark-file)
1180 (vc-dir-mark-file))))
1181
1182(defun vc-dir-toggle-mark (e)
1183 (interactive "e")
1184 (vc-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file)))
1185
1186(defun vc-dir-delete-file ()
1187 "Delete the marked files, or the current file if no marks."
1188 (interactive)
1189 (mapc 'vc-delete-file (or (vc-dir-marked-files)
1190 (list (vc-dir-current-file)))))
1191
1192(defun vc-dir-find-file ()
1193 "Find the file on the current line."
1194 (interactive)
1195 (find-file (vc-dir-current-file)))
1196
1197(defun vc-dir-find-file-other-window ()
1198 "Find the file on the current line, in another window."
1199 (interactive)
1200 (find-file-other-window (vc-dir-current-file)))
1201
1202(defun vc-dir-current-file ()
1203 (let ((node (ewoc-locate vc-ewoc)))
1204 (unless node
1205 (error "No file available."))
1206 (expand-file-name (vc-dir-fileinfo->name (ewoc-data node)))))
1207
1208(defun vc-dir-marked-files ()
1209 "Return the list of marked files."
1210 (mapcar
1211 (lambda (elem) (expand-file-name (vc-dir-fileinfo->name elem)))
1212 (ewoc-collect vc-ewoc 'vc-dir-fileinfo->marked)))
1213
1214(defun vc-dir-marked-only-files ()
cb625535 1215 "Return the list of marked files, For marked directories return child files."
783b505b
ER
1216 (let ((crt (ewoc-nth vc-ewoc 0))
1217 result)
1218 (while crt
1219 (let ((crt-data (ewoc-data crt)))
1220 (if (vc-dir-fileinfo->marked crt-data)
1221 (if (vc-dir-fileinfo->directory crt-data)
1222 (let* ((dir (vc-dir-fileinfo->directory crt-data))
1223 (dirlen (length dir))
1224 data)
1225 (while
1226 (and (setq crt (ewoc-next vc-ewoc crt))
1227 (string-equal
1228 (substring
1229 (progn
1230 (setq data (ewoc-data crt))
1231 (let ((crtdir (vc-dir-fileinfo->directory data)))
1232 (if crtdir
1233 crtdir
1234 (file-name-directory
1235 (expand-file-name
1236 (vc-dir-fileinfo->name data))))))
1237 0 dirlen)
1238 dir))
1239 (unless (vc-dir-fileinfo->directory data)
1240 (push (vc-dir-fileinfo->name data) result))))
1241 (push (expand-file-name (vc-dir-fileinfo->name crt-data)) result)
1242 (setq crt (ewoc-next vc-ewoc crt)))
1243 (setq crt (ewoc-next vc-ewoc crt)))))
1244 result))
038608c7 1245
4fe2e5ed
ER
1246(defun vc-directory-resynch-file (&optional fname)
1247 "Update the entries for FILE in any directory buffers that list it."
1248 (let ((file (or fname (expand-file-name buffer-file-name))))
4fe2e5ed
ER
1249 ;; The vc-dir case
1250 (let ((found-vc-dir-buf nil))
1251 (save-excursion
1252 (dolist (status-buf (buffer-list))
1253 (set-buffer status-buf)
1254 ;; look for a vc-dir buffer that might show this file.
1255 (when (eq major-mode 'vc-dir-mode)
1256 (setq found-vc-dir-buf t)
1257 (let ((ddir (expand-file-name default-directory)))
1258 ;; This test is cvs-string-prefix-p
1259 (when (eq t (compare-strings file nil (length ddir) ddir nil nil))
1260 (let*
1261 ((file-short (substring file (length ddir)))
1262 (state
1263 (funcall (vc-client-object->file-to-state vc-client-mode)
1264 file))
1265 (extra
1266 (funcall (vc-client-object->file-to-extra vc-client-mode)
1267 file))
1268 (entry
1269 (list file-short state extra)))
1270 (vc-dir-update (list entry) status-buf))))))
1271 ;; We didn't find any vc-dir buffers, remove the hook, it is
1272 ;; not needed.
1273 (unless found-vc-dir-buf (remove-hook 'after-save-hook 'vc-directory-resynch-file))))))
cb625535
ER
1274
1275(defun vc-dir-mode (client-object)
1276 "Major mode for showing the VC status for a directory.
1277Marking/Unmarking key bindings and actions:
1278m - marks a file/directory or if the region is active, mark all the files
1279 in region.
1280 Restrictions: - a file cannot be marked if any parent directory is marked
1281 - a directory cannot be marked if any child file or
1282 directory is marked
1283u - marks a file/directory or if the region is active, unmark all the files
1284 in region.
1285M - if the cursor is on a file: mark all the files with the same VC state as
1286 the current file
1287 - if the cursor is on a directory: mark all child files
1288 - with a prefix argument: mark all files
1289U - if the cursor is on a file: unmark all the files with the same VC state
1290 as the current file
1291 - if the cursor is on a directory: unmark all child files
1292 - with a prefix argument: unmark all files
1293
1294
1295\\{vc-dir-mode-map}"
1296 (setq mode-name (vc-client-object->name client-object))
1297 (setq major-mode 'vc-dir-mode)
1298 (setq buffer-read-only t)
1299 (use-local-map vc-dir-mode-map)
1300 (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)
6494957a 1301 (set (make-local-variable 'vc-client-mode) client-object)
cb625535
ER
1302 (let ((buffer-read-only nil))
1303 (erase-buffer)
1304 (set (make-local-variable 'vc-dir-process-buffer) nil)
1305 (set (make-local-variable 'vc-ewoc)
1306 (ewoc-create (vc-client-object->file-to-info client-object)
1307 (vc-client-object->headers client-object)))
4fe2e5ed 1308 (add-hook 'after-save-hook 'vc-directory-resynch-file)
cb625535
ER
1309 ;; Make sure that if the VC status buffer is killed, the update
1310 ;; process running in the background is also killed.
1311 (add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
1312 (funcall (vc-client-object->updater client-object)))
1313 (run-hooks 'vc-dir-mode-hook))
1314
1315(put 'vc-dir-mode 'mode-class 'special)
1316
be636037
ER
1317(defun vc-buffer-sync (&optional not-urgent)
1318 "Make sure the current buffer and its working file are in sync.
1319NOT-URGENT means it is ok to continue if the user says not to save."
1320 (when (buffer-modified-p)
1321 (if (or vc-suppress-confirm
1322 (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
1323 (save-buffer)
1324 (unless not-urgent
1325 (error "Aborted")))))
1326
b236ab0d
ER
1327(defun vc-dispatcher-browsing ()
1328 "Are we in a directory browser buffer?"
8243c746
SM
1329 (derived-mode-p 'vc-dir-mode))
1330
1331(defun vc-dispatcher-in-fileset-p (fileset)
1332 (let ((member nil))
1333 (while (and (not member) fileset)
1334 (let ((elem (pop fileset)))
1335 (if (if (file-directory-p elem)
1336 (eq t (compare-strings buffer-file-name nil (length elem)
1337 elem nil nil))
1338 (eq (current-buffer) (get-file-buffer elem)))
713b6f81
SM
1339 (setq member t))))
1340 member))
b236ab0d 1341
86048828 1342(defun vc-dispatcher-selection-set ()
b236ab0d 1343 "Deduce a set of files to which to apply an operation. Return the fileset.
86048828
ER
1344If we're in a directory display, the fileset is the list of marked files (if
1345there is one) else the file on the curreent line. If not in a directory
1346display, but the current buffer visits a file, the fileset is a singleton
1347containing that file. Otherwise, throw an error."
be636037 1348 (let ((files
b236ab0d 1349 (cond
b236ab0d 1350 ;; Browsing with vc-dir
86048828
ER
1351 ((vc-dispatcher-browsing)
1352 (or (vc-dir-marked-files) (list (vc-dir-current-file))))
b236ab0d 1353 ;; Visiting an eligible file
86048828 1354 ((buffer-file-name)
b236ab0d 1355 (list buffer-file-name))
86048828 1356 ;; No eligible file -- if there's a parent buffer, deduce from there
b236ab0d
ER
1357 ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
1358 (with-current-buffer vc-parent-buffer
1359 (vc-dispatcher-browsing))))
86048828
ER
1360 (with-current-buffer vc-parent-buffer
1361 (vc-dispatcher-selection-set)))
b236ab0d 1362 ;; No good set here, throw error
be636037 1363 (t (error "No fileset is available here.")))))
8243c746
SM
1364 ;; We assume, in order to avoid unpleasant surprises to the user,
1365 ;; that a fileset is not in good shape to be handed to the user if the
86048828 1366 ;; buffers visiting the fileset don't match the on-disk contents.
8243c746
SM
1367 ;; This is actually untrue for operations like `print-log' (or `diff'
1368 ;; between two revisions), so maybe this should be moved elsewhere.
1369 (save-some-buffers
1370 nil (lambda () (vc-dispatcher-in-fileset-p fileset)))
be636037 1371 files))
b236ab0d 1372
3eb20677 1373;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
b1ddeeb7 1374;;; vc-dispatcher.el ends here