Mercurial > emacs
changeset 94571:61cca370b8f5
vc-dispatcher layer separation.
| author | Eric S. Raymond <esr@snark.thyrsus.com> |
|---|---|
| date | Sat, 03 May 2008 07:06:34 +0000 |
| parents | b288a2a8adc3 |
| children | 3bdffe280ad3 |
| files | lisp/ChangeLog lisp/vc-dispatcher.el lisp/vc.el |
| diffstat | 3 files changed, 1705 insertions(+), 1608 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat May 03 06:10:56 2008 +0000 +++ b/lisp/ChangeLog Sat May 03 07:06:34 2008 +0000 @@ -1,3 +1,10 @@ +2008-05-03 Eric S. Raymond <esr@snark.thyrsus.com> + + * vc-dispatcher.el: New file, separates out the UI and command + execution machinery from VCS-specific logic left in vc.el. The + separation is not yet completely clean, but it's a good start. + * vc.el: This file is about 1700 lines shorter now. + 2008-05-02 Sam Steingold <sds@gnu.org> * progmodes/compile.el (compilation-start): Move setting of
--- /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)))))
--- a/lisp/vc.el Sat May 03 06:10:56 2008 +0000 +++ b/lisp/vc.el Sat May 03 07:06:34 2008 +0000 @@ -696,14 +696,10 @@ ;;; Code: (require 'vc-hooks) +(require 'vc-dispatcher) (require 'tool-bar) (require 'ewoc) -(eval-when-compile - (require 'cl) - (require 'dired) ; for dired-map-over-marks macro - (require 'dired-aux)) ; for dired-kill-{line,tree} - (unless (assoc 'vc-parent-buffer minor-mode-alist) (setq minor-mode-alist (cons '(vc-parent-buffer vc-parent-buffer-name) @@ -720,14 +716,6 @@ :type 'boolean :group 'vc) -(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-initial-comment nil "If non-nil, prompt for initial comment when a file is registered." :type 'boolean @@ -741,11 +729,6 @@ :group 'vc :version "20.3") -(defcustom vc-command-messages nil - "If non-nil, display run messages from back-end commands." - :type 'boolean - :group 'vc) - (defcustom vc-checkin-switches nil "A string or list of strings specifying extra switches for checkin. These are passed to the checkin program by \\[vc-checkin]." @@ -776,24 +759,6 @@ string)) :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-diff-switches nil "A string or list of strings specifying switches for diff under VC. When running diff under a given BACKEND, VC concatenates the values of @@ -864,12 +829,6 @@ :type 'hook :group 'vc) -(defcustom vc-dir-mode-hook nil - "Normal hook run by `vc-dir-mode'. -See `run-hooks'." - :type 'hook - :group 'vc) - ;; Annotate customization (defcustom vc-annotate-color-map (if (and (tty-display-color-p) (<= (display-color-cells) 8)) @@ -1013,12 +972,8 @@ Backends that offer asynchronous diffs should respect this variable in their implementation of vc-BACKEND-diff.") -(defvar vc-log-fileset) (defvar vc-log-revision) -(defvar vc-dired-mode nil) -(make-variable-buffer-local 'vc-dired-mode) - ;; File property caching (defun vc-clear-context () @@ -1080,334 +1035,6 @@ ,@body (save-buffer))))) -;; Common command execution logic to be used by backends - -(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)))) - -(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)))))) - ;;; Code for deducing what fileset and backend to assume (defun vc-responsible-backend (file &optional register) @@ -1585,8 +1212,6 @@ (unless not-urgent (error "Aborted"))))) -(defvar vc-dired-window-configuration) - (defun vc-compatible-state (p q) "Controls which states can be in the same commit." (or @@ -1918,51 +1543,6 @@ (let ((buffer (get-file-buffer file))) (vc-dir-mark-buffer-changed file)))) - -(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))))) - (defun vc-checkout (file &optional writable rev) "Retrieve a copy of the revision REV of FILE. If WRITABLE is non-nil, make sure the retrieved file is writable. @@ -2062,61 +1642,6 @@ (message "Checking in %s...done" (vc-delistify files))) 'vc-checkin-hook)) -(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))) - ;;; Additional entry points for examining version histories ;; (defun vc-default-diff-tree (backend dir rev1 rev2) @@ -2502,140 +2027,7 @@ ;;;###autoload (defalias 'vc-resolve-conflicts 'smerge-ediff) -;; 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) - (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))) - -(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)) +;; Hooks to the dired code (defun vc-dired-hook () "Reformat the listing according to version control. @@ -2713,980 +2105,6 @@ (goto-char (point-min)) (message "No changes pending under %s" default-directory))))) -(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))))) - -(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))) - ;; 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))))) - ;; Named-configuration entry points (defun vc-snapshot-precondition (dir) @@ -4897,30 +3315,6 @@ (set-buffer-modified-p nil) (setq buffer-file-name nil)) -;; 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))))) - (provide 'vc) ;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE