--- vc.el.~1.538~ 2008-02-21 10:48:20.000000000 +0100 +++ vc.el 2008-02-21 15:55:55.000000000 +0100 @@ -167,18 +167,24 @@ ;; in older versions this method was not required to recurse into ;; subdirectories.) ;; -;; - dir-status (dir update-function status-buffer) +;; - dir-status (kickp) ;; -;; Produce RESULT: a list of conses of the form (file . vc-state) -;; for the files in DIR. If a command needs to be run to compute -;; this list, it should be run asynchronously. When RESULT is -;; computed, it should be passed back by doing: -;; (funcall UPDATE-FUNCTION RESULT STATUS-BUFFER) ;; This function is used by vc-status, a replacement for vc-dired. ;; vc-status is still under development, and is NOT feature ;; complete. As such, the requirements for this function might -;; change. -;; This is a replacement for dir-state. +;; change. This is a replacement for dir-state. +;; +;; Produce a list (BLURB RESULT). BLURB is a possibly-multiline, +;; newline-terminated string (or the empty string ""). RESULT is a +;; list of conses of the form (file . vc-state) for the files in +;; DIR. This function is called twice, the first time with KICKP t, +;; the second time, with KICKP nil. In both calls, the current +;; buffer is a scratch buffer with `default-directory' set +;; appropriately. If the backend workings are asynchronous, it must +;; start the subprocess when KICKP is t, using the current buffer as +;; its process buffer. The return value of the second call is the +;; above-described list. See comments in `vc-status-refresh' for +;; more info. ;; ;; * working-revision (file) ;; @@ -606,6 +612,7 @@ (eval-when-compile (require 'cl) (require 'compile) + (require 'button) (require 'dired) ; for dired-map-over-marks macro (require 'dired-aux)) ; for dired-kill-{line,tree} @@ -918,6 +925,10 @@ (defvar vc-dired-mode nil) (make-variable-buffer-local 'vc-dired-mode) +(defsubst vc-overview-p () + "Return non-nil if current buffer is in VC Dired or VC Status mode." + (memq major-mode '(vc-dired-mode vc-status-mode))) + ;; File property caching (defun vc-clear-context () @@ -1794,9 +1805,7 @@ \(current one if no file). AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'." (let ((parent - (if (eq major-mode 'vc-dired-mode) - ;; If we are called from VC dired, the parent buffer is - ;; the current buffer. + (if (vc-overview-p) (current-buffer) (if (and files (equal (length files) 1)) (get-file-buffer (car files)) @@ -1934,7 +1943,7 @@ ;; 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 (vc-buffer-sync))) + (unless (vc-overview-p) (vc-buffer-sync))) (if (not vc-log-operation) (error "No log operation is pending")) ;; save the parameters held in buffer-local variables @@ -2641,12 +2650,7 @@ name) (defvar vc-status nil) - -(defun vc-status-headers (backend dir) - (concat - (format "VC backend : %s\n" backend) - "Repository : The repository goes here\n" - (format "Working dir: %s\n" dir))) +(defvar vc-status-overlay nil) (defun vc-status-printer (fileentry) "Pretty print FILEENTRY." @@ -2673,12 +2677,27 @@ ;;;###autoload (defun vc-status (dir) - "Show the VC status for DIR." + "Show the VC status for DIR in its own buffer. +Reuse an existing buffer if possible, otherwise create a new one +and place it in `vc-status-mode'. Lastly, run `vc-status-refresh'." (interactive "DVC status for directory: ") - (vc-setup-buffer "*vc-status*") - (switch-to-buffer "*vc-status*") - (cd dir) - (vc-status-mode)) + (setq dir (file-name-as-directory dir)) + (let ((ls (buffer-list)) + buf) + (while (and ls (not buf)) + (with-current-buffer (car ls) + (when (and vc-status (string= dir default-directory)) + (setq buf (car ls))) + (setq ls (cdr ls)))) + (unless buf + (set-buffer (setq buf (get-buffer-create + (generate-new-buffer-name + (file-name-nondirectory + (directory-file-name dir)))))) + (setq default-directory dir) + (vc-status-mode)) + (switch-to-buffer buf)) + (vc-status-refresh)) (defvar vc-status-mode-map (let ((map (make-keymap))) @@ -2777,42 +2796,177 @@ (defun vc-status-mode () "Major mode for VC status. +Prepare the buffer to begin with the line: + +Directory: DEFAULT-DIRECTORY + +In DEFAULT-DIRECTORY, all filename components starting from the +project's \"root\" directory are displayed as buttons whose action +is to run command `vc-status' in the respective directory. + +Keys do not self-insert; instead they do different things: \\{vc-status-mode-map}" - (setq mode-name "*VC Status*") - (setq major-mode 'vc-status-mode) - (setq buffer-read-only t) - (use-local-map vc-status-mode-map) - (let ((buffer-read-only nil) - (backend (vc-responsible-backend default-directory)) - entries) - (erase-buffer) + (buffer-disable-undo) + (erase-buffer) + (let* ((backend (vc-responsible-backend default-directory)) + (find-root (vc-find-backend-function backend 'root)) + ;; Use `(or (when ...))' in case `find-root' => nil. + (root (or (when find-root + (funcall find-root default-directory)) + default-directory))) + (setq major-mode 'vc-status-mode + mode-name "VC Status" + vc-mode (symbol-name backend)) + (insert "Directory: ") + (let* ((parent (directory-file-name + (file-name-directory + (directory-file-name root)))) + (p (point)) + (components (split-string (substring default-directory + (length parent)) + "/" t)) + full) + (insert parent) + ;; Make buttons for each directory from root down. Mice, feh. + ;; (For some backends, this degenerates to simply default dir.) + (dolist (name components) + (insert "/") + (setq full (concat (buffer-substring-no-properties p (point)) name)) + (insert-text-button + name + 'dir full + 'action (lambda (button) + (vc-status (button-get button 'dir))) + 'follow-link t))) + ;; Add some whitespace and then a placeholder character that hosts + ;; the overlay for displaying refresh progress (timestamp, "working"). + (insert " -") + (set (make-local-variable 'vc-status-overlay) + (make-overlay (1- (point)) (point))) + (insert "\n") (set (make-local-variable 'vc-status) - (ewoc-create #'vc-status-printer - (vc-status-headers backend default-directory))) - (vc-status-refresh))) + (ewoc-create #'vc-status-printer)) + (use-local-map vc-status-mode-map) + (setq buffer-read-only t))) (put 'vc-status-mode 'mode-class 'special) -(defun vc-update-vc-status-buffer (entries buffer) - (with-current-buffer buffer - (dolist (entry entries) - (ewoc-enter-last vc-status - (vc-status-create-fileinfo (cdr entry) (car entry)))) - (ewoc-goto-node vc-status (ewoc-nth vc-status 0)))) - (defun vc-status-refresh () - "Refresh the contents of the VC status buffer." + "Refresh the contents of the VC Status buffer. +Display at end of first line the HH:MM:SS when the buffer was refreshed. +Display backend-specific info starting from the second line. +Lastly, display `fileinfo' entries, one per line. + +If the backend works asynchronously, display \"(BACKEND working)\" +following the timestamp, and arrange for subsequent calls to +`vc-status-refresh' (while still working) to signal error." (interactive) - ;; This is not very efficient; ewoc could use a new function here. - (ewoc-filter vc-status (lambda (node) nil)) - (let ((backend (vc-responsible-backend default-directory))) - ;; Call the dir-status backend function. dir-status is supposed to - ;; be asynchronous. It should compute the results and call the - ;; function passed as a an arg to update the vc-status buffer with - ;; the results. - (vc-call-backend - backend 'dir-status default-directory - #'vc-update-vc-status-buffer (current-buffer)))) + (unless vc-status + (error "Not in a VC Status buffer")) + (when mode-line-process + (error "Refresh in progress (please wait, or kill buffer)")) + (let* ((backend (vc-responsible-backend default-directory)) + (get-status (cond ((vc-find-backend-function backend 'dir-status)) + (t (kill-buffer nil) + (error "No vc-status support for %s" + backend)))) + (here (current-buffer)) + ;; We manage the scratch buffer, instead of letting the backend + ;; handle it, for two reasons: (a) it's easy to extract process + ;; status from that buffer since we know about it; (b) reducing + ;; potential programming error in the backend is Good Planning. + (scratch (get-buffer-create (format " vc status: %s" + default-directory))) + notice) + ;; We used to do this: Call the backend function, passing it the + ;; default directory, a callback, and the buffer `here'; require + ;; that the backend call the callback with its result and (again) + ;; `here'; require that the callback do its thing in buffer `here'; + ;; implement a callback that satisfied the requirement. + ;; + ;; This was very general, but proved suboptimal in practice: + ;; - There was only one function ever passed as the callback, + ;; so that variability just introduced failure modes. + ;; - Likewise for the (lone) callback, there is only one family + ;; of callers; to handle inappropriate calls would require + ;; more arg checking, and "intention synchronization". + ;; - Each backend managed its own temporary process buffer, + ;; sometimes buggily (eg, never discarding old buffers), + ;; and there was no way to get process status info. + ;; - The default directory of buffer `here' can be computed from + ;; `here', so that variability just introduced failure modes. + ;; + ;; These problems can all be lumped under the concept "unneeded + ;; exposure": More functions, more arguments, more "should call" + ;; sequences, more ways to shoot yourself in the foot. To remedy + ;; this, we move (most of) the inherent (irreducible) complexity of + ;; an asynchronous-support architecture from the (call)stack to the + ;; buffer, a central and strongly-supported data structure in Emacs. + ;; + ;; Essentially the transformation is: "Stay put!" That is, rather + ;; than passing location information around, establish fixed locations + ;; and arrange for the backend to be called "there". More concretely, + ;; this means we manage the buffers -- including lifetime of scratch + ;; buffer -- in one function, using `with-current-buffer' and other + ;; available "current buffer" support, for specifying input (output is + ;; still returned on the stack). + ;; + ;; In exchange for this simplicity, the backend must conform to a + ;; "two-phase" calling sequence. In the first phase, "kick", the + ;; backend starts the subprocess; in the second phase, "collect", + ;; it does the rest of the work to compute its result. Thus, the + ;; only argument the backend needs is PHASE. + ;; + ;; (defun vc-BACKEND-dir-status (phase) + ;; (case phase (kick (START-ASYNC-SUBPROCESS)) + ;; (collect (let (result) + ;; (GROVEL-OVER-OUTPUT) + ;; result)))) + ;; + ;; Furthermore, there are only two phases, so this can be + ;; represented by a boolean, KICKP. + ;; + ;; (defun vc-BACKEND-dir-status (kickp) + ;; (if kickp + ;; (START-ASYNC-SUBPROCESS) + ;; (let (result) + ;; (GROVEL-OVER-OUTPUT) + ;; result))) + ;; + ;; Note the backend is not required to work asynchronously. + ;; (This has not changed from before, comments notwithstanding. ;-) + ;; + ;; Call the backend function in two-phase style. First, kick... + (with-current-buffer scratch + (erase-buffer) + (funcall get-status t)) + ;; Clue in the user if things are working asynchronously. + (when (setq notice (buffer-local-value 'mode-line-process scratch)) + (overlay-put vc-status-overlay 'display + (format "%s (%s working)" (format-time-string "%T") + backend)) + (setq mode-line-process notice)) + (with-current-buffer scratch + (vc-exec-after + ;; ... then collect. + `(let* ((tuple (,get-status nil)) + (blurb (pop tuple)) + (entries (pop tuple))) + (when (buffer-live-p ,here) + (with-current-buffer ,here + (ewoc-filter vc-status 'ignore) + (dolist (entry entries) + (ewoc-enter-last vc-status (vc-status-create-fileinfo + (cdr entry) (car entry)))) + (let ((first (ewoc-nth vc-status 0))) + (when first + (ewoc-goto-node vc-status first) + (vc-status-move-to-goal-column)) + (ewoc-set-hf vc-status blurb (if first "" "(no entries)")) + (overlay-put vc-status-overlay 'display + (format-time-string "%T")) + (setq mode-line-process nil)))) + (kill-buffer nil)))))) (defun vc-status-next-line (arg) "Go to the next line. --- vc-svn.el.~1.70~ 2008-02-21 15:56:53.000000000 +0100 +++ vc-svn.el 2008-02-21 14:51:29.000000000 +0100 @@ -158,34 +158,32 @@ (vc-svn-command t 0 nil "status" (if localp "-v" "-u")) (vc-svn-parse-status)))) -(defun vc-svn-after-dir-status (callback buffer) - (let ((state-map '((?A . added) - (?C . edited) - (?D . removed) - (?I . ignored) - (?M . edited) - (?R . removed) - (?? . unregistered) - ;; This is what vc-svn-parse-status does. - (?~ . edited))) - result) - (goto-char (point-min)) - (while (re-search-forward "^\\(.\\)..... \\(.*\\)$" nil t) - (let ((state (cdr (assq (aref (match-string 1) 0) state-map))) - (filename (match-string 2))) - (when state - (setq result (cons (cons filename state) result))))) - (funcall callback result buffer))) - -(defun vc-svn-dir-status (dir callback buffer) - "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." - (with-current-buffer (get-buffer-create - (generate-new-buffer-name " *vc svn status*")) - (vc-svn-command (current-buffer) 'async nil "status") - (vc-exec-after - `(vc-svn-after-dir-status (quote ,callback) ,buffer)))) +(defun vc-svn-dir-status (kickp) + "Return a list of conses (FILE . STATE) for the default directory." + (if kickp + ;; TODO: Conditionally synchronous. + (vc-svn-command (current-buffer) 'async nil "status") + (let ((state-map '((?A . added) + (?C . edited) + (?D . removed) + (?I . ignored) + (?M . edited) + (?R . removed) + (?? . unregistered) + ;; This is what vc-svn-parse-status does. + (?~ . edited))) + result) + (goto-char (point-min)) + (while (re-search-forward "^\\(.\\)..... \\(.*\\)$" nil t) + (let ((state (cdr (assq (aref (match-string 1) 0) state-map))) + (filename (match-string 2))) + (when state + (setq result (cons (cons filename state) result))))) + (list (shell-command-to-string + ;; TODO: Make customizable. + ;;"svn info . | sed '/Revision:/!d'" + "svn info . | sed '/Path:/d;/Node Kind:/d'") + result)))) (defun vc-svn-working-revision (file) "SVN-specific version of `vc-working-revision'." --- vc-hg.el.~1.50~ 2008-02-21 10:30:55.000000000 +0100 +++ vc-hg.el 2008-02-21 11:19:01.000000000 +0100 @@ -483,42 +483,34 @@ (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 buff) - (let ((status-char nil) - (file nil) - (translation '((?= . up-to-date) - (?C . up-to-date) - (?A . added) - (?R . removed) - (?M . edited) - (?I . ignored) - (?! . deleted) - (?? . unregistered))) - (translated nil) - (result nil)) +(defun vc-hg-dir-status (kickp) + "Return a list of conses (FILE . STATE) for the default directory." + (if kickp + ;; TODO: Conditionally synchronous. + (vc-hg-command (current-buffer) 'async default-directory "status") + (let ((status-char nil) + (file nil) + (translation '((?= . up-to-date) + (?C . up-to-date) + (?A . added) + (?R . removed) + (?M . edited) + (?I . ignored) + (?! . deleted) + (?? . unregistered))) + (translated nil) + (result nil)) (goto-char (point-min)) (while (not (eobp)) - (setq status-char (char-after)) - (setq file - (buffer-substring-no-properties (+ (point) 2) - (line-end-position))) - (setq translated (assoc status-char translation)) - (when (and translated (not (eq (cdr translated) 'up-to-date))) - (push (cons file (cdr translated)) result)) - (forward-line)) - (funcall update-function result buff))) - -;; XXX Experimental function for the vc-dired replacement. -(defun vc-hg-dir-status (dir update-function status-buffer) - "Return a list of conses (file . state) for DIR." - (with-current-buffer - (get-buffer-create - (expand-file-name " *VC-hg* tmp status" dir)) - (erase-buffer) - (vc-hg-command (current-buffer) 'async dir "status") - (vc-exec-after - `(vc-hg-after-dir-status (quote ,update-function) ,status-buffer)))) + (setq status-char (char-after)) + (setq file + (buffer-substring-no-properties (+ (point) 2) + (line-end-position))) + (setq translated (assoc status-char translation)) + (when (and translated (not (eq (cdr translated) 'up-to-date))) + (push (cons file (cdr translated)) result)) + (forward-line)) + (list "" result)))) ;; XXX this adds another top level menu, instead figure out how to ;; replace the Log-View menu. --- vc-git.el.~1.38~ 2008-02-21 10:31:02.000000000 +0100 +++ vc-git.el 2008-02-21 15:46:21.000000000 +0100 @@ -207,52 +207,53 @@ ;; fall back to the default VC representation (vc-default-dired-state-info 'Git file)))) -;;; vc-dir-status support (EXPERIMENTAL) -;;; If vc-directory (which is not half bad under Git, w/ some tweaking) -;;; is to go away, vc-dir-status must at least support the same operations. -;;; At the moment, vc-dir-status design is still fluid (a kind way to say -;;; half-baked, undocumented, and spottily-supported), so the following -;;; should be considered likewise ripe for sudden unannounced change. -;;; YHBW, HAND. --ttn - -(defun vc-git-after-dir-status (callback buffer) - (sort-regexp-fields t "^. \\(.+\\)$" "\\1" (point-min) (point-max)) - (let ((map '((?H . cached) - (?M . unmerged) - (?R . removed) - (?C . edited) - (?K . removed) ; ??? "to be killed" - (?? . unregistered))) - status filename result) - (goto-char (point-min)) - (while (> (point-max) (point)) - (setq status (string-to-char (buffer-substring (point) (1+ (point)))) - status (cdr (assq status map)) - filename (buffer-substring (+ 2 (point)) (line-end-position))) - ;; TODO: Add dynamic selection of which status(es) to display, and - ;; bubble that up to vc-dir-status. For now, we consider `cached' - ;; to be uninteresting, to mimic vc-directory (somewhat). - (unless (eq 'cached status) +(defun vc-git-dir-status (kickp) + "Return a list of conses (FILE . STATE) for the default directory." + ;; Don't do it asynchronously; git is fast and always local. + ;; (vc-git-command (current-buffer) 'async default-directory "status") + (unless kickp + ;; Avoid "-a" so as to be able to distinguish "in index". + (call-process "git" nil t nil "status") + (let* ((root (vc-git-root default-directory)) + (sub (file-relative-name default-directory root)) + ;; If we are not in the project's root dir, discard + ;; lines that do not have the relative-dir prefix. + (keep-rx (concat "^#\t\\([^:]+\\): +" + (if (member sub '("." "./")) + "" + (file-name-as-directory sub)))) + (pair-rx (concat keep-rx "\\(.+\\)$")) + status filename result) + (goto-char (point-min)) + ;; Encode "in index" in the state; eg: `modified' vs `modified/in'. + (when (search-forward "\n# Changes to be committed:\n" nil t) + (search-forward "#\t") + (forward-char -2) + (while (looking-at "#\t[^:]+\\(:\\)") + (replace-match "/in:" t t nil 1) + (forward-line 1))) + (when (search-forward "\n# Untracked files:\n" nil t) + (while (re-search-forward "^#\t" nil t) + (insert "untracked: "))) + (keep-lines keep-rx (point-min) (point-max)) + ;; This sorting is purely cosmetic. We will probably remove it a + ;; little further down the road, when VC Status learns to manage + ;; total ordering and all that jazz. --ttn + (sort-regexp-fields t pair-rx "\\2" (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward pair-rx nil t) + (setq status (match-string 1) + status (if (string-match "new file" status) + (replace-match "new" t t status) + status) + status (intern status) + filename (match-string 2)) + (when (memq status '(renamed renamed/in copied copied/in)) + ;; Discard first name: "ONE -> TWO" becomes "TWO". + (setq filename (substring filename + (+ 4 (string-match " -> " filename))))) (push (cons filename status) result)) - (forward-line 1)) - (funcall callback result buffer))) - -(defun vc-git-dir-status (dir update-function status-buffer) - "Return a list of conses (file . state) for DIR." - (with-current-buffer - (get-buffer-create - (expand-file-name " *VC-Git* tmp status" dir)) - (erase-buffer) - (vc-git-command (current-buffer) 'async dir "ls-files" "-t" - "-c" ; cached - "-d" ; deleted - "-k" ; killed - "-m" ; modified - "-o" ; others - "--directory" - "--exclude-per-directory=.gitignore") - (vc-exec-after - `(vc-git-after-dir-status (quote ,update-function) ,status-buffer)))) + (list "" result)))) ;;; STATE-CHANGING FUNCTIONS