Mercurial > emacs
diff lisp/vc-dispatcher.el @ 94571:61cca370b8f5
vc-dispatcher layer separation.
| author | Eric S. Raymond <esr@snark.thyrsus.com> |
|---|---|
| date | Sat, 03 May 2008 07:06:34 +0000 |
| parents | |
| children | 3bdffe280ad3 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc-dispatcher.el Sat May 03 07:06:34 2008 +0000 @@ -0,0 +1,1696 @@ +;;; vc-dispatcher.el -- generic command-dispatcher facility. + +;; Copyright (C) 2008 +;; Free Software Foundation, Inc. + +;; Author: FSF (see below for full credits) +;; Maintainer: Eric S. Raymond <esr@thyrsus.com> +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Credits: + +;; Designed and implemented by Eric S. Raymond, originally as part of VC mode. + +;;; Commentary: + +;; Goals: +;; +;; There is a class of front-ending problems that Emacs might be used +;; to address that involves selecting sets of files, or possibly +;; directories, and passing the selection set to slave commands. The +;; prototypical example, from which this code is derived, is talking +;; to version-control systems. +;; +;; vc-dispatcher.el is written to decouple the UI issues in such front +;; ends from their application-specific logic. It also provides a +;; service layer for running the slave commands either synchronously +;; or asynchronously and managing the message/error logs from the +;; command runs. +;; +;; Similar UI problems can be expected to come up in applications +;; areas other than VCSes; IDEs and document search are two obvious ones. +;; This mode is intended to ensure that the Emacs interfaces for all such +;; beasts are consistent and carefully designed. But even if nothing +;; but VC ever uses it, getting the layer separation right will be +;; a valuable thing. + +;; Dispatcher's universe: +;; +;; The universe consists of the file tree rooted at the current +;; directory. The dispatcher's upper layer deduces some subset +;; of the file tree from the state of the currently visited buffer +;; and returns that subset, presumably to a client mode. +;; +;; The user may be attempting to select one of three contexts: an +;; explicitly selected fileset, the current working directory, or a +;; global (null) context. The user may be looking at either of two +;; different views; a buffer visiting a file, or a directory buffer +;; generated by vc-dispatcher. The main UI problem connected with +;; this mode is that the user may need to be able to select any of +;; these three contexts from either view. +;; +;; The lower layer of this mode runs commands in subprocesses, either +;; synchronously or asynchronously. Commands may be launched in one +;; of two ways: they may be run immediately, or the calling mode can +;; create a closure associated with a text-entry buffer, to be +;; executed when the user types C-c to ship the buffer contents. In +;; either case the command messages and error (if any) will remain +;; available in a status buffer. + +(provide 'vc-dispatcher) + +(eval-when-compile + (require 'cl) + (require 'dired) ; for dired-map-over-marks macro + (require 'dired-aux)) ; for dired-kill-{line,tree} + +(defcustom vc-delete-logbuf-window t + "If non-nil, delete the *VC-log* buffer and window after each logical action. +If nil, bury that buffer instead. +This is most useful if you have multiple windows on a frame and would like to +preserve the setting." + :type 'boolean + :group 'vc) + +(defcustom vc-command-messages nil + "If non-nil, display run messages from back-end commands." + :type 'boolean + :group 'vc) + +(defcustom vc-dired-listing-switches "-al" + "Switches passed to `ls' for vc-dired. MUST contain the `l' option." + :type 'string + :group 'vc + :version "21.1") + +(defcustom vc-dired-recurse t + "If non-nil, show directory trees recursively in VC Dired." + :type 'boolean + :group 'vc + :version "20.3") + +(defcustom vc-dired-terse-display t + "If non-nil, show only locked or locally modified files in VC Dired." + :type 'boolean + :group 'vc + :version "20.3") + +(defcustom vc-dir-mode-hook nil + "Normal hook run by `vc-dir-mode'. +See `run-hooks'." + :type 'hook + :group 'vc) + +(defvar vc-log-fileset) +(defvar vc-dired-mode nil) +(make-variable-buffer-local 'vc-dired-mode) + +;; Common command execution logic + +(defun vc-process-filter (p s) + "An alternative output filter for async process P. +One difference with the default filter is that this inserts S after markers. +Another is that undo information is not kept." + (let ((buffer (process-buffer p))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (goto-char (process-mark p)) + (insert s) + (set-marker (process-mark p) (point)))))))) + +(defun vc-setup-buffer (&optional buf) + "Prepare BUF for executing a VC command and make it current. +BUF defaults to \"*vc*\", can be a string and will be created if necessary." + (unless buf (setq buf "*vc*")) + (let ((camefrom (current-buffer)) + (olddir default-directory)) + (set-buffer (get-buffer-create buf)) + (kill-all-local-variables) + (set (make-local-variable 'vc-parent-buffer) camefrom) + (set (make-local-variable 'vc-parent-buffer-name) + (concat " from " (buffer-name camefrom))) + (setq default-directory olddir) + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (erase-buffer)))) + +(defvar vc-sentinel-movepoint) ;Dynamically scoped. + +(defun vc-process-sentinel (p s) + (let ((previous (process-get p 'vc-previous-sentinel)) + (buf (process-buffer p))) + ;; Impatient users sometime kill "slow" buffers; check liveness + ;; to avoid "error in process sentinel: Selecting deleted buffer". + (when (buffer-live-p buf) + (when previous (funcall previous p s)) + (with-current-buffer buf + (setq mode-line-process + (let ((status (process-status p))) + ;; Leave mode-line uncluttered, normally. + (unless (eq 'exit status) + (format " (%s)" status)))) + (let (vc-sentinel-movepoint) + ;; Normally, we want async code such as sentinels to not move point. + (save-excursion + (goto-char (process-mark p)) + (let ((cmds (process-get p 'vc-sentinel-commands))) + (process-put p 'vc-sentinel-commands nil) + (dolist (cmd cmds) + ;; Each sentinel may move point and the next one should be run + ;; at that new point. We could get the same result by having + ;; each sentinel read&set process-mark, but since `cmd' needs + ;; to work both for async and sync processes, this would be + ;; difficult to achieve. + (vc-exec-after cmd)))) + ;; But sometimes the sentinels really want to move point. + (when vc-sentinel-movepoint + (let ((win (get-buffer-window (current-buffer) 0))) + (if (not win) + (goto-char vc-sentinel-movepoint) + (with-selected-window win + (goto-char vc-sentinel-movepoint)))))))))) + +(defun vc-set-mode-line-busy-indicator () + (setq mode-line-process + (concat " " (propertize "[waiting...]" + 'face 'mode-line-emphasis + 'help-echo + "A VC command is in progress in this buffer")))) + +(defun vc-exec-after (code) + "Eval CODE when the current buffer's process is done. +If the current buffer has no process, just evaluate CODE. +Else, add CODE to the process' sentinel." + (let ((proc (get-buffer-process (current-buffer)))) + (cond + ;; If there's no background process, just execute the code. + ;; We used to explicitly call delete-process on exited processes, + ;; but this led to timing problems causing process output to be + ;; lost. Terminated processes get deleted automatically + ;; anyway. -- cyd + ((or (null proc) (eq (process-status proc) 'exit)) + ;; Make sure we've read the process's output before going further. + (when proc (accept-process-output proc)) + (eval code)) + ;; If a process is running, add CODE to the sentinel + ((eq (process-status proc) 'run) + (vc-set-mode-line-busy-indicator) + (let ((previous (process-sentinel proc))) + (unless (eq previous 'vc-process-sentinel) + (process-put proc 'vc-previous-sentinel previous)) + (set-process-sentinel proc 'vc-process-sentinel)) + (process-put proc 'vc-sentinel-commands + ;; We keep the code fragments in the order given + ;; so that vc-diff-finish's message shows up in + ;; the presence of non-nil vc-command-messages. + (append (process-get proc 'vc-sentinel-commands) + (list code)))) + (t (error "Unexpected process state")))) + nil) + +(defvar vc-post-command-functions nil + "Hook run at the end of `vc-do-command'. +Each function is called inside the buffer in which the command was run +and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.") + +(defvar w32-quote-process-args) + +(defun vc-delistify (filelist) + "Smash a FILELIST into a file list string suitable for info messages." + ;; FIXME what about file names with spaces? + (if (not filelist) "." (mapconcat 'identity filelist " "))) + +;;;###autoload +(defun vc-do-command (buffer okstatus command file-or-list &rest flags) + "Execute a VC command, notifying user and checking for errors. +Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil or the +current buffer if BUFFER is t. If the destination buffer is not +already current, set it up properly and erase it. The command is +considered successful if its exit status does not exceed OKSTATUS (if +OKSTATUS is nil, that means to ignore error status, if it is `async', that +means not to wait for termination of the subprocess; if it is t it means to +ignore all execution errors). FILE-OR-LIST is the name of a working file; +it may be a list of files or be nil (to execute commands that don't expect +a file name or set of files). If an optional list of FLAGS is present, +that is inserted into the command line before the filename." + ;; FIXME: file-relative-name can return a bogus result because + ;; it doesn't look at the actual file-system to see if symlinks + ;; come into play. + (let* ((files + (mapcar (lambda (f) (file-relative-name (expand-file-name f))) + (if (listp file-or-list) file-or-list (list file-or-list)))) + (full-command + ;; What we're doing here is preparing a version of the command + ;; for display in a debug-progess message. If it's fewer than + ;; 20 characters display the entire command (without trailing + ;; newline). Otherwise display the first 20 followed by an ellipsis. + (concat (if (string= (substring command -1) "\n") + (substring command 0 -1) + command) + " " + (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags)) + " " (vc-delistify files)))) + (save-current-buffer + (unless (or (eq buffer t) + (and (stringp buffer) + (string= (buffer-name) buffer)) + (eq buffer (current-buffer))) + (vc-setup-buffer buffer)) + ;; If there's some previous async process still running, just kill it. + (let ((oldproc (get-buffer-process (current-buffer)))) + ;; If we wanted to wait for oldproc to finish before doing + ;; something, we'd have used vc-eval-after. + ;; Use `delete-process' rather than `kill-process' because we don't + ;; want any of its output to appear from now on. + (if oldproc (delete-process oldproc))) + (let ((squeezed (remq nil flags)) + (inhibit-read-only t) + (status 0)) + (when files + (setq squeezed (nconc squeezed files))) + (let ((exec-path (append vc-path exec-path)) + ;; Add vc-path to PATH for the execution of this command. + (process-environment + (cons (concat "PATH=" (getenv "PATH") + path-separator + (mapconcat 'identity vc-path path-separator)) + process-environment)) + (w32-quote-process-args t)) + (when (and (eq okstatus 'async) (file-remote-p default-directory)) + ;; start-process does not support remote execution + (setq okstatus nil)) + (if (eq okstatus 'async) + ;; Run asynchronously. + (let ((proc + (let ((process-connection-type nil)) + (apply 'start-file-process command (current-buffer) + command squeezed)))) + (if vc-command-messages + (message "Running %s in background..." full-command)) + ;;(set-process-sentinel proc (lambda (p msg) (delete-process p))) + (set-process-filter proc 'vc-process-filter) + (vc-exec-after + `(if vc-command-messages + (message "Running %s in background... done" ',full-command)))) + ;; Run synchrously + (when vc-command-messages + (message "Running %s in foreground..." full-command)) + (let ((buffer-undo-list t)) + (setq status (apply 'process-file command nil t nil squeezed))) + (when (and (not (eq t okstatus)) + (or (not (integerp status)) + (and okstatus (< okstatus status)))) + (unless (eq ?\s (aref (buffer-name (current-buffer)) 0)) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer)) + (error "Running %s...FAILED (%s)" full-command + (if (integerp status) (format "status %d" status) status)))) + ;; We're done. But don't emit a status message if running + ;; asychronously, it would just mislead. + (if (and vc-command-messages (not (eq okstatus 'async))) + (message "Running %s...OK = %d" full-command status))) + (vc-exec-after + `(run-hook-with-args 'vc-post-command-functions + ',command ',file-or-list ',flags)) + status)))) + +;; Context management + +(defun vc-position-context (posn) + "Save a bit of the text around POSN in the current buffer. +Used to help us find the corresponding position again later +if markers are destroyed or corrupted." + ;; A lot of this was shamelessly lifted from Sebastian Kremer's + ;; rcs.el mode. + (list posn + (buffer-size) + (buffer-substring posn + (min (point-max) (+ posn 100))))) + +(defun vc-find-position-by-context (context) + "Return the position of CONTEXT in the current buffer. +If CONTEXT cannot be found, return nil." + (let ((context-string (nth 2 context))) + (if (equal "" context-string) + (point-max) + (save-excursion + (let ((diff (- (nth 1 context) (buffer-size)))) + (when (< diff 0) (setq diff (- diff))) + (goto-char (nth 0 context)) + (if (or (search-forward context-string nil t) + ;; Can't use search-backward since the match may continue + ;; after point. + (progn (goto-char (- (point) diff (length context-string))) + ;; goto-char doesn't signal an error at + ;; beginning of buffer like backward-char would + (search-forward context-string nil t))) + ;; to beginning of OSTRING + (- (point) (length context-string)))))))) + +(defun vc-context-matches-p (posn context) + "Return t if POSN matches CONTEXT, nil otherwise." + (let* ((context-string (nth 2 context)) + (len (length context-string)) + (end (+ posn len))) + (if (> end (1+ (buffer-size))) + nil + (string= context-string (buffer-substring posn end))))) + +(defun vc-buffer-context () + "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE). +Used by `vc-restore-buffer-context' to later restore the context." + (let ((point-context (vc-position-context (point))) + ;; Use mark-marker to avoid confusion in transient-mark-mode. + (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer)) + (vc-position-context (mark-marker)))) + ;; Make the right thing happen in transient-mark-mode. + (mark-active nil) + ;; The new compilation code does not use compilation-error-list any + ;; more, so the code below is now ineffective and might as well + ;; be disabled. -- Stef + ;; ;; We may want to reparse the compilation buffer after revert + ;; (reparse (and (boundp 'compilation-error-list) ;compile loaded + ;; ;; Construct a list; each elt is nil or a buffer + ;; ;; if that buffer is a compilation output buffer + ;; ;; that contains markers into the current buffer. + ;; (save-current-buffer + ;; (mapcar (lambda (buffer) + ;; (set-buffer buffer) + ;; (let ((errors (or + ;; compilation-old-error-list + ;; compilation-error-list)) + ;; (buffer-error-marked-p nil)) + ;; (while (and (consp errors) + ;; (not buffer-error-marked-p)) + ;; (and (markerp (cdr (car errors))) + ;; (eq buffer + ;; (marker-buffer + ;; (cdr (car errors)))) + ;; (setq buffer-error-marked-p t)) + ;; (setq errors (cdr errors))) + ;; (if buffer-error-marked-p buffer))) + ;; (buffer-list))))) + (reparse nil)) + (list point-context mark-context reparse))) + +(defun vc-restore-buffer-context (context) + "Restore point/mark, and reparse any affected compilation buffers. +CONTEXT is that which `vc-buffer-context' returns." + (let ((point-context (nth 0 context)) + (mark-context (nth 1 context)) + ;; (reparse (nth 2 context)) + ) + ;; The new compilation code does not use compilation-error-list any + ;; more, so the code below is now ineffective and might as well + ;; be disabled. -- Stef + ;; ;; Reparse affected compilation buffers. + ;; (while reparse + ;; (if (car reparse) + ;; (with-current-buffer (car reparse) + ;; (let ((compilation-last-buffer (current-buffer)) ;select buffer + ;; ;; Record the position in the compilation buffer of + ;; ;; the last error next-error went to. + ;; (error-pos (marker-position + ;; (car (car-safe compilation-error-list))))) + ;; ;; Reparse the error messages as far as they were parsed before. + ;; (compile-reinitialize-errors '(4) compilation-parsing-end) + ;; ;; Move the pointer up to find the error we were at before + ;; ;; reparsing. Now next-error should properly go to the next one. + ;; (while (and compilation-error-list + ;; (/= error-pos (car (car compilation-error-list)))) + ;; (setq compilation-error-list (cdr compilation-error-list)))))) + ;; (setq reparse (cdr reparse))) + + ;; if necessary, restore point and mark + (if (not (vc-context-matches-p (point) point-context)) + (let ((new-point (vc-find-position-by-context point-context))) + (when new-point (goto-char new-point)))) + (and mark-active + mark-context + (not (vc-context-matches-p (mark) mark-context)) + (let ((new-mark (vc-find-position-by-context mark-context))) + (when new-mark (set-mark new-mark)))))) + +(defvar vc-dired-window-configuration) + +;; Command closures + +;; FIXME: The rev argument is VCS-specific and needs to be factored out +(defun vc-start-entry (files rev comment initial-contents msg action &optional after-hook) + "Accept a comment for an operation on FILES revision REV. +If COMMENT is nil, pop up a VC-log buffer, emit MSG, and set the +action on close to ACTION. If COMMENT is a string and +INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial +contents of the log entry buffer. If COMMENT is a string and +INITIAL-CONTENTS is nil, do action immediately as if the user had +entered COMMENT. If COMMENT is t, also do action immediately with an +empty comment. Remember the file's buffer in `vc-parent-buffer' +\(current one if no file). AFTER-HOOK specifies the local value +for `vc-log-after-operation-hook'." + (let ((parent + (if (or (eq major-mode 'vc-dired-mode) (eq major-mode 'vc-dir-mode)) + ;; If we are called from VC dired, the parent buffer is + ;; the current buffer. + (current-buffer) + (if (and files (equal (length files) 1)) + (get-file-buffer (car files)) + (current-buffer))))) + (when vc-before-checkin-hook + (if files + (with-current-buffer parent + (run-hooks 'vc-before-checkin-hook)) + (run-hooks 'vc-before-checkin-hook))) + (if (and comment (not initial-contents)) + (set-buffer (get-buffer-create "*VC-log*")) + (pop-to-buffer (get-buffer-create "*VC-log*"))) + (set (make-local-variable 'vc-parent-buffer) parent) + (set (make-local-variable 'vc-parent-buffer-name) + (concat " from " (buffer-name vc-parent-buffer))) + ;;(if file (vc-mode-line file)) + (vc-log-edit files) + (make-local-variable 'vc-log-after-operation-hook) + (when after-hook + (setq vc-log-after-operation-hook after-hook)) + (setq vc-log-operation action) + (setq vc-log-revision rev) + (when comment + (erase-buffer) + (when (stringp comment) (insert comment))) + (if (or (not comment) initial-contents) + (message "%s Type C-c C-c when done" msg) + (vc-finish-logentry (eq comment t))))) + +;; FIXME: Reference to vc-call-backend should go. +(defun vc-finish-logentry (&optional nocomment) + "Complete the operation implied by the current log entry. +Use the contents of the current buffer as a check-in or registration +comment. If the optional arg NOCOMMENT is non-nil, then don't check +the buffer contents as a comment." + (interactive) + ;; Check and record the comment, if any. + (unless nocomment + ;; Comment too long? + (vc-call-backend (or (when vc-log-fileset (vc-backend vc-log-fileset)) + (vc-responsible-backend default-directory)) + 'logentry-check) + (run-hooks 'vc-logentry-check-hook)) + ;; Sync parent buffer in case the user modified it while editing the comment. + ;; But not if it is a vc-dired buffer. + (with-current-buffer vc-parent-buffer + (or vc-dired-mode (eq major-mode 'vc-dir-mode) (vc-buffer-sync))) + (unless vc-log-operation + (error "No log operation is pending")) + ;; save the parameters held in buffer-local variables + (let ((log-operation vc-log-operation) + (log-fileset vc-log-fileset) + (log-revision vc-log-revision) + (log-entry (buffer-string)) + (after-hook vc-log-after-operation-hook) + (tmp-vc-parent-buffer vc-parent-buffer)) + (pop-to-buffer vc-parent-buffer) + ;; OK, do it to it + (save-excursion + (funcall log-operation + log-fileset + log-revision + log-entry)) + ;; Remove checkin window (after the checkin so that if that fails + ;; we don't zap the *VC-log* buffer and the typing therein). + ;; -- IMO this should be replaced with quit-window + (let ((logbuf (get-buffer "*VC-log*"))) + (cond ((and logbuf vc-delete-logbuf-window) + (delete-windows-on logbuf (selected-frame)) + ;; Kill buffer and delete any other dedicated windows/frames. + (kill-buffer logbuf)) + (logbuf (pop-to-buffer "*VC-log*") + (bury-buffer) + (pop-to-buffer tmp-vc-parent-buffer)))) + ;; Now make sure we see the expanded headers + (when log-fileset + (mapc + (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t)) + log-fileset)) + (when vc-dired-mode + (dired-move-to-filename)) + (when (eq major-mode 'vc-dir-mode) + (vc-dir-move-to-goal-column)) + (run-hooks after-hook 'vc-finish-logentry-hook))) + + +;; The VC directory major mode. Coopt Dired for this. +;; All VC commands get mapped into logical equivalents. + +(defvar vc-dired-switches) +(defvar vc-dired-terse-mode) + +(defvar vc-dired-mode-map + (let ((map (make-sparse-keymap)) + (vmap (make-sparse-keymap))) + (define-key map "\C-xv" vmap) + (define-key map "v" vmap) + (set-keymap-parent vmap vc-prefix-map) + (define-key vmap "t" 'vc-dired-toggle-terse-mode) + map)) + +(define-derived-mode vc-dired-mode dired-mode "Dired under " + "The major mode used in VC directory buffers. + +It works like Dired, but lists only files under version control, with +the current VC state of each file being indicated in the place of the +file's link count, owner, group and size. Subdirectories are also +listed, and you may insert them into the buffer as desired, like in +Dired. + +All Dired commands operate normally, with the exception of `v', which +is redefined as the version control prefix, so that you can type +`vl', `v=' etc. to invoke `vc-print-log', `vc-diff', and the like on +the file named in the current Dired buffer line. `vv' invokes +`vc-next-action' on this file, or on all files currently marked. +There is a special command, `*l', to mark all files currently locked." + ;; define-derived-mode does it for us in Emacs-21, but not in Emacs-20. + ;; We do it here because dired might not be loaded yet + ;; when vc-dired-mode-map is initialized. + (set-keymap-parent vc-dired-mode-map dired-mode-map) + (add-hook 'dired-after-readin-hook 'vc-dired-hook nil t) + ;; The following is slightly modified from files.el, + ;; because file lines look a bit different in vc-dired-mode + ;; (the column before the date does not end in a digit). + ;; albinus: It should be done in the original declaration. Problem + ;; is the optional empty state-info; otherwise ")" would be good + ;; enough as delimeter. + (set (make-local-variable 'directory-listing-before-filename-regexp) + (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)") + ;; In some locales, month abbreviations are as short as 2 letters, + ;; and they can be followed by ".". + (month (concat l l "+\\.?")) + (s " ") + (yyyy "[0-9][0-9][0-9][0-9]") + (dd "[ 0-3][0-9]") + (HH:MM "[ 0-2][0-9]:[0-5][0-9]") + (seconds "[0-6][0-9]\\([.,][0-9]+\\)?") + (zone "[-+][0-2][0-9][0-5][0-9]") + (iso-mm-dd "[01][0-9]-[0-3][0-9]") + (iso-time (concat HH:MM "\\(:" seconds "\\( ?" zone "\\)?\\)?")) + (iso (concat "\\(\\(" yyyy "-\\)?" iso-mm-dd "[ T]" iso-time + "\\|" yyyy "-" iso-mm-dd "\\)")) + (western (concat "\\(" month s "+" dd "\\|" dd "\\.?" s month "\\)" + s "+" + "\\(" HH:MM "\\|" yyyy "\\)")) + (western-comma (concat month s "+" dd "," s "+" yyyy)) + ;; Japanese MS-Windows ls-lisp has one-digit months, and + ;; omits the Kanji characters after month and day-of-month. + (mm "[ 0-1]?[0-9]") + (japanese + (concat mm l "?" s dd l "?" s "+" + "\\(" HH:MM "\\|" yyyy l "?" "\\)"))) + ;; the .* below ensures that we find the last match on a line + (concat ".*" s + "\\(" western "\\|" western-comma "\\|" japanese "\\|" iso "\\)" + s "+"))) + (and (boundp 'vc-dired-switches) + vc-dired-switches + (set (make-local-variable 'dired-actual-switches) + vc-dired-switches)) + (set (make-local-variable 'vc-dired-terse-mode) vc-dired-terse-display) + ;; FIXME: This needs to be factored out + (let ((backend-name (symbol-name (vc-responsible-backend + default-directory)))) + (setq mode-name (concat mode-name backend-name)) + ;; Add menu after `vc-dired-mode-map' has `dired-mode-map' as the parent. + (let ((vc-dire-menu-map (copy-keymap vc-menu-map))) + (define-key-after (lookup-key vc-dired-mode-map [menu-bar]) [vc] + (cons backend-name vc-dire-menu-map) 'subdir))) + (setq vc-dired-mode t)) + +(defun vc-dired-toggle-terse-mode () + "Toggle terse display in VC Dired." + (interactive) + (if (not vc-dired-mode) + nil + (setq vc-dired-terse-mode (not vc-dired-terse-mode)) + (if vc-dired-terse-mode + (vc-dired-hook) + (revert-buffer)))) + +(defun vc-dired-mark-locked () + "Mark all files currently locked." + (interactive) + (dired-mark-if (let ((f (dired-get-filename nil t))) + (and f + (not (file-directory-p f)) + (not (vc-up-to-date-p f)))) + "locked file")) + +(define-key vc-dired-mode-map "*l" 'vc-dired-mark-locked) + +(defun vc-dired-reformat-line (vc-info) + "Reformat a directory-listing line. +Replace various columns with version control information, VC-INFO. +This code, like dired, assumes UNIX -l format." + (beginning-of-line) + (when (re-search-forward + ;; Match link count, owner, group, size. Group may be missing, + ;; and only the size is present in OS/2 -l format. + "^..[drwxlts-]+ \\( *[0-9]+\\( [^ ]+ +\\([^ ]+ +\\)?[0-9]+\\)?\\) " + (line-end-position) t) + (replace-match (substring (concat vc-info " ") 0 10) + t t nil 1))) + +;; FIXME: VCS-specific knowledge in here needs to be factored out +(defun vc-dired-ignorable-p (filename) + "Should FILENAME be ignored in VC-Dired listings?" + (catch t + ;; Ignore anything that wouldn't be found by completion (.o, .la, etc.) + (dolist (ignorable completion-ignored-extensions) + (let ((ext (substring filename + (- (length filename) + (length ignorable))))) + (if (string= ignorable ext) (throw t t)))) + ;; Ignore Makefiles derived from something else + (when (string= (file-name-nondirectory filename) "Makefile") + (let* ((dir (file-name-directory filename)) + (peers (directory-files (or dir default-directory)))) + (if (or (member "Makefile.in" peers) (member "Makefile.am" peers)) + (throw t t)))) + nil)) + +(defun vc-dired-purge () + "Remove empty subdirs." + (goto-char (point-min)) + (while (dired-get-subdir) + (forward-line 2) + (if (dired-get-filename nil t) + (if (not (dired-next-subdir 1 t)) + (goto-char (point-max))) + (forward-line -2) + (if (not (string= (dired-current-directory) default-directory)) + (dired-do-kill-lines t "") + ;; We cannot remove the top level directory. + ;; Just make it look a little nicer. + (forward-line 1) + (or (eobp) (kill-line)) + (if (not (dired-next-subdir 1 t)) + (goto-char (point-max)))))) + (goto-char (point-min))) + +(defun vc-dired-buffers-for-dir (dir) + "Return a list of all vc-dired buffers that currently display DIR." + (let (result) + ;; Check whether dired is loaded. + (when (fboundp 'dired-buffers-for-dir) + (dolist (buffer (dired-buffers-for-dir dir)) + (with-current-buffer buffer + (when vc-dired-mode + (push buffer result))))) + (nreverse result))) + +(defun vc-directory-resynch-file (file) + "Update the entries for FILE in any VC Dired buffers that list it." + ;;FIXME This needs to be implemented so it works for vc-dir + (let ((buffers (vc-dired-buffers-for-dir (file-name-directory file)))) + (when buffers + (mapcar (lambda (buffer) + (with-current-buffer buffer + (when (dired-goto-file file) + ;; bind vc-dired-terse-mode to nil so that + ;; files won't vanish when they are checked in + (let ((vc-dired-terse-mode nil)) + (dired-do-redisplay 1))))) + buffers)))) + +;;;###autoload +(defun vc-directory (dir read-switches) + "Create a buffer in VC Dired Mode for directory DIR. + +See Info node `VC Dired Mode'. + +With prefix arg READ-SWITCHES, specify a value to override +`dired-listing-switches' when generating the listing." + (interactive "DDired under VC (directory): \nP") + (let ((vc-dired-switches (concat vc-dired-listing-switches + (if vc-dired-recurse "R" "")))) + (if read-switches + (setq vc-dired-switches + (read-string "Dired listing switches: " + vc-dired-switches))) + (require 'dired) + (require 'dired-aux) + (switch-to-buffer + (dired-internal-noselect (expand-file-name (file-name-as-directory dir)) + vc-dired-switches + 'vc-dired-mode)))) + +;; VC status implementation + +;; Used to store information for the files displayed in the *VC status* buffer. +;; Each item displayed corresponds to one of these defstructs. +(defstruct (vc-dir-fileinfo + (:copier nil) + (:type list) ;So we can use `member' on lists of FIs. + (:constructor + ;; We could define it as an alias for `list'. + vc-dir-create-fileinfo (name state &optional extra marked directory)) + (:conc-name vc-dir-fileinfo->)) + name ;Keep it as first, for `member'. + state + ;; For storing backend specific information. + extra + marked + ;; To keep track of not updated files during a global refresh + needs-update + ;; To distinguish files and directories. + directory) + +(defvar vc-ewoc nil) + +(defun vc-default-status-extra-headers (backend dir) + ;; Be loud by default to remind people to add coded to display + ;; backend specific headers. + ;; XXX: change this to return nil before the release. + "Extra : Add backend specific headers here") + +(defun vc-dir-headers (backend dir) + "Display the headers in the *VC status* buffer. +It calls the `status-extra-headers' backend method to display backend +specific headers." + (concat + (propertize "VC backend : " 'face 'font-lock-type-face) + (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face) + (propertize "Working dir: " 'face 'font-lock-type-face) + (propertize (format "%s\n" dir) 'face 'font-lock-variable-name-face) + (vc-call-backend backend 'status-extra-headers dir) + "\n")) + +(defun vc-default-status-printer (backend fileentry) + "Pretty print FILEENTRY." + ;; If you change the layout here, change vc-dir-move-to-goal-column. + (let ((state + (if (vc-dir-fileinfo->directory fileentry) + 'DIRECTORY + (vc-dir-fileinfo->state fileentry)))) + (insert + (propertize + (format "%c" (if (vc-dir-fileinfo->marked fileentry) ?* ? )) + 'face 'font-lock-type-face) + " " + (propertize + (format "%-20s" state) + 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face) + ((memq state '(missing conflict)) 'font-lock-warning-face) + (t 'font-lock-variable-name-face)) + 'mouse-face 'highlight) + " " + (propertize + (format "%s" (vc-dir-fileinfo->name fileentry)) + 'face 'font-lock-function-name-face + 'mouse-face 'highlight)))) + +(defun vc-dir-printer (fileentry) + (let ((backend (vc-responsible-backend default-directory))) + (vc-call-backend backend 'status-printer fileentry))) + +(defun vc-dir-move-to-goal-column () + ;; Used to keep the cursor on the file name column. + (beginning-of-line) + ;; Must be in sync with vc-default-status-printer. + (forward-char 25)) + +(defun vc-dir-prepare-status-buffer (dir &optional create-new) + "Find a *vc-dir* buffer showing DIR, or create a new one." + (setq dir (expand-file-name dir)) + (let* ((bname "*vc-dir*") + ;; Look for another *vc-dir* buffer visiting the same directory. + (buf (save-excursion + (unless create-new + (dolist (buffer (buffer-list)) + (set-buffer buffer) + (when (and (eq major-mode 'vc-dir-mode) + (string= (expand-file-name default-directory) dir)) + (return buffer))))))) + (or buf + ;; Create a new *vc-dir* buffer. + (with-current-buffer (create-file-buffer bname) + (cd dir) + (vc-setup-buffer (current-buffer)) + ;; Reset the vc-parent-buffer-name so that it does not appear + ;; in the mode-line. + (setq vc-parent-buffer-name nil) + (current-buffer))))) + +;;;###autoload +(defun vc-dir (dir) + "Show the VC status for DIR." + (interactive "DVC status for directory: ") + (pop-to-buffer (vc-dir-prepare-status-buffer dir)) + (if (eq major-mode 'vc-dir-mode) + (vc-dir-refresh) + (vc-dir-mode))) + +(defvar vc-dir-menu-map + (let ((map (make-sparse-keymap "VC-dir"))) + (define-key map [quit] + '(menu-item "Quit" quit-window + :help "Quit")) + (define-key map [kill] + '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process + :enable (vc-dir-busy) + :help "Kill the command that updates VC status buffer")) + (define-key map [refresh] + '(menu-item "Refresh" vc-dir-refresh + :enable (not (vc-dir-busy)) + :help "Refresh the contents of the VC status buffer")) + (define-key map [remup] + '(menu-item "Hide up-to-date" vc-dir-hide-up-to-date + :help "Hide up-to-date items from display")) + ;; Movement. + (define-key map [sepmv] '("--")) + (define-key map [next-line] + '(menu-item "Next line" vc-dir-next-line + :help "Go to the next line" :keys "n")) + (define-key map [previous-line] + '(menu-item "Previous line" vc-dir-previous-line + :help "Go to the previous line")) + ;; Marking. + (define-key map [sepmrk] '("--")) + (define-key map [unmark-all] + '(menu-item "Unmark All" vc-dir-unmark-all-files + :help "Unmark all files that are in the same state as the current file\ +\nWith prefix argument unmark all files")) + (define-key map [unmark-previous] + '(menu-item "Unmark previous " vc-dir-unmark-file-up + :help "Move to the previous line and unmark the file")) + + (define-key map [mark-all] + '(menu-item "Mark All" vc-dir-mark-all-files + :help "Mark all files that are in the same state as the current file\ +\nWith prefix argument mark all files")) + (define-key map [unmark] + '(menu-item "Unmark" vc-dir-unmark + :help "Unmark the current file or all files in the region")) + + (define-key map [mark] + '(menu-item "Mark" vc-dir-mark + :help "Mark the current file or all files in the region")) + + (define-key map [sepopn] '("--")) + (define-key map [open-other] + '(menu-item "Open in other window" vc-dir-find-file-other-window + :help "Find the file on the current line, in another window")) + (define-key map [open] + '(menu-item "Open file" vc-dir-find-file + :help "Find the file on the current line")) + ;; VC info details + (define-key map [sepvcdet] '("--")) + ;; FIXME: This needs a key binding. And maybe a better name + ;; ("Insert" like PCL-CVS uses does not sound that great either)... + (define-key map [ins] + '(menu-item "Show File" vc-dir-show-fileentry + :help "Show a file in the VC status listing even though it might be up to date")) + (define-key map [annotate] + '(menu-item "Annotate" vc-annotate + :help "Display the edit history of the current file using colors")) + (define-key map [diff] + '(menu-item "Compare with Base Version" vc-diff + :help "Compare file set with the base version")) + (define-key map [log] + '(menu-item "Show history" vc-print-log + :help "List the change log of the current file set in a window")) + ;; VC commands. + (define-key map [sepvccmd] '("--")) + (define-key map [update] + '(menu-item "Update to latest version" vc-update + :help "Update the current fileset's files to their tip revisions")) + (define-key map [revert] + '(menu-item "Revert to base version" vc-revert + :help "Revert working copies of the selected fileset to their repository contents.")) + (define-key map [next-action] + ;; FIXME: This really really really needs a better name! + ;; And a key binding too. + '(menu-item "Check In/Out" vc-next-action + :help "Do the next logical version control operation on the current fileset")) + (define-key map [register] + '(menu-item "Register" vc-dir-register + :help "Register file set into the version control system")) + map) + "Menu for VC status") + +(defalias 'vc-dir-menu-map vc-dir-menu-map) + +(defvar vc-dir-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + ;; Marking. + (define-key map "m" 'vc-dir-mark) + (define-key map "M" 'vc-dir-mark-all-files) + (define-key map "u" 'vc-dir-unmark) + (define-key map "U" 'vc-dir-unmark-all-files) + (define-key map "\C-?" 'vc-dir-unmark-file-up) + (define-key map "\M-\C-?" 'vc-dir-unmark-all-files) + ;; Movement. + (define-key map "n" 'vc-dir-next-line) + (define-key map " " 'vc-dir-next-line) + (define-key map "\t" 'vc-dir-next-line) + (define-key map "p" 'vc-dir-previous-line) + (define-key map [backtab] 'vc-dir-previous-line) + ;; VC commands. + (define-key map "=" 'vc-diff) ;; C-x v = + (define-key map "a" 'vc-dir-register) + (define-key map "+" 'vc-update) ;; C-x v + + (define-key map "R" 'vc-revert) ;; u is taken by unmark. + + ;; Can't be "g" (as in vc map), so "A" for "Annotate". + (define-key map "A" 'vc-annotate) + (define-key map "l" 'vc-print-log) ;; C-x v l + ;; The remainder. + (define-key map "f" 'vc-dir-find-file) + (define-key map "\C-m" 'vc-dir-find-file) + (define-key map "o" 'vc-dir-find-file-other-window) + (define-key map "x" 'vc-dir-hide-up-to-date) + (define-key map "q" 'quit-window) + (define-key map "g" 'vc-dir-refresh) + (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process) + (define-key map [(down-mouse-3)] 'vc-dir-menu) + (define-key map [(mouse-2)] 'vc-dir-toggle-mark) + + ;; Hook up the menu. + (define-key map [menu-bar vc-dir-mode] + '(menu-item + ;; This is used to that VC backends could add backend specific + ;; menu items to vc-dir-menu-map. + "VC Status" vc-dir-menu-map :filter vc-dir-menu-map-filter)) + map) + "Keymap for VC status") + +(defun vc-default-extra-status-menu (backend) + nil) + +;; This is used to that VC backends could add backend specific menu +;; items to vc-dir-menu-map. +(defun vc-dir-menu-map-filter (orig-binding) + (when (and (symbolp orig-binding) (fboundp orig-binding)) + (setq orig-binding (indirect-function orig-binding))) + (let ((ext-binding + (vc-call-backend (vc-responsible-backend default-directory) + 'extra-status-menu))) + (if (null ext-binding) + orig-binding + (append orig-binding + '("----") + ext-binding)))) + +(defmacro vc-at-event (event &rest body) + "Evaluate `body' wich point located at event-start of `event'. +If `body' uses `event', it should be a variable, + otherwise it will be evaluated twice." + (let ((posn (gensym "vc-at-event-posn"))) + `(let ((,posn (event-start ,event))) + (save-excursion + (set-buffer (window-buffer (posn-window ,posn))) + (goto-char (posn-point ,posn)) + ,@body)))) + +(defun vc-dir-menu (e) + "Popup the VC status menu." + (interactive "e") + (vc-at-event e (popup-menu vc-dir-menu-map e))) + +(defvar vc-dir-tool-bar-map + (let ((map (make-sparse-keymap))) + (tool-bar-local-item-from-menu 'vc-dir-find-file "open" + map vc-dir-mode-map) + (tool-bar-local-item "bookmark_add" + 'vc-dir-toggle-mark 'vc-dir-toggle-mark map + :help "Toggle mark on current item") + (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow" + map vc-dir-mode-map + :rtl "right-arrow") + (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow" + map vc-dir-mode-map + :rtl "left-arrow") + (tool-bar-local-item-from-menu 'vc-print-log "info" + map vc-dir-mode-map) + (tool-bar-local-item-from-menu 'vc-dir-refresh "refresh" + map vc-dir-mode-map) + (tool-bar-local-item-from-menu 'nonincremental-search-forward + "search" map) + (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel" + map vc-dir-mode-map) + (tool-bar-local-item-from-menu 'quit-window "exit" + map vc-dir-mode-map) + map)) + +(defvar vc-dir-process-buffer nil + "The buffer used for the asynchronous call that computes the VC status.") + +(defun vc-dir-mode () + "Major mode for showing the VC status for a directory. +Marking/Unmarking key bindings and actions: +m - marks a file/directory or ff the region is active, mark all the files + in region. + Restrictions: - a file cannot be marked if any parent directory is marked + - a directory cannot be marked if any child file or + directory is marked +u - marks a file/directory or if the region is active, unmark all the files + in region. +M - if the cursor is on a file: mark all the files with the same VC state as + the current file + - if the cursor is on a directory: mark all child files + - with a prefix argument: mark all files +U - if the cursor is on a file: unmark all the files with the same VC state + as the current file + - if the cursor is on a directory: unmark all child files + - with a prefix argument: unmark all files + + +\\{vc-dir-mode-map}" + (setq mode-name "VC Status") + (setq major-mode 'vc-dir-mode) + (setq buffer-read-only t) + (use-local-map vc-dir-mode-map) + (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map) + (let ((buffer-read-only nil) + (backend (vc-responsible-backend default-directory)) + entries) + (erase-buffer) + (set (make-local-variable 'vc-dir-process-buffer) nil) + (set (make-local-variable 'vc-ewoc) + (ewoc-create #'vc-dir-printer + (vc-dir-headers backend default-directory))) + (add-hook 'after-save-hook 'vc-dir-mark-buffer-changed) + ;; Make sure that if the VC status buffer is killed, the update + ;; process running in the background is also killed. + (add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t) + (vc-dir-refresh)) + (run-hooks 'vc-dir-mode-hook)) + +(put 'vc-dir-mode 'mode-class 'special) + +;; t if directories should be shown in vc-dir. +;; WORK IN PROGRESS! DO NOT SET this! ONLY set it if you want to help +;; write code for this feature. This variable will likely disappear +;; when the work is done. +(defvar vc-dir-insert-directories nil) + +(defun vc-dir-update (entries buffer &optional noinsert) + "Update BUFFER's ewoc from the list of ENTRIES. +If NOINSERT, ignore elements on ENTRIES which are not in the ewoc." + ;; Add ENTRIES to the vc-dir buffer BUFFER. + (with-current-buffer buffer + ;; Insert the entries sorted by name into the ewoc. + ;; We assume the ewoc is sorted too, which should be the + ;; case if we always add entries with vc-dir-update. + (setq entries + ;; Sort: first files and then subdirectories. + ;; XXX: this is VERY inefficient, it computes the directory + ;; names too many times + (sort entries + (lambda (entry1 entry2) + (let ((dir1 (file-name-directory (expand-file-name (car entry1)))) + (dir2 (file-name-directory (expand-file-name (car entry2))))) + (cond + ((string< dir1 dir2) t) + ((not (string= dir1 dir2)) nil) + ((string< (car entry1) (car entry2)))))))) + (if (not vc-dir-insert-directories) + (let ((entry (car entries)) + (node (ewoc-nth vc-ewoc 0))) + (while (and entry node) + (let ((entryfile (car entry)) + (nodefile (vc-dir-fileinfo->name (ewoc-data node)))) + (cond + ((string-lessp nodefile entryfile) + (setq node (ewoc-next vc-ewoc node))) + ((string-lessp entryfile nodefile) + (unless noinsert + (ewoc-enter-before vc-ewoc node + (apply 'vc-dir-create-fileinfo entry))) + (setq entries (cdr entries) entry (car entries))) + (t + (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry)) + (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry)) + (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil) + (ewoc-invalidate vc-ewoc node) + (setq entries (cdr entries) entry (car entries)) + (setq node (ewoc-next vc-ewoc node)))))) + (unless (or node noinsert) + ;; We're past the last node, all remaining entries go to the end. + (while entries + (ewoc-enter-last vc-ewoc + (apply 'vc-dir-create-fileinfo (pop entries)))))) + ;; Insert directory entries in the right places. + (let ((entry (car entries)) + (node (ewoc-nth vc-ewoc 0))) + ;; Insert . if it is not present. + (unless node + (let ((rd (file-relative-name default-directory))) + (ewoc-enter-last + vc-ewoc (vc-dir-create-fileinfo + rd nil nil nil (expand-file-name default-directory)))) + (setq node (ewoc-nth vc-ewoc 0))) + + (while (and entry node) + (let* ((entryfile (car entry)) + (entrydir (file-name-directory (expand-file-name entryfile))) + (nodedir + (or (vc-dir-fileinfo->directory (ewoc-data node)) + (file-name-directory + (expand-file-name + (vc-dir-fileinfo->name (ewoc-data node))))))) + (cond + ;; First try to find the directory. + ((string-lessp nodedir entrydir) + (setq node (ewoc-next vc-ewoc node))) + ((string-equal nodedir entrydir) + ;; Found the directory, find the place for the file name. + (let ((nodefile (vc-dir-fileinfo->name (ewoc-data node)))) + (cond + ((string-lessp nodefile entryfile) + (setq node (ewoc-next vc-ewoc node))) + ((string-equal nodefile entryfile) + (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry)) + (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry)) + (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil) + (ewoc-invalidate vc-ewoc node) + (setq entries (cdr entries) entry (car entries)) + (setq node (ewoc-next vc-ewoc node))) + (t + (ewoc-enter-before vc-ewoc node + (apply 'vc-dir-create-fileinfo entry)) + (setq entries (cdr entries) entry (car entries)))))) + (t + ;; We need to insert a directory node + (let ((rd (file-relative-name entrydir))) + (ewoc-enter-last + vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))) + ;; Now insert the node itself. + (ewoc-enter-before vc-ewoc node + (apply 'vc-dir-create-fileinfo entry)) + (setq entries (cdr entries) entry (car entries)))))) + ;; We're past the last node, all remaining entries go to the end. + (unless (or node noinsert) + (let* ((lastnode (ewoc-nth vc-ewoc -1)) + (lastdir + (or (vc-dir-fileinfo->directory (ewoc-data lastnode)) + (file-name-directory + (expand-file-name + (vc-dir-fileinfo->name (ewoc-data lastnode))))))) + (dolist (entry entries) + (let ((entrydir (file-name-directory (expand-file-name (car entry))))) + ;; Insert a directory node if needed. + (unless (string-equal lastdir entrydir) + (setq lastdir entrydir) + (let ((rd (file-relative-name entrydir))) + (ewoc-enter-last + vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir)))) + ;; Now insert the node itself. + (ewoc-enter-last vc-ewoc + (apply 'vc-dir-create-fileinfo entry)))))))))) + +(defun vc-dir-busy () + (and (buffer-live-p vc-dir-process-buffer) + (get-buffer-process vc-dir-process-buffer))) + +(defun vc-dir-refresh-files (files default-state) + "Refresh some files in the VC status buffer." + (let ((backend (vc-responsible-backend default-directory)) + (status-buffer (current-buffer)) + (def-dir default-directory)) + (vc-set-mode-line-busy-indicator) + ;; Call the `dir-status-file' backend function. + ;; `dir-status-file' is supposed to be asynchronous. + ;; It should compute the results, and then call the function + ;; passed as an argument in order to update the vc-dir buffer + ;; with the results. + (unless (buffer-live-p vc-dir-process-buffer) + (setq vc-dir-process-buffer + (generate-new-buffer (format " *VC-%s* tmp status" backend)))) + (lexical-let ((buffer (current-buffer))) + (with-current-buffer vc-dir-process-buffer + (cd def-dir) + (erase-buffer) + (vc-call-backend + backend 'dir-status-files def-dir files default-state + (lambda (entries &optional more-to-come) + ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items. + ;; If MORE-TO-COME is true, then more updates will come from + ;; the asynchronous process. + (with-current-buffer buffer + (vc-dir-update entries buffer) + (unless more-to-come + (setq mode-line-process nil) + ;; Remove the ones that haven't been updated at all. + ;; Those not-updated are those whose state is nil because the + ;; file/dir doesn't exist and isn't versioned. + (ewoc-filter vc-ewoc + (lambda (info) + (not (vc-dir-fileinfo->needs-update info)))))))))))) + +(defun vc-dir-refresh () + "Refresh the contents of the VC status buffer. +Throw an error if another update process is in progress." + (interactive) + (if (vc-dir-busy) + (error "Another update process is in progress, cannot run two at a time") + (let ((backend (vc-responsible-backend default-directory)) + (status-buffer (current-buffer)) + (def-dir default-directory)) + (vc-set-mode-line-busy-indicator) + ;; Call the `dir-status' backend function. + ;; `dir-status' is supposed to be asynchronous. + ;; It should compute the results, and then call the function + ;; passed as an argument in order to update the vc-dir buffer + ;; with the results. + + ;; Create a buffer that can be used by `dir-status' and call + ;; `dir-status' with this buffer as the current buffer. Use + ;; `vc-dir-process-buffer' to remember this buffer, so that + ;; it can be used later to kill the update process in case it + ;; takes too long. + (unless (buffer-live-p vc-dir-process-buffer) + (setq vc-dir-process-buffer + (generate-new-buffer (format " *VC-%s* tmp status" backend)))) + ;; set the needs-update flag on all entries + (ewoc-map (lambda (info) (setf (vc-dir-fileinfo->needs-update info) t) nil) + vc-ewoc) + (lexical-let ((buffer (current-buffer))) + (with-current-buffer vc-dir-process-buffer + (cd def-dir) + (erase-buffer) + (vc-call-backend + backend 'dir-status def-dir + (lambda (entries &optional more-to-come) + ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items. + ;; If MORE-TO-COME is true, then more updates will come from + ;; the asynchronous process. + (with-current-buffer buffer + (vc-dir-update entries buffer) + (unless more-to-come + (let ((remaining + (ewoc-collect + vc-ewoc 'vc-dir-fileinfo->needs-update))) + (if remaining + (vc-dir-refresh-files + (mapcar 'vc-dir-fileinfo->name remaining) + 'up-to-date) + (setq mode-line-process nil)))))))))))) + +(defun vc-dir-kill-dir-status-process () + "Kill the temporary buffer and associated process." + (interactive) + (when (buffer-live-p vc-dir-process-buffer) + (let ((proc (get-buffer-process vc-dir-process-buffer))) + (when proc (delete-process proc)) + (setq vc-dir-process-buffer nil) + (setq mode-line-process nil)))) + +(defun vc-dir-kill-query () + ;; Make sure that when the VC status buffer is killed the update + ;; process running in background is also killed. + (if (vc-dir-busy) + (when (y-or-n-p "Status update process running, really kill status buffer?") + (vc-dir-kill-dir-status-process) + t) + t)) + +(defun vc-dir-next-line (arg) + "Go to the next line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-next vc-ewoc arg) + (vc-dir-move-to-goal-column)) + +(defun vc-dir-previous-line (arg) + "Go to the previous line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-prev vc-ewoc arg) + (vc-dir-move-to-goal-column)) + +(defun vc-dir-mark-unmark (mark-unmark-function) + (if (use-region-p) + (let ((firstl (line-number-at-pos (region-beginning))) + (lastl (line-number-at-pos (region-end)))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (line-number-at-pos) lastl) + (funcall mark-unmark-function)))) + (funcall mark-unmark-function))) + +(defun vc-dir-parent-marked-p (arg) + (when vc-dir-insert-directories + ;; Return nil if none of the parent directories of arg is marked. + (let* ((argdata (ewoc-data arg)) + (argdir + (let ((crtdir (vc-dir-fileinfo->directory argdata))) + (if crtdir + crtdir + (file-name-directory (expand-file-name + (vc-dir-fileinfo->name argdata)))))) + (arglen (length argdir)) + (crt arg) + data dir) + ;; Go through the predecessors, checking if any directory that is + ;; a parent is marked. + (while (setq crt (ewoc-prev vc-ewoc crt)) + (setq data (ewoc-data crt)) + (setq dir + (let ((crtdir (vc-dir-fileinfo->directory data))) + (if crtdir + crtdir + (file-name-directory (expand-file-name + (vc-dir-fileinfo->name data)))))) + + (when (and (vc-dir-fileinfo->directory data) + (string-equal (substring argdir 0 (length dir)) dir)) + (when (vc-dir-fileinfo->marked data) + (error "Cannot mark `%s', parent directory `%s' marked" + (vc-dir-fileinfo->name argdata) + (vc-dir-fileinfo->name data))))) + nil))) + +(defun vc-dir-children-marked-p (arg) + ;; Return nil if none of the children of arg is marked. + (when vc-dir-insert-directories + (let* ((argdata (ewoc-data arg)) + (argdir (vc-dir-fileinfo->directory argdata)) + (arglen (length argdir)) + (is-child t) + (crt arg) + data dir) + (while (and is-child (setq crt (ewoc-next vc-ewoc crt))) + (setq data (ewoc-data crt)) + (setq dir + (let ((crtdir (vc-dir-fileinfo->directory data))) + (if crtdir + crtdir + (file-name-directory (expand-file-name + (vc-dir-fileinfo->name data)))))) + (if (string-equal argdir (substring dir 0 arglen)) + (when (vc-dir-fileinfo->marked data) + (error "Cannot mark `%s', child `%s' marked" + (vc-dir-fileinfo->name argdata) + (vc-dir-fileinfo->name data))) + ;; We are done, we got to an entry that is not a child of `arg'. + (setq is-child nil))) + nil))) + +(defun vc-dir-mark-file (&optional arg) + ;; Mark ARG or the current file and move to the next line. + (let* ((crt (or arg (ewoc-locate vc-ewoc))) + (file (ewoc-data crt)) + (isdir (vc-dir-fileinfo->directory file))) + (when (or (and isdir (not (vc-dir-children-marked-p crt))) + (and (not isdir) (not (vc-dir-parent-marked-p crt)))) + (setf (vc-dir-fileinfo->marked file) t) + (ewoc-invalidate vc-ewoc crt) + (unless (or arg (mouse-event-p last-command-event)) + (vc-dir-next-line 1))))) + +(defun vc-dir-mark () + "Mark the current file or all files in the region. +If the region is active, mark all the files in the region. +Otherwise mark the file on the current line and move to the next +line." + (interactive) + (vc-dir-mark-unmark 'vc-dir-mark-file)) + +(defun vc-dir-mark-all-files (arg) + "Mark all files with the same state as the current one. +With a prefix argument mark all files. +If the current entry is a directory, mark all child files. + +The VC commands operate on files that are on the same state. +This command is intended to make it easy to select all files that +share the same state." + (interactive "P") + (if arg + ;; Mark all files. + (progn + ;; First check that no directory is marked, we can't mark + ;; files in that case. + (ewoc-map + (lambda (filearg) + (when (and (vc-dir-fileinfo->directory filearg) + (vc-dir-fileinfo->directory filearg)) + (error "Cannot mark all files, directory `%s' marked" + (vc-dir-fileinfo->name filearg)))) + vc-ewoc) + (ewoc-map + (lambda (filearg) + (unless (vc-dir-fileinfo->marked filearg) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + (let ((data (ewoc-data (ewoc-locate vc-ewoc)))) + (if (vc-dir-fileinfo->directory data) + ;; It's a directory, mark child files. + (let ((crt (ewoc-locate vc-ewoc))) + (unless (vc-dir-children-marked-p crt) + (while (setq crt (ewoc-next vc-ewoc crt)) + (let ((crt-data (ewoc-data crt))) + (unless (vc-dir-fileinfo->directory crt-data) + (setf (vc-dir-fileinfo->marked crt-data) t) + (ewoc-invalidate vc-ewoc crt)))))) + ;; It's a file + (let ((state (vc-dir-fileinfo->state data)) + (crt (ewoc-nth vc-ewoc 0))) + (while crt + (let ((crt-data (ewoc-data crt))) + (when (and (not (vc-dir-fileinfo->marked crt-data)) + (eq (vc-dir-fileinfo->state crt-data) state) + (not (vc-dir-fileinfo->directory crt-data))) + (vc-dir-mark-file crt))) + (setq crt (ewoc-next vc-ewoc crt)))))))) + +(defun vc-dir-unmark-file () + ;; Unmark the current file and move to the next line. + (let* ((crt (ewoc-locate vc-ewoc)) + (file (ewoc-data crt))) + (setf (vc-dir-fileinfo->marked file) nil) + (ewoc-invalidate vc-ewoc crt) + (unless (mouse-event-p last-command-event) + (vc-dir-next-line 1)))) + +(defun vc-dir-unmark () + "Unmark the current file or all files in the region. +If the region is active, unmark all the files in the region. +Otherwise mark the file on the current line and move to the next +line." + (interactive) + (vc-dir-mark-unmark 'vc-dir-unmark-file)) + +(defun vc-dir-unmark-file-up () + "Move to the previous line and unmark the file." + (interactive) + ;; If we're on the first line, we won't move up, but we will still + ;; remove the mark. This seems a bit odd but it is what buffer-menu + ;; does. + (let* ((prev (ewoc-goto-prev vc-ewoc 1)) + (file (ewoc-data prev))) + (setf (vc-dir-fileinfo->marked file) nil) + (ewoc-invalidate vc-ewoc prev) + (vc-dir-move-to-goal-column))) + +(defun vc-dir-unmark-all-files (arg) + "Unmark all files with the same state as the current one. +With a prefix argument unmark all files. +If the current entry is a directory, unmark all the child files. + +The VC commands operate on files that are on the same state. +This command is intended to make it easy to deselect all files +that share the same state." + (interactive "P") + (if arg + (ewoc-map + (lambda (filearg) + (when (vc-dir-fileinfo->marked filearg) + (setf (vc-dir-fileinfo->marked filearg) nil) + t)) + vc-ewoc) + (let* ((crt (ewoc-locate vc-ewoc)) + (data (ewoc-data crt))) + (if (vc-dir-fileinfo->directory data) + ;; It's a directory, unmark child files. + (while (setq crt (ewoc-next vc-ewoc crt)) + (let ((crt-data (ewoc-data crt))) + (unless (vc-dir-fileinfo->directory crt-data) + (setf (vc-dir-fileinfo->marked crt-data) nil) + (ewoc-invalidate vc-ewoc crt)))) + ;; It's a file + (let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt)))) + (ewoc-map + (lambda (filearg) + (when (and (vc-dir-fileinfo->marked filearg) + (eq (vc-dir-fileinfo->state filearg) crt-state)) + (setf (vc-dir-fileinfo->marked filearg) nil) + t)) + vc-ewoc)))))) + +(defun vc-dir-toggle-mark-file () + (let* ((crt (ewoc-locate vc-ewoc)) + (file (ewoc-data crt))) + (if (vc-dir-fileinfo->marked file) + (vc-dir-unmark-file) + (vc-dir-mark-file)))) + +(defun vc-dir-toggle-mark (e) + (interactive "e") + (vc-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file))) + +(defun vc-dir-register () + "Register the marked files, or the current file if no marks." + (interactive) + ;; FIXME: Just pass the fileset to vc-register. + (mapc (lambda (arg) (vc-register nil arg)) + (or (vc-dir-marked-files) (list (vc-dir-current-file))))) + +(defun vc-dir-delete-file () + "Delete the marked files, or the current file if no marks." + (interactive) + (mapc 'vc-delete-file (or (vc-dir-marked-files) + (list (vc-dir-current-file))))) + +(defun vc-dir-show-fileentry (file) + "Insert an entry for a specific file into the current VC status listing. +This is typically used if the file is up-to-date (or has been added +outside of VC) and one wants to do some operation on it." + (interactive "fShow file: ") + (vc-dir-update (list (list (file-relative-name file) (vc-state file))) (current-buffer))) + +(defun vc-dir-find-file () + "Find the file on the current line." + (interactive) + (find-file (vc-dir-current-file))) + +(defun vc-dir-find-file-other-window () + "Find the file on the current line, in another window." + (interactive) + (find-file-other-window (vc-dir-current-file))) + +(defun vc-dir-current-file () + (let ((node (ewoc-locate vc-ewoc))) + (unless node + (error "No file available.")) + (expand-file-name (vc-dir-fileinfo->name (ewoc-data node))))) + +(defun vc-dir-marked-files () + "Return the list of marked files." + (mapcar + (lambda (elem) (expand-file-name (vc-dir-fileinfo->name elem))) + (ewoc-collect vc-ewoc 'vc-dir-fileinfo->marked))) + +(defun vc-dir-marked-only-files () + "Return the list of marked files, for marked directories, return child files." + + (let ((crt (ewoc-nth vc-ewoc 0)) + result) + (while crt + (let ((crt-data (ewoc-data crt))) + (if (vc-dir-fileinfo->marked crt-data) + (if (vc-dir-fileinfo->directory crt-data) + (let* ((dir (vc-dir-fileinfo->directory crt-data)) + (dirlen (length dir)) + data) + (while + (and (setq crt (ewoc-next vc-ewoc crt)) + (string-equal + (substring + (progn + (setq data (ewoc-data crt)) + (let ((crtdir (vc-dir-fileinfo->directory data))) + (if crtdir + crtdir + (file-name-directory + (expand-file-name + (vc-dir-fileinfo->name data)))))) + 0 dirlen) + dir)) + (unless (vc-dir-fileinfo->directory data) + (push (vc-dir-fileinfo->name data) result)))) + (push (expand-file-name (vc-dir-fileinfo->name crt-data)) result) + (setq crt (ewoc-next vc-ewoc crt))) + (setq crt (ewoc-next vc-ewoc crt))))) + result)) + +(defun vc-dir-hide-up-to-date () + "Hide up-to-date items from display." + (interactive) + (ewoc-filter + vc-ewoc + (lambda (crt) (not (eq (vc-dir-fileinfo->state crt) 'up-to-date))))) + +;; FIXME: VCS-specific concept of backend needs to be factored out +(defun vc-default-status-fileinfo-extra (backend file) + nil) + +(defun vc-dir-mark-buffer-changed (&optional fname) + (let* ((file (or fname (expand-file-name buffer-file-name))) + (found-vc-dir-buf nil)) + (save-excursion + (dolist (status-buf (buffer-list)) + (set-buffer status-buf) + ;; look for a vc-dir buffer that might show this file. + (when (eq major-mode 'vc-dir-mode) + (setq found-vc-dir-buf t) + (let ((ddir (expand-file-name default-directory))) + ;; FIXME: VCS-specific stuff needs to be factored out. + ;; This test is cvs-string-prefix-p + (when (eq t (compare-strings file nil (length ddir) ddir nil nil)) + (let* + ((file-short (substring file (length ddir))) + (backend (vc-backend file)) + (state (and backend (vc-state file))) + (extra + (and backend + (vc-call-backend backend 'status-fileinfo-extra file))) + (entry + (list file-short (if state state 'unregistered) extra))) + (vc-dir-update (list entry) status-buf)))))) + ;; We didn't find any vc-dir buffers, remove the hook, it is + ;; not needed. + (unless found-vc-dir-buf (remove-hook 'after-save-hook 'vc-dir-mark-buffer-changed))))) + +;; These things should probably be generally available + +(defun vc-file-tree-walk (dirname func &rest args) + "Walk recursively through DIRNAME. +Invoke FUNC f ARGS on each VC-managed file f underneath it." + (vc-file-tree-walk-internal (expand-file-name dirname) func args) + (message "Traversing directory %s...done" dirname)) + +(defun vc-file-tree-walk-internal (file func args) + (if (not (file-directory-p file)) + (when (vc-backend file) (apply func file args)) + (message "Traversing directory %s..." (abbreviate-file-name file)) + (let ((dir (file-name-as-directory file))) + (mapcar + (lambda (f) (or + (string-equal f ".") + (string-equal f "..") + (member f vc-directory-exclusion-list) + (let ((dirf (expand-file-name f dir))) + (or + (file-symlink-p dirf) ;; Avoid possible loops. + (vc-file-tree-walk-internal dirf func args))))) + (directory-files dir)))))