--- /dev/null
+;;; 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)))))
;;; 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)
: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
: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]."
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
: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))
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 ()
,@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)
(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
(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.
(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)
;;;###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.
(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)
(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
projects / emacs.git / commitdiff