Commit c1b51374 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Change `dir-status' to not take (and pass) status-buffer.

(vc-status-create-fileinfo): Make `extra' optional.
(vc-status-busy): New fun.
(vc-status-menu-map): Use it.
(vc-status-crt-marked): Remove.
(vc-status-update): Rename from vc-status-add-entries.
Add argument so as to prevent addition of entries.  Rewrite.
(vc-update-vc-status-buffer): Remove.
(vc-status-refresh): Don't remove old entries, set them to
up-to-date instead.  Also do it after the update is complete.
(vc-status-marked-files): η-reduce.
parent da5a7abb
2008-04-11 Stefan Monnier <monnier@iro.umontreal.ca>
 
* vc.el: Change `dir-status' to not take (and pass) status-buffer.
(vc-status-create-fileinfo): Make `extra' optional.
(vc-status-busy): New fun.
(vc-status-menu-map): Use it.
(vc-status-crt-marked): Remove.
(vc-status-update): Rename from vc-status-add-entries.
Add argument so as to prevent addition of entries. Rewrite.
(vc-update-vc-status-buffer): Remove.
(vc-status-refresh): Don't remove old entries, set them to
up-to-date instead. Also do it after the update is complete.
(vc-status-marked-files): η-reduce.
* dired.el (dired-read-dir-and-switches): Use read-directory-name even
for non-dialogs.
 
