* vc.el (vc-root-diff): Doc fix.
[emacs.git] / lisp / vc-dispatcher.el
blob40223c9010d01afc5716fc553c0487f79806fcd7
1 ;;; vc-dispatcher.el -- generic command-dispatcher facility.
3 ;; Copyright (C) 2008, 2009, 2010
4 ;; Free Software Foundation, Inc.
6 ;; Author: FSF (see below for full credits)
7 ;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
8 ;; Keywords: tools
10 ;; This file is part of GNU Emacs.
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 of the License, or
15 ;; (at your option) any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;;; Credits:
27 ;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
28 ;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
29 ;; vc-dir front end.
31 ;;; Commentary:
33 ;; Goals:
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.
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.
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.
54 ;; Dispatcher's universe:
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.
61 ;; The user may be looking at either of two different views; a buffer
62 ;; visiting a file, or a directory buffer generated by vc-dispatcher.
64 ;; The lower layer of this mode runs commands in subprocesses, either
65 ;; synchronously or asynchronously. Commands may be launched in one
66 ;; of two ways: they may be run immediately, or the calling mode can
67 ;; create a closure associated with a text-entry buffer, to be
68 ;; executed when the user types C-c to ship the buffer contents. In
69 ;; either case the command messages and error (if any) will remain
70 ;; available in a status buffer.
72 ;; Special behavior of dispatcher directory buffers:
74 ;; In dispatcher directory buffers, facilities to perform basic
75 ;; navigation and selection operations are provided by keymap and menu
76 ;; entries that dispatcher sets up itself, so they'll be uniform
77 ;; across all dispatcher-using client modes. Client modes are
78 ;; expected to append to these to provide mode-specific bindings.
80 ;; The standard map associates a 'state' slot (that the client mode
81 ;; may set) with each directory entry. The dispatcher knows nothing
82 ;; about the semantics of individual states, but mark and unmark commands
83 ;; treat all entries with the same state as the currently selected one as
84 ;; a unit.
86 ;; The interface:
88 ;; The main interface to the lower level is vc-do-command. This launches a
89 ;; command, synchronously or asynchronously, making the output available
90 ;; in a command log buffer. Two other functions, (vc-start-logentry) and
91 ;; (vc-finish-logentry), allow you to associate a command closure with an
92 ;; annotation buffer so that when the user confirms the comment the closure
93 ;; is run (with the comment as part of its context).
95 ;; The interface to the upper level has the two main entry points (vc-dir)
96 ;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
97 ;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
98 ;; returns a selection set of files, either the marked files in a browsing
99 ;; buffer or the singleton set consisting of the file visited by the current
100 ;; buffer (when that is appropriate). It also does what is needed to ensure
101 ;; that on-disk files and the contents of their visiting Emacs buffers
102 ;; coincide.
104 ;; When the client mode adds a local mode-line-hook to a buffer, it
105 ;; will be called with the buffer file name as argument whenever the
106 ;; dispatcher resynchs the buffer.
108 ;; To do:
110 ;; - log buffers need font-locking.
113 ;; General customization
114 (defcustom vc-logentry-check-hook nil
115 "Normal hook run by `vc-finish-logentry'.
116 Use this to impose your own rules on the entry in addition to any the
117 dispatcher client mode imposes itself."
118 :type 'hook
119 :group 'vc)
121 (defcustom vc-delete-logbuf-window t
122 "If non-nil, delete the log buffer and window after each logical action.
123 If nil, bury that buffer instead.
124 This is most useful if you have multiple windows on a frame and would like to
125 preserve the setting."
126 :type 'boolean
127 :group 'vc)
129 (defcustom vc-command-messages nil
130 "If non-nil, display run messages from back-end commands."
131 :type 'boolean
132 :group 'vc)
134 (defcustom vc-suppress-confirm nil
135 "If non-nil, treat user as expert; suppress yes-no prompts on some things."
136 :type 'boolean
137 :group 'vc)
139 ;; Variables the user doesn't need to know about.
141 (defvar vc-log-operation nil)
142 (defvar vc-log-after-operation-hook nil)
143 (defvar vc-log-fileset)
144 (defvar vc-log-extra)
146 ;; In a log entry buffer, this is a local variable
147 ;; that points to the buffer for which it was made
148 ;; (either a file, or a directory buffer).
149 (defvar vc-parent-buffer nil)
150 (put 'vc-parent-buffer 'permanent-local t)
151 (defvar vc-parent-buffer-name nil)
152 (put 'vc-parent-buffer-name 'permanent-local t)
154 ;; Common command execution logic
156 (defun vc-process-filter (p s)
157 "An alternative output filter for async process P.
158 One difference with the default filter is that this inserts S after markers.
159 Another is that undo information is not kept."
160 (let ((buffer (process-buffer p)))
161 (when (buffer-live-p buffer)
162 (with-current-buffer buffer
163 (save-excursion
164 (let ((buffer-undo-list t)
165 (inhibit-read-only t))
166 (goto-char (process-mark p))
167 (insert s)
168 (set-marker (process-mark p) (point))))))))
170 (defun vc-setup-buffer (buf)
171 "Prepare BUF for executing a slave command and make it current."
172 (let ((camefrom (current-buffer))
173 (olddir default-directory))
174 (set-buffer (get-buffer-create buf))
175 (kill-all-local-variables)
176 (set (make-local-variable 'vc-parent-buffer) camefrom)
177 (set (make-local-variable 'vc-parent-buffer-name)
178 (concat " from " (buffer-name camefrom)))
179 (setq default-directory olddir)
180 (let ((buffer-undo-list t)
181 (inhibit-read-only t))
182 (erase-buffer))))
184 (defvar vc-sentinel-movepoint) ;Dynamically scoped.
186 (defun vc-process-sentinel (p s)
187 (let ((previous (process-get p 'vc-previous-sentinel))
188 (buf (process-buffer p)))
189 ;; Impatient users sometime kill "slow" buffers; check liveness
190 ;; to avoid "error in process sentinel: Selecting deleted buffer".
191 (when (buffer-live-p buf)
192 (when previous (funcall previous p s))
193 (with-current-buffer buf
194 (setq mode-line-process
195 (let ((status (process-status p)))
196 ;; Leave mode-line uncluttered, normally.
197 (unless (eq 'exit status)
198 (format " (%s)" status))))
199 (let (vc-sentinel-movepoint)
200 ;; Normally, we want async code such as sentinels to not move point.
201 (save-excursion
202 (goto-char (process-mark p))
203 (let ((cmds (process-get p 'vc-sentinel-commands)))
204 (process-put p 'vc-sentinel-commands nil)
205 (dolist (cmd cmds)
206 ;; Each sentinel may move point and the next one should be run
207 ;; at that new point. We could get the same result by having
208 ;; each sentinel read&set process-mark, but since `cmd' needs
209 ;; to work both for async and sync processes, this would be
210 ;; difficult to achieve.
211 (vc-exec-after cmd))))
212 ;; But sometimes the sentinels really want to move point.
213 (when vc-sentinel-movepoint
214 (let ((win (get-buffer-window (current-buffer) 0)))
215 (if (not win)
216 (goto-char vc-sentinel-movepoint)
217 (with-selected-window win
218 (goto-char vc-sentinel-movepoint))))))))))
220 (defun vc-set-mode-line-busy-indicator ()
221 (setq mode-line-process
222 (concat " " (propertize "[waiting...]"
223 'face 'mode-line-emphasis
224 'help-echo
225 "A command is in progress in this buffer"))))
227 (defun vc-exec-after (code)
228 "Eval CODE when the current buffer's process is done.
229 If the current buffer has no process, just evaluate CODE.
230 Else, add CODE to the process' sentinel."
231 (let ((proc (get-buffer-process (current-buffer))))
232 (cond
233 ;; If there's no background process, just execute the code.
234 ;; We used to explicitly call delete-process on exited processes,
235 ;; but this led to timing problems causing process output to be
236 ;; lost. Terminated processes get deleted automatically
237 ;; anyway. -- cyd
238 ((or (null proc) (eq (process-status proc) 'exit))
239 ;; Make sure we've read the process's output before going further.
240 (when proc (accept-process-output proc))
241 (eval code))
242 ;; If a process is running, add CODE to the sentinel
243 ((eq (process-status proc) 'run)
244 (vc-set-mode-line-busy-indicator)
245 (let ((previous (process-sentinel proc)))
246 (unless (eq previous 'vc-process-sentinel)
247 (process-put proc 'vc-previous-sentinel previous))
248 (set-process-sentinel proc 'vc-process-sentinel))
249 (process-put proc 'vc-sentinel-commands
250 ;; We keep the code fragments in the order given
251 ;; so that vc-diff-finish's message shows up in
252 ;; the presence of non-nil vc-command-messages.
253 (append (process-get proc 'vc-sentinel-commands)
254 (list code))))
255 (t (error "Unexpected process state"))))
256 nil)
258 (defvar vc-post-command-functions nil
259 "Hook run at the end of `vc-do-command'.
260 Each function is called inside the buffer in which the command was run
261 and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
263 (defvar w32-quote-process-args)
265 (defun vc-delistify (filelist)
266 "Smash a FILELIST into a file list string suitable for info messages."
267 ;; FIXME what about file names with spaces?
268 (if (not filelist) "." (mapconcat 'identity filelist " ")))
270 ;;;###autoload
271 (defun vc-do-command (buffer okstatus command file-or-list &rest flags)
272 "Execute a slave command, notifying user and checking for errors.
273 Output from COMMAND goes to BUFFER, or the current buffer if
274 BUFFER is t. If the destination buffer is not already current,
275 set it up properly and erase it. The command is considered
276 successful if its exit status does not exceed OKSTATUS (if
277 OKSTATUS is nil, that means to ignore error status, if it is
278 `async', that means not to wait for termination of the
279 subprocess; if it is t it means to ignore all execution errors).
280 FILE-OR-LIST is the name of a working file; it may be a list of
281 files or be nil (to execute commands that don't expect a file
282 name or set of files). If an optional list of FLAGS is present,
283 that is inserted into the command line before the filename.
284 Return the return value of the slave command in the synchronous
285 case, and the process object in the asynchronous case."
286 ;; FIXME: file-relative-name can return a bogus result because
287 ;; it doesn't look at the actual file-system to see if symlinks
288 ;; come into play.
289 (let* ((files
290 (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
291 (if (listp file-or-list) file-or-list (list file-or-list))))
292 (full-command
293 ;; What we're doing here is preparing a version of the command
294 ;; for display in a debug-progress message. If it's fewer than
295 ;; 20 characters display the entire command (without trailing
296 ;; newline). Otherwise display the first 20 followed by an ellipsis.
297 (concat (if (string= (substring command -1) "\n")
298 (substring command 0 -1)
299 command)
301 (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
302 " " (vc-delistify files))))
303 (save-current-buffer
304 (unless (or (eq buffer t)
305 (and (stringp buffer)
306 (string= (buffer-name) buffer))
307 (eq buffer (current-buffer)))
308 (vc-setup-buffer buffer))
309 ;; If there's some previous async process still running, just kill it.
310 (let ((oldproc (get-buffer-process (current-buffer))))
311 ;; If we wanted to wait for oldproc to finish before doing
312 ;; something, we'd have used vc-eval-after.
313 ;; Use `delete-process' rather than `kill-process' because we don't
314 ;; want any of its output to appear from now on.
315 (when oldproc (delete-process oldproc)))
316 (let ((squeezed (remq nil flags))
317 (inhibit-read-only t)
318 (status 0))
319 (when files
320 (setq squeezed (nconc squeezed files)))
321 (let ((exec-path (append vc-path exec-path))
322 ;; Add vc-path to PATH for the execution of this command.
323 ;; Also, since some functions need to parse the output
324 ;; from external commands, set LC_MESSAGES to C.
325 (process-environment
326 (cons (concat "PATH=" (getenv "PATH")
327 path-separator
328 (mapconcat 'identity vc-path path-separator))
329 (cons "LC_MESSAGES=C"
330 process-environment)))
331 (w32-quote-process-args t))
332 (if (eq okstatus 'async)
333 ;; Run asynchronously.
334 (let ((proc
335 (let ((process-connection-type nil))
336 (apply 'start-file-process command (current-buffer)
337 command squeezed))))
338 (when vc-command-messages
339 (message "Running %s in background..." full-command))
340 ;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
341 (set-process-filter proc 'vc-process-filter)
342 (setq status proc)
343 (when vc-command-messages
344 (vc-exec-after
345 `(message "Running %s in background... done" ',full-command))))
346 ;; Run synchronously
347 (when vc-command-messages
348 (message "Running %s in foreground..." full-command))
349 (let ((buffer-undo-list t))
350 (setq status (apply 'process-file command nil t nil squeezed)))
351 (when (and (not (eq t okstatus))
352 (or (not (integerp status))
353 (and okstatus (< okstatus status))))
354 (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
355 (pop-to-buffer (current-buffer))
356 (goto-char (point-min))
357 (shrink-window-if-larger-than-buffer))
358 (error "Running %s...FAILED (%s)" full-command
359 (if (integerp status) (format "status %d" status) status)))
360 (when vc-command-messages
361 (message "Running %s...OK = %d" full-command status))))
362 (vc-exec-after
363 `(run-hook-with-args 'vc-post-command-functions
364 ',command ',file-or-list ',flags))
365 status))))
367 ;; These functions are used to ensure that the view the user sees is up to date
368 ;; even if the dispatcher client mode has messed with file contents (as in,
369 ;; for example, VCS keyword expansion).
371 (declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
373 (defun vc-position-context (posn)
374 "Save a bit of the text around POSN in the current buffer.
375 Used to help us find the corresponding position again later
376 if markers are destroyed or corrupted."
377 ;; A lot of this was shamelessly lifted from Sebastian Kremer's
378 ;; rcs.el mode.
379 (list posn
380 (buffer-size)
381 (buffer-substring posn
382 (min (point-max) (+ posn 100)))))
384 (defun vc-find-position-by-context (context)
385 "Return the position of CONTEXT in the current buffer.
386 If CONTEXT cannot be found, return nil."
387 (let ((context-string (nth 2 context)))
388 (if (equal "" context-string)
389 (point-max)
390 (save-excursion
391 (let ((diff (- (nth 1 context) (buffer-size))))
392 (when (< diff 0) (setq diff (- diff)))
393 (goto-char (nth 0 context))
394 (if (or (search-forward context-string nil t)
395 ;; Can't use search-backward since the match may continue
396 ;; after point.
397 (progn (goto-char (- (point) diff (length context-string)))
398 ;; goto-char doesn't signal an error at
399 ;; beginning of buffer like backward-char would
400 (search-forward context-string nil t)))
401 ;; to beginning of OSTRING
402 (- (point) (length context-string))))))))
404 (defun vc-context-matches-p (posn context)
405 "Return t if POSN matches CONTEXT, nil otherwise."
406 (let* ((context-string (nth 2 context))
407 (len (length context-string))
408 (end (+ posn len)))
409 (if (> end (1+ (buffer-size)))
411 (string= context-string (buffer-substring posn end)))))
413 (defun vc-buffer-context ()
414 "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
415 Used by `vc-restore-buffer-context' to later restore the context."
416 (let ((point-context (vc-position-context (point)))
417 ;; Use mark-marker to avoid confusion in transient-mark-mode.
418 (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
419 (vc-position-context (mark-marker))))
420 ;; Make the right thing happen in transient-mark-mode.
421 (mark-active nil))
422 (list point-context mark-context nil)))
424 (defun vc-restore-buffer-context (context)
425 "Restore point/mark, and reparse any affected compilation buffers.
426 CONTEXT is that which `vc-buffer-context' returns."
427 (let ((point-context (nth 0 context))
428 (mark-context (nth 1 context)))
429 ;; if necessary, restore point and mark
430 (if (not (vc-context-matches-p (point) point-context))
431 (let ((new-point (vc-find-position-by-context point-context)))
432 (when new-point (goto-char new-point))))
433 (and mark-active
434 mark-context
435 (not (vc-context-matches-p (mark) mark-context))
436 (let ((new-mark (vc-find-position-by-context mark-context)))
437 (when new-mark (set-mark new-mark))))))
439 (defun vc-revert-buffer-internal (&optional arg no-confirm)
440 "Revert buffer, keeping point and mark where user expects them.
441 Try to be clever in the face of changes due to expanded version-control
442 key words. This is important for typeahead to work as expected.
443 ARG and NO-CONFIRM are passed on to `revert-buffer'."
444 (interactive "P")
445 (widen)
446 (let ((context (vc-buffer-context)))
447 ;; Use save-excursion here, because it may be able to restore point
448 ;; and mark properly even in cases where vc-restore-buffer-context
449 ;; would fail. However, save-excursion might also get it wrong --
450 ;; in this case, vc-restore-buffer-context gives it a second try.
451 (save-excursion
452 ;; t means don't call normal-mode;
453 ;; that's to preserve various minor modes.
454 (revert-buffer arg no-confirm t))
455 (vc-restore-buffer-context context)))
457 (defun vc-resynch-window (file &optional keep noquery)
458 "If FILE is in the current buffer, either revert or unvisit it.
459 The choice between revert (to see expanded keywords) and unvisit
460 depends on KEEP. NOQUERY if non-nil inhibits confirmation for
461 reverting. NOQUERY should be t *only* if it is known the only
462 difference between the buffer and the file is due to
463 modifications by the dispatcher client code, rather than user
464 editing!"
465 (and (string= buffer-file-name file)
466 (if keep
467 (when (file-exists-p file)
468 (vc-revert-buffer-internal t noquery)
470 ;; VC operations might toggle the read-only state. In
471 ;; that case we need to adjust the `view-mode' status
472 ;; when `view-read-only' is non-nil.
473 (and view-read-only
474 (if (file-writable-p file)
475 (and view-mode
476 (let ((view-old-buffer-read-only nil))
477 (view-mode-exit)))
478 (and (not view-mode)
479 (not (eq (get major-mode 'mode-class) 'special))
480 (view-mode-enter))))
482 (run-hook-with-args 'mode-line-hook buffer-file-name))
483 (kill-buffer (current-buffer)))))
485 (declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
486 (declare-function vc-string-prefix-p "vc" (prefix string))
488 (defun vc-resynch-buffers-in-directory (directory &optional keep noquery)
489 "Resync all buffers that visit files in DIRECTORY."
490 (dolist (buffer (buffer-list))
491 (let ((fname (buffer-file-name buffer)))
492 (when (and fname (vc-string-prefix-p directory fname))
493 (with-current-buffer buffer
494 (vc-resynch-buffer fname keep noquery))))))
496 (defun vc-resynch-buffer (file &optional keep noquery)
497 "If FILE is currently visited, resynch its buffer."
498 (if (string= buffer-file-name file)
499 (vc-resynch-window file keep noquery)
500 (if (file-directory-p file)
501 (vc-resynch-buffers-in-directory file keep noquery)
502 (let ((buffer (get-file-buffer file)))
503 (when buffer
504 (with-current-buffer buffer
505 (vc-resynch-window file keep noquery))))))
506 ;; Try to avoid unnecessary work, a *vc-dir* buffer is only present
507 ;; if this is true.
508 (when vc-dir-buffers
509 (vc-dir-resynch-file file)))
511 (defun vc-buffer-sync (&optional not-urgent)
512 "Make sure the current buffer and its working file are in sync.
513 NOT-URGENT means it is ok to continue if the user says not to save."
514 (when (buffer-modified-p)
515 (if (or vc-suppress-confirm
516 (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
517 (save-buffer)
518 (unless not-urgent
519 (error "Aborted")))))
521 ;; Command closures
523 ;; Set up key bindings for use while editing log messages
525 (defun vc-log-edit (fileset)
526 "Set up `log-edit' for use on FILE."
527 (setq default-directory
528 (with-current-buffer vc-parent-buffer default-directory))
529 (log-edit 'vc-finish-logentry
531 `((log-edit-listfun . (lambda () ',fileset))
532 (log-edit-diff-function . (lambda () (vc-diff nil)))))
533 (set (make-local-variable 'vc-log-fileset) fileset)
534 (make-local-variable 'vc-log-extra)
535 (set-buffer-modified-p nil)
536 (setq buffer-file-name nil))
538 (defun vc-start-logentry (files extra comment initial-contents msg logbuf action &optional after-hook)
539 "Accept a comment for an operation on FILES with extra data EXTRA.
540 If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the
541 action on close to ACTION. If COMMENT is a string and
542 INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
543 contents of the log entry buffer. If COMMENT is a string and
544 INITIAL-CONTENTS is nil, do action immediately as if the user had
545 entered COMMENT. If COMMENT is t, also do action immediately with an
546 empty comment. Remember the file's buffer in `vc-parent-buffer'
547 \(current one if no file). AFTER-HOOK specifies the local value
548 for `vc-log-after-operation-hook'."
549 (let ((parent
550 (if (vc-dispatcher-browsing)
551 ;; If we are called from a directory browser, the parent buffer is
552 ;; the current buffer.
553 (current-buffer)
554 (if (and files (equal (length files) 1))
555 (get-file-buffer (car files))
556 (current-buffer)))))
557 (if (and comment (not initial-contents))
558 (set-buffer (get-buffer-create logbuf))
559 (pop-to-buffer (get-buffer-create logbuf)))
560 (set (make-local-variable 'vc-parent-buffer) parent)
561 (set (make-local-variable 'vc-parent-buffer-name)
562 (concat " from " (buffer-name vc-parent-buffer)))
563 (vc-log-edit files)
564 (make-local-variable 'vc-log-after-operation-hook)
565 (when after-hook
566 (setq vc-log-after-operation-hook after-hook))
567 (setq vc-log-operation action)
568 (setq vc-log-extra extra)
569 (when comment
570 (erase-buffer)
571 (when (stringp comment) (insert comment)))
572 (if (or (not comment) initial-contents)
573 (message "%s Type C-c C-c when done" msg)
574 (vc-finish-logentry (eq comment t)))))
576 (declare-function vc-dir-move-to-goal-column "vc-dir" ())
578 (defun vc-finish-logentry (&optional nocomment)
579 "Complete the operation implied by the current log entry.
580 Use the contents of the current buffer as a check-in or registration
581 comment. If the optional arg NOCOMMENT is non-nil, then don't check
582 the buffer contents as a comment."
583 (interactive)
584 ;; Check and record the comment, if any.
585 (unless nocomment
586 (run-hooks 'vc-logentry-check-hook))
587 ;; Sync parent buffer in case the user modified it while editing the comment.
588 ;; But not if it is a vc-dir buffer.
589 (with-current-buffer vc-parent-buffer
590 (or (vc-dispatcher-browsing) (vc-buffer-sync)))
591 (unless vc-log-operation
592 (error "No log operation is pending"))
593 ;; save the parameters held in buffer-local variables
594 (let ((logbuf (current-buffer))
595 (log-operation vc-log-operation)
596 (log-fileset vc-log-fileset)
597 (log-extra vc-log-extra)
598 (log-entry (buffer-string))
599 (after-hook vc-log-after-operation-hook)
600 (tmp-vc-parent-buffer vc-parent-buffer))
601 (pop-to-buffer vc-parent-buffer)
602 ;; OK, do it to it
603 (save-excursion
604 (funcall log-operation
605 log-fileset
606 log-extra
607 log-entry))
608 ;; Remove checkin window (after the checkin so that if that fails
609 ;; we don't zap the log buffer and the typing therein).
610 ;; -- IMO this should be replaced with quit-window
611 (cond ((and logbuf vc-delete-logbuf-window)
612 (delete-windows-on logbuf (selected-frame))
613 ;; Kill buffer and delete any other dedicated windows/frames.
614 (kill-buffer logbuf))
615 (logbuf (pop-to-buffer logbuf)
616 (bury-buffer)
617 (pop-to-buffer tmp-vc-parent-buffer)))
618 ;; Now make sure we see the expanded headers
619 (when log-fileset
620 (mapc
621 (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
622 log-fileset))
623 (when (vc-dispatcher-browsing)
624 (vc-dir-move-to-goal-column))
625 (run-hooks after-hook 'vc-finish-logentry-hook)))
627 (defun vc-dispatcher-browsing ()
628 "Are we in a directory browser buffer?"
629 (derived-mode-p 'vc-dir-mode))
631 ;; These are unused.
632 ;; (defun vc-dispatcher-in-fileset-p (fileset)
633 ;; (let ((member nil))
634 ;; (while (and (not member) fileset)
635 ;; (let ((elem (pop fileset)))
636 ;; (if (if (file-directory-p elem)
637 ;; (eq t (compare-strings buffer-file-name nil (length elem)
638 ;; elem nil nil))
639 ;; (eq (current-buffer) (get-file-buffer elem)))
640 ;; (setq member t))))
641 ;; member))
643 ;; (defun vc-dispatcher-selection-set (&optional observer)
644 ;; "Deduce a set of files to which to apply an operation. Return a cons
645 ;; cell (SELECTION . FILESET), where SELECTION is what the user chose
646 ;; and FILES is the flist with any directories replaced by the listed files
647 ;; within them.
649 ;; If we're in a directory display, the fileset is the list of marked files (if
650 ;; there is one) else the file on the current line. If not in a directory
651 ;; display, but the current buffer visits a file, the fileset is a singleton
652 ;; containing that file. Otherwise, throw an error."
653 ;; (let ((selection
654 ;; (cond
655 ;; ;; Browsing with vc-dir
656 ;; ((vc-dispatcher-browsing)
657 ;; ;; If no files are marked, temporarily mark current file
658 ;; ;; and choose on that basis (so we get subordinate files)
659 ;; (if (not (vc-dir-marked-files))
660 ;; (prog2
661 ;; (vc-dir-mark-file)
662 ;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))
663 ;; (vc-dir-unmark-all-files t))
664 ;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))))
665 ;; ;; Visiting an eligible file
666 ;; ((buffer-file-name)
667 ;; (cons (list buffer-file-name) (list buffer-file-name)))
668 ;; ;; No eligible file -- if there's a parent buffer, deduce from there
669 ;; ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
670 ;; (with-current-buffer vc-parent-buffer
671 ;; (vc-dispatcher-browsing))))
672 ;; (with-current-buffer vc-parent-buffer
673 ;; (vc-dispatcher-selection-set)))
674 ;; ;; No good set here, throw error
675 ;; (t (error "No fileset is available here")))))
676 ;; ;; We assume, in order to avoid unpleasant surprises to the user,
677 ;; ;; that a fileset is not in good shape to be handed to the user if the
678 ;; ;; buffers visiting the fileset don't match the on-disk contents.
679 ;; (unless observer
680 ;; (save-some-buffers
681 ;; nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
682 ;; selection))
684 (provide 'vc-dispatcher)
686 ;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
687 ;;; vc-dispatcher.el ends here