......
......@@ -658,7 +658,7 @@ Optional argument LOCALP is always ignored."
(vc-default-dired-state-info 'Bzr file)))
;; XXX: this needs testing, it's probably incomplete.
(defun vc-bzr-after-dir-status (update-function status-buffer)
(defun vc-bzr-after-dir-status (update-function)
(let ((status-str nil)
(file nil)
(translation '(("+N" . added)
......@@ -693,16 +693,16 @@ Optional argument LOCALP is always ignored."
(line-end-position))
translated) result))
(forward-line))
(funcall update-function result status-buffer)))
(funcall update-function result)))
;; XXX Experimental function for the vc-dired replacement.
;; XXX This probably needs some further refinement and testing.
(defun vc-bzr-dir-status (dir update-function status-buffer)
(defun vc-bzr-dir-status (dir update-function)
"Return a list of conses (file . state) for DIR."
;; XXX: Is this the right command to use?
(vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S")
(vc-exec-after
`(vc-bzr-after-dir-status (quote ,update-function) ,status-buffer)))
`(vc-bzr-after-dir-status (quote ,update-function))))
;;; Revision completion
......
......@@ -855,7 +855,7 @@ state."
(forward-line 1))))
;; XXX Experimental function for the vc-dired replacement.
(defun vc-cvs-after-dir-status (update-function status-buffer)
(defun vc-cvs-after-dir-status (update-function)
;; Heavily inspired by vc-cvs-parse-status. AKA a quick hack.
;; It needs a lot of testing.
(let ((status nil)
......@@ -909,14 +909,14 @@ state."
(push (list file status) result))))))
(goto-char (point-max))
(widen))
(funcall update-function result status-buffer)))
(funcall update-function result)))
;; XXX Experimental function for the vc-dired replacement.
(defun vc-cvs-dir-status (dir update-function status-buffer)
(defun vc-cvs-dir-status (dir update-function)
"Create a list of conses (file . state) for DIR."
(vc-cvs-command (current-buffer) 'async dir "status")
(vc-exec-after
`(vc-cvs-after-dir-status (quote ,update-function) ,status-buffer)))
`(vc-cvs-after-dir-status (quote ,update-function))))
(defun vc-cvs-get-entries (dir)
"Insert the CVS/Entries file from below DIR into the current buffer.
......
......@@ -313,13 +313,13 @@
;; Variable used to keep the intermediate results for vc-git-status.
(defvar vc-git-status-result nil)
(defun vc-git-after-dir-status-stage2 (update-function status-buffer)
(defun vc-git-after-dir-status-stage2 (update-function)
(goto-char (point-min))
(while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
(push (list (match-string 1) 'unregistered (vc-git-create-extra-fileinfo 0 0)) vc-git-status-result))
(funcall update-function (nreverse vc-git-status-result) status-buffer))
(funcall update-function (nreverse vc-git-status-result)))
(defun vc-git-after-dir-status-stage1 (update-function status-buffer)
(defun vc-git-after-dir-status-stage1 (update-function)
(goto-char (point-min))
(while (re-search-forward
":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
......@@ -339,9 +339,9 @@
(vc-git-command (current-buffer) 'async nil "ls-files" "-z" "-o"
"--directory" "--no-empty-directory" "--exclude-standard")
(vc-exec-after
`(vc-git-after-dir-status-stage2 (quote ,update-function) ,status-buffer)))
`(vc-git-after-dir-status-stage2 (quote ,update-function))))
(defun vc-git-after-dir-status-stage1-empty-db (update-function status-buffer)
(defun vc-git-after-dir-status-stage1-empty-db (update-function)
(goto-char (point-min))
(while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
(let ((new-perm (string-to-number (match-string 1) 8))
......@@ -351,9 +351,9 @@
(vc-git-command (current-buffer) 'async nil "ls-files" "-z" "-o"
"--directory" "--no-empty-directory" "--exclude-standard")
(vc-exec-after
`(vc-git-after-dir-status-stage2 (quote ,update-function) ,status-buffer)))
`(vc-git-after-dir-status-stage2 (quote ,update-function))))
(defun vc-git-dir-status (dir update-function status-buffer)
(defun vc-git-dir-status (dir update-function)
"Return a list of conses (file . state) for DIR."
;; Further things that would have to be fixed later:
;; - how to handle unregistered directories
......@@ -364,10 +364,10 @@
(vc-git-command (current-buffer) 'async nil "ls-files" "-z" "-c" "-s")
(vc-exec-after
`(vc-git-after-dir-status-stage1-empty-db
(quote ,update-function) ,status-buffer)))
(quote ,update-function))))
(vc-git-command (current-buffer) 'async nil "diff-index" "-z" "-M" "HEAD")
(vc-exec-after
`(vc-git-after-dir-status-stage1 (quote ,update-function) ,status-buffer))))
`(vc-git-after-dir-status-stage1 (quote ,update-function)))))
(defun vc-git-status-extra-headers (dir)
(let ((str (with-output-to-string
......
......@@ -475,7 +475,7 @@ REV is the revision to check out into WORKFILE."
(define-derived-mode vc-hg-incoming-mode vc-hg-log-view-mode "Hg-Incoming")
;; XXX Experimental function for the vc-dired replacement.
(defun vc-hg-after-dir-status (update-function status-buffer)
(defun vc-hg-after-dir-status (update-function)
(let ((status-char nil)
(file nil)
(translation '((?= . up-to-date)
......@@ -498,13 +498,13 @@ REV is the revision to check out into WORKFILE."
(when (and translated (not (eq (cdr translated) 'up-to-date)))
(push (list file (cdr translated)) result))
(forward-line))
(funcall update-function result status-buffer)))
(funcall update-function result)))
;; XXX Experimental function for the vc-dired replacement.
(defun vc-hg-dir-status (dir update-function status-buffer)
(defun vc-hg-dir-status (dir update-function)
(vc-hg-command (current-buffer) 'async dir "status")
(vc-exec-after
`(vc-hg-after-dir-status (quote ,update-function) ,status-buffer)))
`(vc-hg-after-dir-status (quote ,update-function))))
;; XXX this adds another top level menu, instead figure out how to
;; replace the Log-View menu.
......
......@@ -182,7 +182,7 @@ For a description of possible values, see `vc-check-master-templates'."
(vc-rcs-state file)))))
;; XXX Experimental function for the vc-dired replacement.
(defun vc-rcs-dir-status (dir update-function status-buffer)
(defun vc-rcs-dir-status (dir update-function)
;; XXX: quick hack, there should be a better way to do this,
;; but it's not worse than vc-dired :-).
(let ((flist (vc-expand-dirs (list dir)))
......@@ -191,7 +191,7 @@ For a description of possible values, see `vc-check-master-templates'."
(let ((state (vc-state file))
(frel (file-relative-name file)))
(push (list frel state) result)))
(funcall update-function result status-buffer)))
(funcall update-function result)))
(defun vc-rcs-working-revision (file)
"RCS-specific version of `vc-working-revision'."
......
......@@ -145,7 +145,7 @@ For a description of possible values, see `vc-check-master-templates'."
(vc-sccs-state file)))
;; XXX Experimental function for the vc-dired replacement.
(defun vc-sccs-dir-status (dir update-function status-buffer)
(defun vc-sccs-dir-status (dir update-function)
;; XXX: quick hack, there should be a better way to do this,
;; but it's not worse than vc-dired :-).
(let ((flist (vc-expand-dirs (list dir)))
......@@ -154,7 +154,7 @@ For a description of possible values, see `vc-check-master-templates'."
(let ((state (vc-state file))
(frel (file-relative-name file)))
(push (list frel state) result)))
(funcall update-function result status-buffer)))
(funcall update-function result)))
(defun vc-sccs-working-revision (file)
"SCCS-specific version of `vc-working-revision'."
......
......@@ -158,7 +158,7 @@ If you want to force an empty list of arguments, use t."
(vc-svn-command t 0 nil "status" (if localp "-v" "-u"))
(vc-svn-parse-status))))
(defun vc-svn-after-dir-status (callback buffer)
(defun vc-svn-after-dir-status (callback)
(let ((state-map '((?A . added)
(?C . conflict)
(?D . removed)
......@@ -177,13 +177,13 @@ If you want to force an empty list of arguments, use t."
(setq result (cons (list filename state) result)))))
(funcall callback result buffer)))
(defun vc-svn-dir-status (dir callback buffer)
(defun vc-svn-dir-status (dir callback)
"Run 'svn status' for DIR and update BUFFER via CALLBACK.
CALLBACK is called as (CALLBACK RESULT BUFFER), where
RESULT is a list of conses (FILE . STATE) for directory DIR."
(vc-svn-command (current-buffer) 'async nil "status")
(vc-exec-after
`(vc-svn-after-dir-status (quote ,callback) ,buffer)))
`(vc-svn-after-dir-status (quote ,callback))))
(defun vc-svn-working-revision (file)
"SVN-specific version of `vc-working-revision'."
......
......@@ -168,7 +168,7 @@
;; in older versions this method was not required to recurse into
;; subdirectories.)
;;
;; - dir-status (dir update-function status-buffer)
;; - dir-status (dir update-function)
;;
;; Produce RESULT: a list of lists of the form (FILE VC-STATE EXTRA)
;; for the files in DIR.
......@@ -176,11 +176,11 @@
;; If a command needs to be run to compute this list, it should be
;; run asynchronously using (current-buffer) as the buffer for the
;; command. When RESULT is computed, it should be passed back by
;; doing: (funcall UPDATE-FUNCTION RESULT STATUS-BUFFER nil).
;; doing: (funcall UPDATE-FUNCTION RESULT nil).
;; If the backend uses a process filter, hence it produces partial results,
;; they can be passed back by doing:
;; (funcall UPDATE-FUNCTION RESULT STATUS-BUFFER t)
;; and then do a (funcall UPDATE-FUNCTION RESULT STATUS-BUFFER nil)
;; (funcall UPDATE-FUNCTION RESULT t)
;; and then do a (funcall UPDATE-FUNCTION RESULT nil)
;; when all the results have been computed.
;; To provide more backend specific functionality for `vc-status'
;; the following functions might be needed: `status-extra-headers',
......@@ -582,6 +582,9 @@
;;; Todo:
;; - vc-status-kill-dir-status-process should not be specific to dir-status,
;; it should work for other async commands as well (pull/push/...).
;;
;; - vc-update/vc-merge should deal with VC systems that don't
;; update/merge on a file basis, but on a whole repository basis.
;;
......@@ -1438,10 +1441,8 @@ Otherwise, throw an error."
(error "All members of a fileset must be under the same version-control system."))))
marked))
((eq major-mode 'vc-status-mode)
(let ((marked (vc-status-marked-files)))
(if marked
marked
(list (vc-status-current-file)))))
(or (vc-status-marked-files)
(list (vc-status-current-file))))
((vc-backend buffer-file-name)
(list buffer-file-name))
((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
......@@ -2705,14 +2706,16 @@ With prefix arg READ-SWITCHES, specify a value to override
;; Each item displayed corresponds to one of these defstructs.
(defstruct (vc-status-fileinfo
(:copier nil)
(:type list) ;So we can use `member' on lists of FIs.
(:constructor
vc-status-create-fileinfo (name state extra &optional marked))
;; We could define it as an alias for `list'.
vc-status-create-fileinfo (name state &optional extra marked))
(:conc-name vc-status-fileinfo->))
marked
name ;Keep it as first, for `member'.
state
name
;; For storing backend specific information.
extra)
extra
marked)
(defvar vc-status nil)
......@@ -2804,11 +2807,11 @@ specific headers."
:help "Quit"))
(define-key map [kill]
'(menu-item "Kill Update Command" vc-status-kill-dir-status-process
:enable vc-status-process-buffer
:enable (vc-status-busy)
:help "Kill the command that updates VC status buffer"))
(define-key map [refresh]
'(menu-item "Refresh" vc-status-refresh
:enable (not vc-status-process-buffer)
:enable (not (vc-status-busy))
:help "Refresh the contents of the VC status buffer"))
(define-key map [remup]
'(menu-item "Hide up-to-date" vc-status-hide-up-to-date
......@@ -2974,16 +2977,12 @@ specific headers."
(defvar vc-status-process-buffer nil
"The buffer used for the asynchronous call that computes the VC status.")
(defvar vc-status-crt-marked nil
"The list of marked files before `vc-status-refresh'.")
(defun vc-status-mode ()
"Major mode for VC status.
\\{vc-status-mode-map}"
(setq mode-name "VC Status")
(setq major-mode 'vc-status-mode)
(setq buffer-read-only t)
(set (make-local-variable 'vc-status-crt-marked) nil)
(use-local-map vc-status-mode-map)
(set (make-local-variable 'tool-bar-map) vc-status-tool-bar-map)
(let ((buffer-read-only nil)
......@@ -2999,76 +2998,52 @@ specific headers."
(put 'vc-status-mode 'mode-class 'special)
(defun vc-status-add-entries (entries buffer)
(defun vc-status-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-status buffer BUFFER.
(with-current-buffer buffer
(when entries
;; 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-status-add-entries.
(setq entries (sort (copy-sequence entries)
(lambda (entry1 entry2)
(string-lessp (car entry1) (car entry2)))))
(let ((entry (pop entries))
(node (ewoc-nth vc-status 0)))
(while entry
(while (and vc-status-crt-marked
(string-lessp (car vc-status-crt-marked) (car entry)))
(setq vc-status-crt-marked (cdr vc-status-crt-marked)))
(let* ((file (car entry))
(state (nth 1 entry))
(extra (nth 2 entry))
(marked (and vc-status-crt-marked
(string-equal (car vc-status-crt-marked) file))))
(cond ((not node)
(setq node (ewoc-enter-last vc-status
(vc-status-create-fileinfo file state extra marked)))
(setq entry (pop entries)))
((string-lessp (vc-status-fileinfo->name (ewoc-data node)) file)
(setq node (ewoc-next vc-status node)))
((string-equal (vc-status-fileinfo->name (ewoc-data node)) file)
(setf (vc-status-fileinfo->state (ewoc-data node)) state)
(setf (vc-status-fileinfo->extra (ewoc-data node)) extra)
(ewoc-invalidate vc-status node)
(setq entry (pop entries)))
(t
(setq node (ewoc-enter-before vc-status node
(vc-status-create-fileinfo file state extra marked)))
(setq entry (pop entries))))))))))
(defun vc-update-vc-status-buffer (entries buffer &optional more-to-come)
;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
;; BUFFER is the *vc-status* buffer to be updated with ENTRIES
;; If MORE-TO-COME is true, then more updates will come from the
;; asynchronous process.
(with-current-buffer buffer
(when entries
(vc-status-add-entries entries buffer)
(ewoc-goto-node vc-status (ewoc-nth vc-status 0)))
;; No more updates are expected from the asynchronous process.
(unless more-to-come
(setq vc-status-process-buffer nil)
;; We are done, turn off the mode-line "in progress" message.
(setq mode-line-process nil))))
;; 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-status-update.
(setq entries (sort entries
(lambda (entry1 entry2)
(string-lessp (car entry1) (car entry2)))))
(let ((entry (car entries))
(node (ewoc-nth vc-status 0)))
(while (and entry node)
(let ((entryfile (car entry))
(nodefile (vc-status-fileinfo->name (ewoc-data node))))
(cond
((string-lessp nodefile entryfile)
(setq node (ewoc-next vc-status node)))
((string-lessp nodefile entryfile)
(unless noinsert
(ewoc-enter-before vc-status node
(apply 'vc-status-create-fileinfo entry)))
(setq entries (cdr entries) entry (car entries)))
(t
(setf (vc-status-fileinfo->state (ewoc-data node)) (nth 1 entry))
(setf (vc-status-fileinfo->extra (ewoc-data node)) (nth 2 entry))
(ewoc-invalidate vc-status node)
(setq entries (cdr entries) entry (car entries))
(setq node (ewoc-next vc-status node))))))
(unless (or node noinsert)
;; We're past the last node, all remaining entries go to the end.
(while entries
(ewoc-enter-last vc-status
(apply 'vc-status-create-fileinfo (pop entries))))))))
(defun vc-status-busy ()
(and (buffer-live-p vc-status-process-buffer)
(get-buffer-process vc-status-process-buffer)))
(defun vc-status-refresh ()
"Refresh the contents of the VC status buffer.
Throw an error if another update process is in progress."
(interactive)
(if vc-status-process-buffer
(if (vc-status-busy)
(error "Another update process is in progress, cannot run two at a time")
;; We clear the ewoc, but remember the marked files so that we can
;; mark them again after the refresh is done.
;; This is not very efficient; ewoc could use a new function here.
(setq vc-status-crt-marked
(mapcar
(lambda (elem)
(vc-status-fileinfo->name elem))
(ewoc-collect
vc-status
(lambda (crt) (vc-status-fileinfo->marked crt)))))
(ewoc-filter vc-status (lambda (node) nil))
(let ((backend (vc-responsible-backend default-directory))
(status-buffer (current-buffer))
(def-dir default-directory))
......@@ -3084,14 +3059,35 @@ Throw an error if another update process is in progress."
;; `vc-status-process-buffer' to remember this buffer, so that
;; it can be used later to kill the update process in case it
;; takes too long.
(setq vc-status-process-buffer
(get-buffer-create
(generate-new-buffer-name (format " *VC-%s* tmp status" backend))))
(with-current-buffer vc-status-process-buffer
(cd def-dir)
(erase-buffer)
(vc-call-backend backend 'dir-status def-dir
#'vc-update-vc-status-buffer status-buffer)))))
(unless (buffer-live-p vc-status-process-buffer)
(setq vc-status-process-buffer
(generate-new-buffer (format " *VC-%s* tmp status" backend))))
(lexical-let ((oldentries (ewoc-collect vc-status (lambda (_) t)))
(buffer (current-buffer)))
(with-current-buffer vc-status-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
(dolist (entry entries)
(setq oldentries
(delq (member (car entry) oldentries) oldentries)))
(vc-status-update entries buffer)
(ewoc-goto-node vc-status (ewoc-nth vc-status 0))
;; No more updates are expected from the asynchronous process.
(unless more-to-come
;; We are done, turn off the mode-line "in progress" message.
(setq mode-line-process nil)
;; Update old entries that were not mentioned, and were
;; hence implicitly given as uptodate.
(dolist (entry oldentries)
(setf (vc-status-fileinfo->state entry) 'up-to-date))
(vc-status-update oldentries buffer 'noinsert))))))))))
(defun vc-status-kill-dir-status-process ()
"Kill the temporary buffer and associated process."
......@@ -3236,10 +3232,9 @@ that share the same state."
(defun vc-status-register ()
"Register the marked files, or the current file if no marks."
(interactive)
(let ((files (or (vc-status-marked-files)
(list (vc-status-current-file)))))
(dolist (file files)
(vc-register file))))
;; FIXME: Just pass the fileset to vc-register.
(mapc 'vc-register (or (vc-status-marked-files)
(list (vc-status-current-file)))))
(defun vc-status-find-file ()
"Find the file on the current line."
......@@ -3260,11 +3255,8 @@ that share the same state."
(defun vc-status-marked-files ()
"Return the list of marked files"
(mapcar
(lambda (elem)
(expand-file-name (vc-status-fileinfo->name elem)))
(ewoc-collect
vc-status
(lambda (crt) (vc-status-fileinfo->marked crt)))))
(lambda (elem) (expand-file-name (vc-status-fileinfo->name elem)))
(ewoc-collect vc-status 'vc-status-fileinfo->marked)))
(defun vc-status-hide-up-to-date ()
"Hide up-to-date items from display."
......@@ -3297,7 +3289,7 @@ that share the same state."
(vc-call-backend backend 'status-fileinfo-extra file)))
(entry
(list file-short (if state state 'unregistered) extra)))
(vc-status-add-entries (list entry) status-buf))))))
(vc-status-update (list entry) status-buf))))))
;; We didn't find any vc-status buffers, remove the hook, it is
;; not needed.
(unless found-vc-status-buf (remove-hook 'after-save-hook 'vc-status-mark-buffer-changed)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment