diff --git a/dvc/debian/changelog b/dvc/debian/changelog index eae7ec0..40a779a 100644 --- a/dvc/debian/changelog +++ b/dvc/debian/changelog @@ -1,6 +1,7 @@ -dvc (0r20080829-1) unstable; urgency=low +dvc (0r20091206-1) unstable; urgency=low * New snapshot. + * Add dvc.texinfo license to debian/copyright. * Julien Danjou is the sponsor for DVC (Closes: #496930). - -- Daniel Dehennin Fri, 29 Aug 2008 19:27:14 +0200 + -- Daniel Dehennin Sun, 06 Dec 2009 11:54:58 +0100 diff --git a/dvc/debian/compat b/dvc/debian/compat index b8626c4..7f8f011 100644 --- a/dvc/debian/compat +++ b/dvc/debian/compat @@ -1 +1 @@ -4 +7 diff --git a/dvc/debian/control b/dvc/debian/control index 861f759..a138681 100644 --- a/dvc/debian/control +++ b/dvc/debian/control @@ -2,15 +2,15 @@ Source: dvc Section: devel Priority: optional Maintainer: Daniel Dehennin -Build-Depends: cdbs (>= 0.4.50), debhelper +Build-Depends: cdbs (>= 0.4.50), debhelper (>= 7) Build-Depends-Indep: autoconf, emacs22 | emacs21 | xemacs21 | emacsen, texinfo -Standards-Version: 3.8.0.1 +Standards-Version: 3.8.3 Vcs-Bzr: http://bzr.xsteve.at/dvc/ Homepage: http://download.gna.org/dvc/ Package: dvc Architecture: all -Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot +Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot, dpkg (>= 1.15.4) | install-info, ${misc:Depends} Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone Description: Emacs front-end to distributed version control systems DVC is an attempt to build a common infrastructure for various diff --git a/dvc/debian/copyright b/dvc/debian/copyright index ccbf461..2f43314 100644 --- a/dvc/debian/copyright +++ b/dvc/debian/copyright @@ -37,7 +37,8 @@ License: This package 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; version 2 dated June, 1991. + the Free Software Foundation; version 2 dated June, 1991, or + (at your option) any later version. This package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/dvc/lisp/xmtn-automate.el b/dvc/lisp/xmtn-automate.el index 9887655..eb7e9d6 100644 --- a/dvc/lisp/xmtn-automate.el +++ b/dvc/lisp/xmtn-automate.el @@ -26,98 +26,39 @@ ;; This library provides access to monotone's "automate" interface ;; from Emacs Lisp. ;; -;; I found monotone's automate stdio mode (see -;; http://www.venge.net/monotone/docs/Automation.html for details) -;; rather intriguing, so I tried to make full use of it. I don't know -;; whether it is really significantly more efficient than spawning a -;; new subprocess for each command. But, in theory, feeding multiple -;; commands to one process allows that process to do all kinds of -;; smart caching, so it could make very large differences, even -;; differences in orders of magnitude. I don't know whether monotone -;; currently does any caching, but at least this means we have an -;; excuse for not doing any caching in Emacs. (If it becomes clear -;; that caching would be a good idea, it can be implemented in -;; monotone instead of Emacs; this way, other front-ends to monotone -;; can also benefit from it.) +;; see http://www.monotone.ca/docs/Automation.html#Automation for +;; details of the monotone automate command. +;; +;; mtn automate allows sending several commands to a single mtn +;; process, and provides the results in a form that is easy to +;; parse. It does some caching between command, and will do more in +;; the future, so this is a significant speed-up over spawning a new +;; subprocess for each command. ;; ;; To allow xmtn-automate to track how long an automate stdio process -;; needs to be kept around, we introduce the concept of a session. To -;; the programmer using this library, a session is an opaque object -;; that is needed to run automate commands. Each session is -;; associated with a monotone workspace ("root") that the commands -;; will operate on. (Using xmtn-auomate to run commands with no -;; workspace is not currently part of the design.) A session can be -;; obtained using `xmtn-automate-with-session' and has dynamic extent. -;; Note that `xmtn-automate-with-session' doesn't necessarily start a -;; fresh monotone process; xmtn-automate may reuse existing session -;; objects and processes, or launch the process only when the first -;; command is sent to the session. There is also no guarantee about -;; how long xmtn-automate will keep the process running after -;; `xmtn-automate-with-session' exits. (The function -;; `xmtn-automate-terminate-processes-in-root' can be used to tell -;; xmtn-automate to terminate all processes in a given root as soon as -;; possible, and wait until they terminate. I imagine this could be -;; necessary to free locks, but whether mtn automate stdio does any -;; locking doesn't seem to be specified in monotone's manual.) To put -;; it another way, the mapping between `xmtn-automate-with-session' -;; forms and monotone processes is not necessarily one-to-one. -;; -;; `xmtn-automate-with-session' forms can safely be nested. +;; needs to be kept around, and to store meta data, we introduce the +;; concept of a session. To the programmer using this library, a +;; session is an opaque object that is needed to run automate +;; commands. Each session is associated with a monotone workspace +;; ("root") that the commands will operate on. A session can be +;; obtained using `xmtn-automate-cache-session'. Note that +;; `xmtn-automate-cache-session' doesn't necessarily start a fresh +;; monotone process, if a session with that root already exists. The +;; process must be killed with `xmtn-automate-kill-session'. ;; ;; Once you have a session object, you can use -;; `xmtn-automate-with-command' forms to send commands to monotone. -;; Each such form gets you a so-called command-handle. Again, this is -;; an opaque object with dynamic extent. You can use this handle to -;; check the error code of the command and obtain its output. Your -;; Emacs Lisp code can also do other computation while the monotone -;; command runs. Allowing this kind of parallelism and incremental -;; processing of command output is the main reason for introducing -;; command handles. +;; `xmtn-automate-new-command' to send commands to monotone. ;; -;; The following operations are defined on command handles. +;; A COMMAND is a list of strings (the command and its arguments), or +;; a cons of lists of strings. If car COMMAND is a list, car COMMAND is +;; options (without leading "--"), cdr is the command and arguments. ;; -;; * xmtn-automate-command-error-code (command-handle) --> 0, 1 or 2 -;; -;; Returns the error code of the command. See monotone -;; documentation. This operation blocks until the monotone process -;; has sent the error code. -;; -;; * xmtn-automate-command-wait-until-finished (command-handle) --> -;; nil -;; -;; Blocks until the command has finished (successfully or not). -;; After this operation returns, `xmtn-automate-command-finished-p' -;; will return true for this command. -;; -;; * xmtn-automate-command-buffer (command-handle) --> buffer -;; -;; Returns the so-called command buffer associated with the command -;; handle. This is a buffer with the output that the command has -;; generated so far. The buffer contents will be updated as new -;; output arrives. The buffer has the same extent as the command -;; handle. This operation does not block. -;; -;; * xmtn-automate-command-write-marker-position (command-handle) -;; --> position -;; -;; The position in the output buffer after the last character of -;; output the command has generated so far. This is also where new -;; output will be inserted. This operation does not block. -;; -;; * xmtn-automate-command-finished-p (command-handle) --> boolean -;; -;; Returns nil if the command is still running, non-nil if it has -;; finished (successfully or not). If this function returns non-nil, -;; the full output of the command is available in the command buffer. -;; This operation does not block. -;; -;; * xmtn-automate-command-accept-output (command-handle) --> -;; output-received-p -;; -;; Allows Emacs to process more output from the command (and -;; possibly from other processes). Blocks until more output has -;; been received from the command or the command has finished. -;; Returns non-nil if more output has been received. +;; `xmtn-automate-new-command' returns a command handle. You use this +;; handle to check the error code of the command and obtain its +;; output. Your Emacs Lisp code can also do other computation while +;; the monotone command runs. Allowing this kind of parallelism and +;; incremental processing of command output is the main reason for +;; introducing command handles. ;; ;; The intention behind this protocol is to allow Emacs Lisp code to ;; process command output incrementally as it arrives instead of @@ -127,88 +68,15 @@ ;; hard to tune it, either. So I'm not sure whether incremental ;; processing is useful. ;; -;; In the output buffer, the "chunking" (the :::: thing) that monotone automate stdio does -;; has already been decoded and removed. However, no other processing or -;; parsing has been done. The output buffer contains raw 8-bit data. -;; -;; Different automate commands generate data in different formats: For -;; example, get_manifest generates basic_io; select generates a list -;; of lines with one ID each, graph generates a list of lines with one -;; or more IDs each; inventory and the packet_* commands generate -;; different custom line-based formats; and get_file generates binary -;; output. Parsing these formats is not part of xmtn-automate. -;; -;; You shouldn't manually kill the output buffer; xmtn-automate will take -;; care of it when the `xmtn-automate-with-command' form exits. -;; -;; Example: -;; -;; (xmtn-automate-with-session (session "/path/to/workspace") -;; ;; The variable `session' now holds a session object associated -;; ;; with the workspace. -;; (xmtn-automate-with-command (handle session '("get_base_revision_id")) -;; ;; The variable `handle' now holds a command handle. -;; ;; Check that the command was successful (not described above); -;; ;; generate a default error message otherwise and abort. -;; (xmtn-automate-command-check-for-and-report-error handle) -;; ;; Wait until the entire output of the command has arrived. -;; (xmtn-automate-command-wait-until-finished handle) -;; ;; Process output (in command buffer). -;; (message "Base revision id is %s" -;; (with-current-buffer (xmtn-automate-command-buffer handle) -;; (buffer-substring (point-min) -;; ;; Ignore final newline. -;; (1- (point-max))))))) -;; -;; There are some utility functions built on top of this general -;; interface that help express common uses more concisely; for -;; example, -;; -;; (message "Base revision id is %s" -;; (xmtn-automate-simple-command-output-line -;; "/path/to/workspace" '("get_base_revision_id"))) -;; -;; does the same thing as the above code. -;; -;; If multiple "simple" automate commands are run in succession on the -;; same workspace, it's a good idea to wrap an -;; `xmtn-automate-with-session' form around them so xmtn knows that it -;; should reuse the same process. -;; -;; (xmtn-automate-with-session (nil "/path/to/workspace") -;; (message "Base revision id is %s, current revision is %s" -;; (xmtn-automate-simple-command-output-line -;; "/path/to/workspace" '("get_base_revision_id")) -;; (xmtn-automate-simple-command-output-line -;; "/path/to/workspace" '("get_current_revision_id"))) -;; -;; Here, the session object is not explicitly passed to the functions -;; that actually feed commands to monotone. But, since the containing -;; session is still open after the first command, xmtn knows that it -;; should keep the process alive, and it is smart enough to reuse the -;; process for the second command. -;; -;; The fact that `xmtn-automate-with-command' always forces commands -;; to either happen in sequence or properly nested can be a -;; limitation. For example, it's not possible to write a -;; (non-recursive) loop that runs N automate commands and processes -;; their output, always launching the (k+1)th automate command ahead -;; of time to run in parallel with the kth iteration. (Some of the -;; revlist and cert-parsing code really wants to do this, I think.) -;; (But maybe writing this recursively wouldn't be all that bad... It -;; is asymptotically less (stack-!)space-efficient but makes it -;; impossible to get the cleanup wrong.) Providing the two halves of -;; `xmtn-automate-with-command' as two functions -;; `xmtn-automate-open-command' and `xmtn-automate-close-command' that -;; always need to be called in pairs would be more flexible. (Common -;; Lisp also has with-open-file but also open and close.) +;; In the output buffer, the mtn stdio output header (::::) has been processed; +;; only the data is present. + +;; There are some notes on the design of xmtn in +;; docs/xmtn-readme.txt. ;;; Code: -;;; There are some notes on the design of xmtn in -;;; docs/xmtn-readme.txt. - (eval-and-compile (require 'cl) (require 'parse-time) ;for parse-integer @@ -255,92 +123,36 @@ (xmtn-automate-command-finished-p handle)))) nil) -(defvar xmtn-automate--*sessions* '()) +(defvar xmtn-automate--*sessions* '() + "Assoc list of sessions, indexed by uniquified root directory.") (defun xmtn-automate-cache-session (root) - "Create a mtn automate session for workspace ROOT, store it in -session cache, return it (for later kill)." - (let* ((default-directory (file-name-as-directory root)) - (key (file-truename default-directory)) - (session (xmtn-automate--make-session root key))) - (setq xmtn-automate--*sessions* - (acons key session xmtn-automate--*sessions*)) - session)) + "If necessary, create a mtn automate session for workspace +ROOT, store it in session cache. Return session." + ;; we require an explicit root argument here, rather than relying on + ;; default-directory, because one application is to create several + ;; sessions for several workspaces, and operate on them as a group + ;; (see xmtn-multi-status.el, for example). + (let* ((default-directory (dvc-uniquify-file-name root)) + (session (xmtn-automate-get-cached-session default-directory))) + (or session + (progn + (setq session (xmtn-automate--make-session default-directory default-directory)) + (setq xmtn-automate--*sessions* + (acons default-directory session xmtn-automate--*sessions*)) + session)))) (defun xmtn-automate-get-cached-session (key) - "Return a session from the cache, or nil." - ;; separate function so we can debug it + "Return a session from the cache, or nil. KEY is uniquified +workspace root." (cdr (assoc key xmtn-automate--*sessions*))) -(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key) - &body body) - "Call BODY, after ensuring an automate session for ROOT-FORM is active." - (declare (indent 1) (debug (sexp body))) - ;; I would prefer to factor out a function - ;; `xmtn-automate--call-with-session' here, but that would make - ;; profiler output unreadable, since every function would only - ;; appear to call `xmtn-automate--call-with-session', and that - ;; function would appear to do all computation. - ;; - ;; mtn automate stdio requires a valid database, so we require a - ;; root directory here. - (let ((session (gensym)) - (session-var (or session-var-or-null (gensym))) - (root (gensym)) - (key (gensym)) - (thunk (gensym))) - `(let* ((,root (file-name-as-directory ,root-form)) - (,key (file-truename ,root)) - (,session (xmtn-automate-get-cached-session ,key)) - (,thunk (lambda () - (let ((,session-var ,session)) - ,@body)))) - (if ,session - (funcall ,thunk) - (unwind-protect - (progn - (setq ,session (xmtn-automate--make-session ,root ,key)) - (let ((xmtn-automate--*sessions* - ;; note the let-binding here; these sessions are _not_ - ;; available for later commands. use - ;; xmtn-automate-cache-session to get a persistent - ;; session. - (acons ,key ,session xmtn-automate--*sessions*))) - (funcall ,thunk))) - (when ,session (xmtn-automate--close-session ,session))))))) - -(defmacro* xmtn-automate-with-command ((handle-var session-form command-form - &key ((:may-kill-p - may-kill-p-form))) - &body body) - "Send COMMAND_FORM (a list of strings, or cons of lists of -strings) to session SESSION_FORM (current if nil). If car -COMMAND_FORM is a list, car COMMAND_FORM is options, cdr is command. -Then execute BODY." - (declare (indent 1) (debug (sexp body))) - (let ((session (gensym)) - (command (gensym)) - (may-kill-p (gensym)) - (handle (gensym))) - `(let ((,session ,session-form) - (,command ,command-form) - (,may-kill-p ,may-kill-p-form) - (,handle nil)) - (unwind-protect - (progn - (setq ,handle (xmtn-automate--new-command ,session - ,command - ,may-kill-p)) - (xmtn--assert-optional (xmtn-automate--command-handle-p ,handle)) - (let ((,handle-var ,handle)) - ,@body)) - (when ,handle - (xmtn-automate--cleanup-command ,handle)))))) - (defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle) (xmtn-automate-command-wait-until-finished handle) (with-current-buffer (xmtn-automate-command-buffer handle) - (buffer-substring-no-properties (point-min) (point-max)))) + (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (xmtn-automate--cleanup-command handle)))) (defun xmtn-automate-command-check-for-and-report-error (handle) (unless (eql (xmtn-automate-command-error-code handle) 0) @@ -351,30 +163,27 @@ Then execute BODY." nil) (defun xmtn-automate-simple-command-output-string (root command) - "Send COMMAND (a list of strings, or cons of lists of strings) -to current session. If car COMMAND is a list, car COMMAND is -options, cdr is command. Return result as a string." - (xmtn-automate-with-session (session root) - (xmtn-automate-with-command (handle session command) - (xmtn-automate-command-check-for-and-report-error handle) - (xmtn-automate--command-output-as-string-ignoring-exit-code handle)))) + "Send COMMAND to session for ROOT. Return result as a string." + (let* ((session (xmtn-automate-cache-session root)) + (command-handle (xmtn-automate--new-command session command nil))) + (xmtn-automate-command-check-for-and-report-error command-handle) + (xmtn-automate--command-output-as-string-ignoring-exit-code command-handle))) (defun xmtn-automate-simple-command-output-insert-into-buffer (root buffer command) - "Send COMMAND (a list of strings, or cons of lists of strings) -to current session. If car COMMAND is a list, car COMMAND is -options, cdr is command. Insert result into BUFFER." - (xmtn-automate-with-session (session root) - (xmtn-automate-with-command (handle session command) - (xmtn-automate-command-check-for-and-report-error handle) - (xmtn-automate-command-wait-until-finished handle) - (with-current-buffer buffer - (xmtn--insert-buffer-substring-no-properties - (xmtn-automate-command-buffer handle)))))) + "Send COMMAND to session for ROOT, insert result into BUFFER." + (let* ((session (xmtn-automate-cache-session root)) + (command-handle (xmtn-automate--new-command session command nil))) + (xmtn-automate-command-check-for-and-report-error command-handle) + (xmtn-automate-command-wait-until-finished command-handle) + (with-current-buffer buffer + (insert-buffer-substring-no-properties + (xmtn-automate-command-buffer command-handle))) + (xmtn-automate--cleanup-command command-handle))) (defun xmtn-automate-command-output-lines (handle) - ;; Return list of lines of output; first line output is first in - ;; list. + "Return list of lines of output in HANDLE; first line output is +first in list." (xmtn-automate-command-check-for-and-report-error handle) (xmtn-automate-command-wait-until-finished handle) (save-excursion @@ -387,16 +196,16 @@ options, cdr is command. Insert result into BUFFER." (progn (end-of-line) (point))) result)) (forward-line 1)) + (xmtn-automate--cleanup-command handle) (nreverse result)))) (defun xmtn-automate-simple-command-output-lines (root command) - "Return list of strings containing output of COMMAND, one line per string." - (xmtn-automate-with-session (session root) - (xmtn-automate-with-command (handle session command) - (xmtn-automate-command-output-lines handle)))) + "Return list of strings containing output of COMMAND, one line per +string." + (let* ((session (xmtn-automate-cache-session root)) + (command-handle (xmtn-automate--new-command session command nil))) + (xmtn-automate-command-output-lines command-handle))) -;; This one is used twice. I think the error checking it provides is -;; a reasonable simplification for its callers. (defun xmtn-automate-simple-command-output-line (root command) "Return the one line output from mtn automate as a string. @@ -409,19 +218,11 @@ Signals an error if output contains zero lines or more than one line." command)) (first lines))) - (defun xmtn-automate--set-process-session (process session) - (xmtn--assert-optional (typep session 'xmtn-automate--session) t) - (xmtn--process-put process 'xmtn-automate--session session)) + (process-put process 'xmtn-automate--session session)) (defun xmtn-automate--process-session (process) - (xmtn--assert-optional (processp process) t) - (let ((session (xmtn--process-get process 'xmtn-automate--session))) - ;; This seems to fail sometimes with session being nil. Not sure - ;; why. The problem seems to be reproducible by calling - ;; (dvc-dvc-revision-nth-ancestor `(xmtn (local-tree ,(dvc-tree-root))) 10). - (xmtn--assert-optional (typep session 'xmtn-automate--session) t) - session)) + (process-get process 'xmtn-automate--session)) (defstruct (xmtn-automate--decoder-state (:constructor xmtn-automate--%make-raw-decoder-state)) @@ -437,8 +238,7 @@ Signals an error if output contains zero lines or more than one line." (buffer nil) (process nil) (decoder-state) - (next-mtn-command-number) - (next-session-command-number 0) + (next-command-number 0) (must-not-kill-counter) (remaining-command-handles) (sent-kill-p) @@ -492,6 +292,7 @@ Signals an error if output contains zero lines or more than one line." nil) (defun xmtn-automate--close-session (session) + "Kill session process, buffer." (setf (xmtn-automate--session-closed-p session) t) (let ((process (xmtn-automate--session-process session))) (cond @@ -537,9 +338,8 @@ Signals an error if output contains zero lines or more than one line." (let ((process-connection-type nil) (default-directory root)) (let ((process - (xmtn--with-environment-for-subprocess () - (apply #'start-process name buffer xmtn-executable - "automate" "stdio" xmtn-additional-arguments)))) + (apply 'start-process name buffer xmtn-executable + "automate" "stdio" xmtn-additional-arguments))) (xmtn-automate--set-process-session process session) (set-process-filter process 'xmtn-automate--process-filter) (set-process-sentinel process 'xmtn-automate--process-sentinel) @@ -555,13 +355,13 @@ Signals an error if output contains zero lines or more than one line." (xmtn--assert-optional (eql (point-min) (point)) t) (set-marker (make-marker) (point-min))))) - (setf (xmtn-automate--session-next-mtn-command-number session) 0) (setf (xmtn-automate--session-must-not-kill-counter session) 0) (setf (xmtn-automate--session-remaining-command-handles session) (list)) (setf (xmtn-automate--session-sent-kill-p session) nil) process)))) (defun xmtn-automate--ensure-process (session) + "Ensure SESSION has an active process; restart it if it died." (let ((process (xmtn-automate--session-process session))) (when (or (null process) (ecase (process-status process) @@ -575,33 +375,16 @@ Signals an error if output contains zero lines or more than one line." process)) (defun xmtn-automate--new-buffer (session) - (let* ((buffer-base-name (format "*%s: session*" + (let* ((buffer-base-name (format " *%s: session*" (xmtn-automate--session-name session))) (buffer (generate-new-buffer buffer-base-name))) (with-current-buffer buffer (buffer-disable-undo) - (xmtn--set-buffer-multibyte nil) + (set-buffer-multibyte nil) (setq buffer-read-only t)) (setf (xmtn-automate--session-buffer session) buffer) buffer)) -(defun xmtn-automate-terminate-processes-in-root (root) - (xmtn-automate-with-session (session root) - (xmtn-automate--close-session session) - (let ((process (xmtn-automate--session-process session))) - (when process - (while (ecase (process-status process) - (run t) - (exit nil) - (signal nil)) - (accept-process-output process)) - (dvc-trace "Process in root %s terminated" root) - )) - (xmtn-automate--initialize-session - session - :root (xmtn-automate--session-root session) - :name (xmtn-automate--session-name session)))) - (defun xmtn-automate--append-encoded-strings (strings) "Encode STRINGS (a list of strings or nil) in automate stdio format, insert into current buffer. Assumes that point is at the end of @@ -616,12 +399,10 @@ the buffer." (goto-char (point-max))))) nil) -(defun xmtn-automate--send-command-string (session command option-plist - mtn-number session-number) +(defun xmtn-automate--send-command-string (session command option-plist session-number) "Send COMMAND and OPTION-PLIST to SESSION." - (let* ((buffer-name (format "*%s: input for command %s(%s)*" + (let* ((buffer-name (format "*%s: input for command %s*" (xmtn-automate--session-name session) - mtn-number session-number)) (buffer nil)) (unwind-protect @@ -635,7 +416,7 @@ the buffer." (setq buffer (get-buffer-create buffer-name)) (with-current-buffer buffer (buffer-disable-undo) - (xmtn--set-buffer-multibyte t) + (set-buffer-multibyte t) (setq buffer-read-only t) (let ((inhibit-read-only t)) (when option-plist @@ -655,22 +436,14 @@ the buffer." (kill-buffer buffer)))))) (defun xmtn-automate--new-command (session command may-kill-p) - "Send COMMAND (a list of strings, or cons of lists of strings) -to the current automate stdio session. If car COMMAND is a list, -car COMMAND is options, cdr is command." - ;; For debugging. - ;;(xmtn-automate-terminate-processes-in-root - ;; (xmtn-automate--session-root session)) + "Send COMMAND to SESSION." (xmtn-automate--ensure-process session) - (let* ((mtn-number (1- (incf (xmtn-automate--session-next-mtn-command-number - session)))) - (session-number - (1- (incf (xmtn-automate--session-next-session-command-number + (let* ((command-number + (1- (incf (xmtn-automate--session-next-command-number session)))) - (buffer-name (format "*%s: output for command %s(%s)*" + (buffer-name (format " *%s: output for command %s*" (xmtn-automate--session-name session) - mtn-number - session-number)) + command-number)) (buffer (progn (when (get-buffer buffer-name) ;; Make sure no local variables or mode changes @@ -681,21 +454,18 @@ car COMMAND is options, cdr is command." (fundamental-mode))) (get-buffer-create buffer-name)))) (if (not (listp (car command))) - (xmtn-automate--send-command-string session command '() - mtn-number session-number) - (xmtn-automate--send-command-string session (cdr command) (car command) - mtn-number session-number)) + (xmtn-automate--send-command-string session command '() command-number) + (xmtn-automate--send-command-string session (cdr command) (car command) command-number)) (with-current-buffer buffer (buffer-disable-undo) - (xmtn--set-buffer-multibyte nil) + (set-buffer-multibyte nil) (setq buffer-read-only t) (xmtn--assert-optional (and (eql (point) (point-min)) (eql (point) (point-max)))) (let ((handle (xmtn-automate--%make-raw-command-handle :session session :arguments command - :mtn-command-number mtn-number - :session-command-number session-number + :session-command-number command-number :may-kill-p may-kill-p :buffer buffer :write-marker (set-marker (make-marker) (point))))) @@ -742,9 +512,9 @@ car COMMAND is options, cdr is command." (goto-char write-marker) (let ((inhibit-read-only t) deactivate-mark) - (xmtn--insert-buffer-substring-no-properties session-buffer - read-marker - end)) + (insert-buffer-substring-no-properties session-buffer + read-marker + end)) (set-marker write-marker (point)))) ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil) ) @@ -802,8 +572,9 @@ car COMMAND is options, cdr is command." (xmtn-automate--decoder-state-last-p state)) (xmtn--assert-optional command) (setf (xmtn-automate--command-handle-finished-p command) t) - (xmtn--with-no-warnings - (pop (xmtn-automate--session-remaining-command-handles session))) + (with-no-warnings + ;; discard result + (pop (xmtn-automate--session-remaining-command-handles session))) (setq tag 'check-for-more) (when (not (xmtn-automate--command-handle-may-kill-p command)) (when (zerop (decf (xmtn-automate--session-must-not-kill-counter @@ -919,7 +690,7 @@ car COMMAND is options, cdr is command." (message "Process %s died due to signal" (process-name process)) (when (not (zerop (xmtn-automate--session-must-not-kill-counter session))) - (xmtn--lwarn + (lwarn 'xmtn ':error "Process %s died due to signal during a critical operation" (process-name process)))))))))) @@ -1007,6 +778,18 @@ Each element of the list is a list; key, signature, name, value, trust." (defun xmtn--tree-default-branch (root) (xmtn-automate-simple-command-output-line root `("get_option" "branch"))) +(defun xmtn-automate-local-changes (work) + "Summary of status for WORK; 'ok if no changes, 'need-commit if changes." + (message "checking %s for local changes" work) + (let ((default-directory work)) + + (let ((result (xmtn-automate-simple-command-output-string + default-directory + (list (list "no-unchanged" "no-ignored") + "inventory")))) + (if (> (length result) 0) + 'need-commit + 'ok)))) (provide 'xmtn-automate) diff --git a/dvc/lisp/xmtn-compat.el b/dvc/lisp/xmtn-compat.el index 3739160..c528f15 100644 --- a/dvc/lisp/xmtn-compat.el +++ b/dvc/lisp/xmtn-compat.el @@ -1,6 +1,6 @@ ;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions -;; Copyright (C) 2008 Stephen Leake +;; Copyright (C) 2008, 2009 Stephen Leake ;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Author: Christian M. Ohler @@ -34,36 +34,6 @@ (eval-and-compile (require 'cl)) -(defun xmtn--temp-directory () - (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory)) - -(defun xmtn--make-temp-file (prefix &optional dirp suffix) - ;; Do this in a temp buffer to ensure we use the default file output - ;; encoding. Emacs 21's `make-temp-file' uses the current buffer's - ;; output format function while writing the file with `write-region' - ;; with a string as its first argument, but coding conversion errors - ;; when `write-region' is called in this way. - (with-temp-buffer - ;; XEmacs' `make-temp-file' doesn't automatically use temp - ;; directory. - (setq prefix (expand-file-name prefix (xmtn--temp-directory))) - ;; FIXME: Ignoring suffix for now since Emacs 21 doesn't support it. - (make-temp-file prefix dirp))) - -(defvar xmtn--*process-plists* (make-hash-table :weakness 'key)) - -;;; These should probably use `process-get' and `process-put' if -;;; available, but that's not important. -(defun xmtn--process-put (process propname value) - (setf (getf (gethash process xmtn--*process-plists*) propname) value) - ;; Mimic the return value that `process-put' would yield. - (gethash process xmtn--*process-plists*)) - -(defsubst xmtn--process-get (process propname) - (getf (gethash process xmtn--*process-plists*) propname nil)) - (defmacro xmtn--set-process-query-on-exit-flag (process value) (if (fboundp 'set-process-query-on-exit-flag) ;; emacs 22.2 and greater @@ -73,54 +43,6 @@ (process-kill-without-query ,process ,value) ,value))) -(defmacro xmtn--insert-buffer-substring-no-properties (from-buffer - &optional start end) - (if (fboundp 'insert-buffer-substring-no-properties) - `(insert-buffer-substring-no-properties ,from-buffer ,start ,end) - `(progn - (insert (with-current-buffer ,from-buffer - (buffer-substring-no-properties (or ,start (point-min)) - (or ,end (point-max))))) - nil))) - -(defun xmtn--lwarn (tag level message &rest args) - (if (fboundp 'lwarn) - (apply #'lwarn tag level message args) - (apply #'message message args)) - ;; The return value of `lwarn' seems to be pretty much undefined, so - ;; we don't try to replicate it here. - nil) - -(defmacro* xmtn--with-no-warnings (&body body) - (if (fboundp 'with-no-warnings) - `(with-no-warnings ,@body) - `(progn ,@body))) - -(defmacro* xmtn--with-temp-message (message &body body) - (declare (indent 1) (debug (form body))) - (if (fboundp 'with-temp-message) - `(with-temp-message ,message ,@body) - `(progn ,@body))) - -(defmacro* xmtn--dotimes-with-progress-reporter ((i n-form &optional res-form) - message-form - &body body) - (declare (indent 2) (debug (sexp form body))) - (if (fboundp 'dotimes-with-progress-reporter) - `(dotimes-with-progress-reporter (,i ,n-form ,res-form) - ,message-form ,@body) - (let ((message (gensym))) - `(let ((,message ,message-form)) - (prog1 - (xmtn--with-temp-message ,message - (dotimes (,i ,n-form ,res-form) - ,@body)) - (message "%sdone" ,message)))))) - -(defmacro xmtn--set-buffer-multibyte (flag) - (when (fboundp 'set-buffer-multibyte) - `(set-buffer-multibyte ,flag))) - (provide 'xmtn-compat) ;;; xmtn-compat.el ends here diff --git a/dvc/lisp/xmtn-conflicts.el b/dvc/lisp/xmtn-conflicts.el index e681bf7..cfae437 100644 --- a/dvc/lisp/xmtn-conflicts.el +++ b/dvc/lisp/xmtn-conflicts.el @@ -1079,12 +1079,16 @@ non-nil, show log-edit buffer in other frame." "Perform propagate on revisions in current conflict buffer." (interactive) (save-some-buffers t); log buffer + ;; save-some-buffers does not save the conflicts buffer, which is the current buffer + (save-buffer) (xmtn-propagate-from xmtn-conflicts-left-branch cached-branch)) (defun xmtn-conflicts-do-merge () "Perform merge on revisions in current conflict buffer." (interactive) (save-some-buffers t); log buffer + ;; save-some-buffers does not save the conflicts buffer, which is the current buffer + (save-buffer) (xmtn-dvc-merge-1 default-directory nil)) (defun xmtn-conflicts-ediff-resolution-ws () diff --git a/dvc/lisp/xmtn-dvc.el b/dvc/lisp/xmtn-dvc.el index ef4c191..6474076 100644 --- a/dvc/lisp/xmtn-dvc.el +++ b/dvc/lisp/xmtn-dvc.el @@ -83,16 +83,14 @@ `(let ((,root ,root-form) (,command ,command-form) (,may-kill-p ,may-kill-p-form)) - (xmtn-automate-with-session (,session ,root) - (xmtn-automate-with-command (,handle - ,session ,command - :may-kill-p ,may-kill-p) - (xmtn-automate-command-check-for-and-report-error ,handle) - (xmtn-automate-command-wait-until-finished ,handle) - (xmtn-basic-io-with-stanza-parser (,parser - (xmtn-automate-command-buffer - ,handle)) - ,@body)))))) + (let* ((,session (xmtn-automate-cache-session ,root)) + (,handle (xmtn-automate--new-command ,session ,command ,may-kill-p))) + (xmtn-automate-command-check-for-and-report-error ,handle) + (xmtn-automate-command-wait-until-finished ,handle) + (xmtn-basic-io-with-stanza-parser (,parser + (xmtn-automate-command-buffer + ,handle)) + ,@body))))) ;;;###autoload (defun xmtn-dvc-log-edit-file-name-func (&optional root) @@ -104,154 +102,6 @@ `("toposort" ,@revision-hash-ids))) -(defun xmtn--insert-log-edit-hints (root branch buffer prefix normalized-files) - (with-current-buffer buffer - (flet ((insert-line (&optional format-string-or-null &rest format-args) - (if format-string-or-null - (let ((line (apply #'format - format-string-or-null format-args))) - (assert (not (position ?\n line))) - (insert prefix line ?\n)) - (assert (endp format-args)) - (insert prefix ?\n)))) - (save-excursion - ;; Launching these mtn processes in parallel is a noticeable - ;; speedup (~14% on some informal benchmarks). At least it - ;; was with the version that I benchmarked, etc. - (xmtn-automate-with-session (nil root) - (let* ((unknown-future (xmtn--unknown-files-future root)) - (missing-future (xmtn--missing-files-future root)) - (consistent-p-future (xmtn--tree-consistent-p-future root)) - (heads (xmtn--heads root branch)) - (inconsistent-p (not (funcall consistent-p-future))) - (revision (if inconsistent-p - nil - (xmtn--get-revision root `(local-tree ,root)))) - (missing (funcall missing-future))) - (when inconsistent-p - (insert-line - "WARNING: Tree is not consistent.") - (insert-line "Commit will fail unless you fix this first.") - (insert-line)) - (when missing - (insert-line "%s missing file(s):" (length missing)) - (dolist (file missing) (insert-line "%s" file)) - (insert-line) - (insert-line)) - (insert-line "Committing on branch:") - (insert-line branch) - (insert-line) - (unless - (let* ((parents (xmtn--revision-old-revision-hash-ids revision)) - (all-parents-are-heads-p - (subsetp parents heads :test #'equal)) - (all-heads-are-parents-p - (subsetp heads parents :test #'equal))) - (cond ((and (not all-heads-are-parents-p) - (not all-parents-are-heads-p)) - (insert-line "This commit will create divergence.") - (insert-line)) - ((not all-heads-are-parents-p) - (insert-line (concat "Divergence will continue to exist" - " after this commit.")) - (insert-line)) - (t - (progn))))) - (case normalized-files - (all - (insert-line "All files selected for commit.")) - (t - (insert-line "File(s) selected for commit:") - ;; Normalized file names are easier to read when coming - ;; from dired buffer, since otherwise, they would contain - ;; the entire path. - (dolist (file - ;; Sort in an attempt to match the order of - ;; "patch" lines, below. - (sort (copy-list normalized-files) #'string<)) - (insert-line "%s" file)))) - ;; Due to the possibility of race conditions, this check - ;; doesn't guarantee the operation will succeed. - (if inconsistent-p - ;; FIXME: Since automate get_revision can't deal with - ;; inconsistent workspaces, we should be using - ;; automate inventory instead. - (progn (insert-line) - (insert-line - (concat "Unable to compute modified files while" - " the tree is inconsistent."))) - (let ((committed-changes (list)) - (other-changes (list))) - (flet ((collect (path message) - (if (or (eql normalized-files 'all) - (member path normalized-files)) - (push message committed-changes) - (push message other-changes)))) - (loop - for (path) in (xmtn--revision-delete revision) - do (collect path (format "delete %s" path))) - (loop - for (from to) in (xmtn--revision-rename revision) - ;; FIXME: collect from or collect to? Monotone - ;; doesn't specify how restrictions work for - ;; renamings. - do (collect to (format "rename %s to %s" from to))) - (loop - for (path) in (xmtn--revision-add-dir revision) - do (collect path (format "add_dir %s" path))) - (loop - for (path contents) - in (xmtn--revision-add-file revision) - do (collect path (format "add_file %s" path))) - (loop - for (path from-contents to-contents) - in (xmtn--revision-patch-file revision) - do (collect path (format "patch %s" path))) - (loop - for (path attr-name) - in (xmtn--revision-clear-attr revision) - do (collect path (format "clear %s %s" - path attr-name))) - (loop - for (path attr-name attr-value) - in (xmtn--revision-set-attr revision) - do (collect path (format "set %s %s %s" - path attr-name attr-value)))) - (setq committed-changes (nreverse committed-changes)) - (setq other-changes (nreverse other-changes)) - (loop - for (lines heading-if heading-if-not) in - `((,committed-changes - ,(format "%s change(s) in selected files:" - (length committed-changes)) - "No changes in selected files.") - (,other-changes - ,(format - "%s change(s) in files not selected for commit:" - (length other-changes)) - "No changes in files not selected for commit.")) - do - (insert-line) - (insert-line "%s" (if lines heading-if heading-if-not)) - (dolist (line lines) (insert-line "%s" line))))) - (let ((unknown (funcall unknown-future))) - (insert-line) - (if (endp unknown) - (insert-line "No unknown files.") - (insert-line "%s unknown file(s):" (length unknown)) - (dolist (file unknown) (insert-line "%s" file)))))))) - (cond ((eql (point) (point-min)) - ;; We take this as an indicator that there is no log message - ;; yet. So insert a blank line. - (insert "\n") - (goto-char (point-min))) - (t - ;; Moving up onto the last line of the log message seems to - ;; be better than having the cursor sit at the ## prefix of - ;; the first line of our hints. - (forward-line -1)))) - nil) - (add-to-list 'format-alist '(xmtn--log-file "This format automatically removes xmtn's log edit hints from @@ -670,18 +520,6 @@ otherwise newer." (setq xmtn-dvc-automate-version (string-to-number (xmtn--command-output-line nil '("automate" "interface_version")))))) -(defun xmtn--unknown-files-future (root) - (xmtn--command-output-lines-future root '("ls" "unknown"))) - -(defun xmtn--missing-files-future (root) - (xmtn--command-output-lines-future root '("ls" "missing"))) - -(defun xmtn--tree-consistent-p-future (root) - ;; FIXME: Should also check for file/dir mismatches. - (lexical-let ((missing-files-future (xmtn--missing-files-future root))) - (lambda () - (null (funcall missing-files-future))))) - (defun xmtn--changes-image (change) (ecase change (content "content") @@ -1073,20 +911,6 @@ otherwise newer." (xmtn--run-command-sync root `("add" "--" ,@file-names))) -(defun xmtn--file-registered-p (root file-name) - ;; FIXME: need a better way to implement this - (let ((normalized-file-name (xmtn--normalize-file-name root file-name))) - (block parse - (xmtn--with-automate-command-output-basic-io-parser - (parser root `("inventory")) - (xmtn--parse-inventory parser - (lambda (path status changes old-path new-path - old-type new-type fs-type) - (when (equal normalized-file-name path) - (return-from parse - t))))) - nil))) - ;;;###autoload (defun xmtn-dvc-add-files (&rest files) (xmtn--add-files (dvc-tree-root) files)) @@ -1214,13 +1038,6 @@ finished." nil) nil) -(defun xmtn--do-disapprove-future (root revision-hash-id) - ;; Returns a future so the calling code can block on its completion - ;; if it wants to. - (check-type root string) - (check-type revision-hash-id xmtn--hash-id) - (xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id))) - (defun xmtn--do-update (root target-revision-hash-id post-update-p) (check-type root string) (check-type target-revision-hash-id xmtn--hash-id) @@ -1264,23 +1081,22 @@ finished." ;;;###autoload (defun xmtn-dvc-update (&optional revision-id no-ding) (let ((root (dvc-tree-root))) - (xmtn-automate-with-session (nil root) - (if revision-id - (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding) + (if revision-id + (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding) - (let* ((branch (xmtn--tree-default-branch root)) - (heads (xmtn--heads root branch))) - (case (length heads) - (0 (assert nil)) - (1 - (xmtn--update root (first heads) t no-ding)) + (let* ((branch (xmtn--tree-default-branch root)) + (heads (xmtn--heads root branch))) + (case (length heads) + (0 (assert nil)) + (1 + (xmtn--update root (first heads) t no-ding)) - (t - ;; User can choose one head from a revlist, or merge them. - (error (substitute-command-keys - (concat "Branch %s is unmerged (%s heads)." - " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]")) - branch (length heads)))))))) + (t + ;; User can choose one head from a revlist, or merge them. + (error (substitute-command-keys + (concat "Branch %s is unmerged (%s heads)." + " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]")) + branch (length heads))))))) nil) (defun xmtn-propagate-from (other &optional cached-branch) @@ -1325,18 +1141,16 @@ finished." (defun xmtn-dvc-merge-1 (root refresh-status) (lexical-let ((refresh-status refresh-status)) - (xmtn-automate-with-session - (nil root) - (xmtn--run-command-async - root - (list - "merge" - (if (file-exists-p (concat root "/_MTN/conflicts")) - "--resolve-conflicts-file=_MTN/conflicts") - (xmtn-dvc-log-message)) - :finished (lambda (output error status arguments) - (if refresh-status - (xmtn--refresh-status-header (current-buffer)))))))) + (xmtn--run-command-async + root + (list + "merge" + (if (file-exists-p (concat root "/_MTN/conflicts")) + "--resolve-conflicts-file=_MTN/conflicts") + (xmtn-dvc-log-message)) + :finished (lambda (output error status arguments) + (if refresh-status + (xmtn--refresh-status-header (current-buffer))))))) ;;;###autoload (defun xmtn-dvc-merge (&optional other) @@ -1410,74 +1224,70 @@ finished." (defun xmtn--revision-get-file-helper (file backend-id) "Fill current buffer with the contents of FILE revision BACKEND-ID." (let ((root (dvc-tree-root))) - (xmtn-automate-with-session (nil root) - (let* ((normalized-file (xmtn--normalize-file-name root file)) - (corresponding-file - (xmtn--get-corresponding-path root normalized-file - `(local-tree ,root) backend-id))) - (if (null corresponding-file) - ;; File doesn't exist. Since this function is (as far - ;; as I know) only called from diff-like functions, a - ;; missing file is not an error but just means the diff - ;; should be computed against an empty file. So just - ;; leave the buffer empty. - (progn) - (let ((temp-dir nil)) - (unwind-protect - (progn - (setq temp-dir (xmtn--make-temp-file - "xmtn--revision-get-file-" t)) - ;; Going through a temporary file and using - ;; `insert-file-contents' in conjunction with as - ;; much of the original file name as possible seems - ;; to be the best way to make sure that Emacs' - ;; entire file coding system detection logic is - ;; applied. Functions like - ;; `find-operation-coding-system' and - ;; `find-file-name-handler' are not a complete - ;; replacement since they don't look at the contents - ;; at all. - (let ((temp-file (concat temp-dir "/" corresponding-file))) - (make-directory (file-name-directory temp-file) t) - (with-temp-file temp-file - (xmtn--set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer))) - (let ((output-buffer (current-buffer))) - (with-temp-buffer - (insert-file-contents temp-file) - (let ((input-buffer (current-buffer))) - (with-current-buffer output-buffer - (insert-buffer-substring input-buffer))))))) - (when temp-dir - (dvc-delete-recursively temp-dir))))))))) + (let* ((normalized-file (xmtn--normalize-file-name root file)) + (corresponding-file + (xmtn--get-corresponding-path root normalized-file + `(local-tree ,root) backend-id))) + (if (null corresponding-file) + ;; File doesn't exist. Since this function is (as far + ;; as I know) only called from diff-like functions, a + ;; missing file is not an error but just means the diff + ;; should be computed against an empty file. So just + ;; leave the buffer empty. + (progn) + (let ((temp-dir nil)) + (unwind-protect + (progn + (setq temp-dir (make-temp-file + "xmtn--revision-get-file-" t)) + ;; Going through a temporary file and using + ;; `insert-file-contents' in conjunction with as + ;; much of the original file name as possible seems + ;; to be the best way to make sure that Emacs' + ;; entire file coding system detection logic is + ;; applied. Functions like + ;; `find-operation-coding-system' and + ;; `find-file-name-handler' are not a complete + ;; replacement since they don't look at the contents + ;; at all. + (let ((temp-file (concat temp-dir "/" corresponding-file))) + (make-directory (file-name-directory temp-file) t) + (with-temp-file temp-file + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer))) + (let ((output-buffer (current-buffer))) + (with-temp-buffer + (insert-file-contents temp-file) + (let ((input-buffer (current-buffer))) + (with-current-buffer output-buffer + (insert-buffer-substring input-buffer))))))) + (when temp-dir + (dvc-delete-recursively temp-dir)))))))) (defun xmtn--get-file-by-id (root file-id save-as) "Store contents of FILE-ID in file SAVE-AS." - (xmtn-automate-with-session - (nil root) - (with-temp-file save-as - (xmtn--set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (xmtn--insert-file-contents root file-id (current-buffer))))) + (with-temp-file save-as + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (xmtn--insert-file-contents root file-id (current-buffer)))) (defun xmtn--revision-parents (root revision-hash-id) (xmtn-automate-simple-command-output-lines root `("parents" ,revision-hash-id))) (defun xmtn--get-content-changed (root backend-id normalized-file) - (xmtn-automate-with-session (nil root) - (xmtn-match (xmtn--resolve-backend-id root backend-id) - ((local-tree $path) (error "Not implemented")) - ((revision $revision-hash-id) - (xmtn--with-automate-command-output-basic-io-parser - (parser root `("get_content_changed" ,revision-hash-id - ,normalized-file)) - (loop for stanza = (funcall parser) - while stanza - collect (xmtn-match stanza - ((("content_mark" (id $previous-id))) - previous-id)))))))) + (xmtn-match (xmtn--resolve-backend-id root backend-id) + ((local-tree $path) (error "Not implemented")) + ((revision $revision-hash-id) + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("get_content_changed" ,revision-hash-id + ,normalized-file)) + (loop for stanza = (funcall parser) + while stanza + collect (xmtn-match stanza + ((("content_mark" (id $previous-id))) + previous-id))))))) (defun xmtn--limit-length (list n) (or (null n) (<= (length list) n))) @@ -1499,39 +1309,37 @@ finished." current-set)) (defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n) - (xmtn-automate-with-session (nil root) - (lexical-let ((root root)) - (labels ((changed-self-or-ancestors (entry) - (destructuring-bind (hash-id file-name) entry - (check-type file-name string) - ;; get-content-changed can return one or two revisions - (loop for next-change-id in (xmtn--get-content-changed - root `(revision ,hash-id) - file-name) - for corresponding-path = - (xmtn--get-corresponding-path-raw root file-name - hash-id next-change-id) - when corresponding-path - collect `(,next-change-id ,corresponding-path)))) - (changed-proper-ancestors (entry) - (destructuring-bind (hash-id file-name) entry - (check-type file-name string) - ;; revision-parents can return one or two revisions - (loop for parent-id in (xmtn--revision-parents root hash-id) - for path-in-parent = - (xmtn--get-corresponding-path-raw root file-name - hash-id parent-id) - when path-in-parent - append (changed-self-or-ancestors - `(,parent-id ,path-in-parent)))))) - (xmtn--close-set - #'changed-proper-ancestors - (xmtn-match (xmtn--resolve-backend-id root backend-id) - ((local-tree $path) (error "Not implemented")) - ((revision $id) (changed-self-or-ancestors - `(,id ,normalized-file)))) - last-n))))) - + (lexical-let ((root root)) + (labels ((changed-self-or-ancestors (entry) + (destructuring-bind (hash-id file-name) entry + (check-type file-name string) + ;; get-content-changed can return one or two revisions + (loop for next-change-id in (xmtn--get-content-changed + root `(revision ,hash-id) + file-name) + for corresponding-path = + (xmtn--get-corresponding-path-raw root file-name + hash-id next-change-id) + when corresponding-path + collect `(,next-change-id ,corresponding-path)))) + (changed-proper-ancestors (entry) + (destructuring-bind (hash-id file-name) entry + (check-type file-name string) + ;; revision-parents can return one or two revisions + (loop for parent-id in (xmtn--revision-parents root hash-id) + for path-in-parent = + (xmtn--get-corresponding-path-raw root file-name + hash-id parent-id) + when path-in-parent + append (changed-self-or-ancestors + `(,parent-id ,path-in-parent)))))) + (xmtn--close-set + #'changed-proper-ancestors + (xmtn-match (xmtn--resolve-backend-id root backend-id) + ((local-tree $path) (error "Not implemented")) + ((revision $id) (changed-self-or-ancestors + `(,id ,normalized-file)))) + last-n)))) (defun xmtn--get-corresponding-path-raw (root normalized-file-name source-revision-hash-id @@ -1553,53 +1361,52 @@ finished." source-revision-backend-id target-revision-backend-id) (block get-corresponding-path - (xmtn-automate-with-session (nil root) - (let (source-revision-hash-id - target-revision-hash-id - (file-name-postprocessor #'identity)) - (let ((resolved-source-revision - (xmtn--resolve-backend-id root source-revision-backend-id)) - (resolved-target-revision - (xmtn--resolve-backend-id root target-revision-backend-id))) - (xmtn-match resolved-source-revision - ((revision $hash-id) - (setq source-revision-hash-id hash-id)) - ((local-tree $path) - (assert (xmtn--same-tree-p root path)) - (let ((base-revision-hash-id - (xmtn--get-base-revision-hash-id-or-null path))) - (if (null base-revision-hash-id) - (xmtn-match resolved-target-revision - ((revision $hash-id) - (return-from get-corresponding-path nil)) - ((local-tree $target-path) - (assert (xmtn--same-tree-p path target-path)) - (return-from get-corresponding-path normalized-file-name))) - (setq normalized-file-name (xmtn--get-rename-in-workspace-to - path normalized-file-name)) - (setq source-revision-hash-id base-revision-hash-id))))) - (xmtn-match resolved-target-revision - ((revision $hash-id) - (setq target-revision-hash-id hash-id)) - ((local-tree $path) - (assert (xmtn--same-tree-p root path)) - (let ((base-revision-hash-id - (xmtn--get-base-revision-hash-id-or-null path))) - (if (null base-revision-hash-id) - (return-from get-corresponding-path nil) - (setq target-revision-hash-id base-revision-hash-id - file-name-postprocessor - (lexical-let ((path path)) - (lambda (file-name) - (xmtn--get-rename-in-workspace-from path - file-name))))))))) - (let ((result - (xmtn--get-corresponding-path-raw root normalized-file-name - source-revision-hash-id - target-revision-hash-id))) - (if (null result) - nil - (funcall file-name-postprocessor result))))))) + (let (source-revision-hash-id + target-revision-hash-id + (file-name-postprocessor #'identity)) + (let ((resolved-source-revision + (xmtn--resolve-backend-id root source-revision-backend-id)) + (resolved-target-revision + (xmtn--resolve-backend-id root target-revision-backend-id))) + (xmtn-match resolved-source-revision + ((revision $hash-id) + (setq source-revision-hash-id hash-id)) + ((local-tree $path) + (assert (xmtn--same-tree-p root path)) + (let ((base-revision-hash-id + (xmtn--get-base-revision-hash-id-or-null path))) + (if (null base-revision-hash-id) + (xmtn-match resolved-target-revision + ((revision $hash-id) + (return-from get-corresponding-path nil)) + ((local-tree $target-path) + (assert (xmtn--same-tree-p path target-path)) + (return-from get-corresponding-path normalized-file-name))) + (setq normalized-file-name (xmtn--get-rename-in-workspace-to + path normalized-file-name)) + (setq source-revision-hash-id base-revision-hash-id))))) + (xmtn-match resolved-target-revision + ((revision $hash-id) + (setq target-revision-hash-id hash-id)) + ((local-tree $path) + (assert (xmtn--same-tree-p root path)) + (let ((base-revision-hash-id + (xmtn--get-base-revision-hash-id-or-null path))) + (if (null base-revision-hash-id) + (return-from get-corresponding-path nil) + (setq target-revision-hash-id base-revision-hash-id + file-name-postprocessor + (lexical-let ((path path)) + (lambda (file-name) + (xmtn--get-rename-in-workspace-from path + file-name))))))))) + (let ((result + (xmtn--get-corresponding-path-raw root normalized-file-name + source-revision-hash-id + target-revision-hash-id))) + (if (null result) + nil + (funcall file-name-postprocessor result)))))) (defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name) ;; FIXME: need a better way to implement this @@ -1632,25 +1439,6 @@ finished." old-path))))) normalized-target-file-name)) -(defun xmtn--manifest-find-file (root manifest normalized-file-name) - (let ((matches (remove* normalized-file-name - (remove* 'file manifest :key #'first :test-not #'equal) - :key #'second :test-not #'equal))) - (xmtn--assert-optional (member (length matches) '(0 1))) - (first matches))) - -(defun xmtn--revision-manifest-file-entry (root backend-id - normalized-file-name) - (let ((manifest (xmtn--get-manifest root backend-id))) - (xmtn--manifest-find-file root manifest normalized-file-name))) - -(defun xmtn--revision-file-contents-hash (root backend-id normalized-file-name) - (xmtn-match (xmtn--revision-manifest-file-entry root backend-id - normalized-file-name) - ((file $relative-path $file-contents-hash $attrs) - (assert (equal relative-path normalized-file-name)) - file-contents-hash))) - (defun xmtn--file-contents-as-string (root content-hash-id) (check-type content-hash-id xmtn--hash-id) (xmtn-automate-simple-command-output-string @@ -1674,51 +1462,6 @@ finished." (defun xmtn--same-tree-p (a b) (equal (file-truename a) (file-truename b))) -(defun xmtn--get-manifest (root backend-id) - (xmtn-automate-with-session (nil root) - (let ((resolved-id (xmtn--resolve-backend-id root backend-id))) - (xmtn--with-automate-command-output-basic-io-parser - (parser root `("get_manifest_of" - ,@(xmtn-match resolved-id - ((local-tree $path) - ;; FIXME: I don't really know what to do if - ;; PATH is not the same as ROOT. Maybe - ;; revision id resolution needs to return - ;; the proper root, too. - (assert (xmtn--same-tree-p root path)) - (unless (funcall - (xmtn--tree-consistent-p-future root)) - (error "Tree is inconsistent, unable to get manifest")) - '()) - ((revision $hash-id) - `(,hash-id))))) - (assert (equal (funcall parser) '(("format_version" (string "1"))))) - (loop for stanza = (funcall parser) - while stanza - collect (xmtn-match stanza - ((("dir" (string $normalized-path))) - (let ((dir (decode-coding-string - normalized-path - 'xmtn--monotone-normal-form))) - (xmtn--assert-optional - (or (equal dir "") - (not (eql (aref dir (1- (length dir))) ?/)))) - `(dir ,dir))) - ((("file" (string $normalized-path)) - ("content" (id $hash-id)) - . $attrs) - `(file - ,(decode-coding-string - normalized-path 'xmtn--monotone-normal-form) - ,hash-id - ,(mapcar (lambda (attr-entry) - (xmtn-match attr-entry - (("attr" - (string $attr-name) - (string $attr-value)) - (list attr-name attr-value)))) - attrs))))))))) - (defstruct (xmtn--revision (:constructor xmtn--make-revision)) ;; matches data output by 'mtn diff' new-manifest-hash-id @@ -1732,35 +1475,6 @@ finished." set-attr ) - -(defun xmtn--get-revision (root backend-id) - (xmtn-automate-with-session (nil root) - (let ((resolved-id (xmtn--resolve-backend-id root backend-id))) - (xmtn--with-automate-command-output-basic-io-parser - (parser root `("get_revision" - ,@(xmtn-match resolved-id - ((local-tree $path) - ;; FIXME: I don't really know what to do if - ;; PATH is not the same as ROOT. Maybe - ;; revision id resolution needs to return - ;; the proper root, too. - (assert (xmtn--same-tree-p root path)) - (unless (funcall - (xmtn--tree-consistent-p-future root)) - (error (concat "Tree is inconsistent," - " unable to compute revision"))) - '()) - ((revision $hash-id) - `(,hash-id))))) - (assert (equal (funcall parser) '(("format_version" (string "1"))))) - (let ((new-manifest-hash-id (xmtn-match (funcall parser) - ((("new_manifest" (id $hash-id))) - hash-id)))) - (let ((proto-revision (xmtn--parse-partial-revision parser))) - (setf (xmtn--revision-new-manifest-hash-id proto-revision) - new-manifest-hash-id) - proto-revision)))))) - (defun xmtn--parse-partial-revision (parser) "Parse basic_io output from get_revision, starting with the old_revision stanzas." (let ((old-revision-hash-ids (list)) diff --git a/dvc/lisp/xmtn-ids.el b/dvc/lisp/xmtn-ids.el index 62966fa..30dbe5f 100644 --- a/dvc/lisp/xmtn-ids.el +++ b/dvc/lisp/xmtn-ids.el @@ -217,21 +217,22 @@ See file commentary for details." (defun xmtn--branches-of (hash-id) "Return list of branch names for HASH-ID. `default-directory' must be a workspace." - (let (result) - (xmtn-automate-with-session (session default-directory) - (xmtn-automate-with-command (handle session `("certs" ,hash-id)) - (xmtn-automate-command-wait-until-finished handle) - (with-current-buffer (xmtn-automate-command-buffer handle) - ;; now in buffer containing basic_io certs; find the branch certs - (goto-char (point-min)) - (while (not (xmtn-basic-io-eof)) - (xmtn-basic-io-optional-line "name" - (if (and (eq 'string (caar value)) - (string= "branch" (cadar value))) - (xmtn-basic-io-parse-line - (if (string= symbol "value") - (add-to-list 'result (cadar value))))) - ))))) + (let* (result + (session (xmtn-automate-cache-session default-directory)) + (handle (xmtn-automate--new-command session `("certs" ,hash-id) nil))) + (xmtn-automate-command-wait-until-finished handle) + (with-current-buffer (xmtn-automate-command-buffer handle) + ;; now in buffer containing basic_io certs; find the branch certs + (goto-char (point-min)) + (while (not (xmtn-basic-io-eof)) + (xmtn-basic-io-optional-line "name" + (if (and (eq 'string (caar value)) + (string= "branch" (cadar value))) + (xmtn-basic-io-parse-line + (if (string= symbol "value") + (add-to-list 'result (cadar value))))) + ))) + (xmtn-automate--cleanup-command handle) result)) (defun xmtn--get-base-revision-hash-id-or-null (root) diff --git a/dvc/lisp/xmtn-multi-status.el b/dvc/lisp/xmtn-multi-status.el new file mode 100644 index 0000000..dd7de5c --- /dev/null +++ b/dvc/lisp/xmtn-multi-status.el @@ -0,0 +1,450 @@ +;;; xmtn-status.el --- manage actions for multiple projects + +;; Copyright (C) 2009 Stephen Leake + +;; Author: Stephen Leake +;; Keywords: tools + +;; This file 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 2 of the License, or +;; (at your option) any later version. +;; +;; This file 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 this file; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, +;; Boston, MA 02110-1301 USA. + +(eval-and-compile + ;; these have macros we use + (require 'xmtn-ids)) + +(eval-when-compile + ;; these have functions we use + (require 'xmtn-base) + (require 'xmtn-conflicts)) + +(defvar xmtn-status-root "" + "Buffer-local variable holding root directory.") +(make-variable-buffer-local 'xmtn-status-root) +(put 'xmtn-status-root 'permanent-local t) + +(defvar xmtn-status-ewoc nil + "Buffer-local ewoc for displaying propagations. +All xmtn-status functions operate on this ewoc. +The elements must all be of class xmtn-status-data.") +(make-variable-buffer-local 'xmtn-status-ewoc) +(put 'xmtn-status-ewoc 'permanent-local t) + +(defstruct (xmtn-status-data (:copier nil)) + work ; directory name relative to xmtn-status-root + branch ; branch name (assumed never changes) + need-refresh ; nil | t : if an async process was started that invalidates state data + head-rev ; nil | mtn rev string : current head revision, nil if multiple heads + conflicts-buffer ; *xmtn-conflicts* buffer for merge + heads ; 'need-scan | 'at-head | 'need-update | 'need-merge) + (local-changes + 'need-scan) ; 'need-scan | 'need-commit | 'ok + (conflicts + 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none + ) + +(defun xmtn-status-work (data) + (concat xmtn-status-root (xmtn-status-data-work data))) + +(defun xmtn-status-need-refresh (elem data) + ;; The user has selected an action that will change the state of the + ;; workspace via mtn actions; set our data to reflect that. We + ;; assume the user will not be creating new files or editing + ;; existing ones. + (setf (xmtn-status-data-need-refresh data) t) + (setf (xmtn-status-data-heads data) 'need-scan) + (setf (xmtn-status-data-conflicts data) 'need-scan) + (ewoc-invalidate xmtn-status-ewoc elem)) + +(defun xmtn-status-printer (data) + "Print an ewoc element." + (insert (dvc-face-add (format "%s\n" (xmtn-status-data-work data)) 'dvc-keyword)) + + (if (xmtn-status-data-need-refresh data) + (insert (dvc-face-add " need refresh\n" 'dvc-conflict)) + + (ecase (xmtn-status-data-local-changes data) + (need-scan (insert " from local changes unknown\n")) + (need-commit (insert (dvc-face-add " need dvc-status\n" 'dvc-header))) + (ok nil)) + + (ecase (xmtn-status-data-conflicts data) + (need-scan + (insert "conflicts need scan\n")) + (need-resolve + (insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict))) + (need-review-resolve-internal + (insert (dvc-face-add " need review resolve internal\n" 'dvc-header))) + (resolved + (insert " conflicts resolved\n")) + ((resolved none) nil)) + + (ecase (xmtn-status-data-heads data) + (at-head nil) + (need-update (insert (dvc-face-add " need update\n" 'dvc-conflict))) + (need-merge + (insert (dvc-face-add " need merge\n" 'dvc-conflict))) + ))) + +(defun xmtn-status-kill-conflicts-buffer (data) + (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) + (let ((buffer (xmtn-status-data-conflicts-buffer data))) + (with-current-buffer buffer (save-buffer)) + (kill-buffer buffer)))) + +(defun xmtn-status-save-conflicts-buffer (data) + (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) + (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer)))) + +(defun xmtn-status-clean () + "Clean current workspace, delete from ewoc" + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem)) + (inhibit-read-only t)) + (xmtn-status-kill-conflicts-buffer data) + (xmtn-conflicts-clean (xmtn-status-work data)) + (ewoc-delete xmtn-status-ewoc elem))) + +(defun xmtn-status-cleanp () + "Non-nil if clean & quit is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + ;; don't check need-refresh here; allow deleting after just doing + ;; final required action in another buffer. + (and (member (xmtn-status-data-local-changes data) '(need-scan ok)) + (member (xmtn-status-data-heads data) '(need-scan at-head))))) + +(defun xmtn-status-do-refresh-one () + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (xmtn-status-refresh-one data current-prefix-arg) + (ewoc-invalidate xmtn-status-ewoc elem))) + +(defun xmtn-status-refreshp () + "Non-nil if refresh is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (or (xmtn-status-data-need-refresh data) + ;; everything's done, but the user just did mtn sync, and more + ;; stuff showed up + (eq 'ok (xmtn-status-data-local-changes data)) + (eq 'at-head (xmtn-status-data-heads data))))) + +(defun xmtn-status-update () + "Update current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (xmtn-status-need-refresh elem data) + (let ((default-directory (xmtn-status-work data))) + (xmtn-dvc-update)) + (xmtn-status-refresh-one data nil) + (ewoc-invalidate xmtn-status-ewoc elem))) + +(defun xmtn-status-updatep () + "Non-nil if update is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (and (not (xmtn-status-data-need-refresh data)) + (eq 'need-update (xmtn-status-data-heads data))))) + +(defun xmtn-status-resolve-conflicts () + "Resolve conflicts for current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (xmtn-status-need-refresh elem data) + (setf (xmtn-status-data-conflicts data) 'resolved) + (pop-to-buffer (xmtn-status-data-conflicts-buffer data)))) + +(defun xmtn-status-resolve-conflictsp () + "Non-nil if resolve conflicts is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (and (not (xmtn-status-data-need-refresh data)) + (member (xmtn-status-data-conflicts data) + '(need-resolve need-review-resolve-internal))))) + +(defun xmtn-status-status () + "Run xmtn-status on current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (xmtn-status-need-refresh elem data) + (setf (xmtn-status-data-local-changes data) 'ok) + (xmtn-status (xmtn-status-work data)))) + +(defun xmtn-status-status-ok () + "Ignore local changes in current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (setf (xmtn-status-data-local-changes data) 'ok) + + (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) + ;; creating the log-edit buffer requires a single status/diff/conflicts buffer + (kill-buffer (xmtn-status-data-conflicts-buffer data))) + + (ewoc-invalidate xmtn-status-ewoc elem))) + +(defun xmtn-status-statusp () + "Non-nil if xmtn-status is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (and (not (xmtn-status-data-need-refresh data)) + (member (xmtn-status-data-local-changes data) + '(need-scan need-commit))))) + +(defun xmtn-status-missing () + "Run xmtn-missing on current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem))) + (xmtn-status-need-refresh elem data) + (xmtn-missing nil (xmtn-status-work data)))) + +(defun xmtn-status-missingp () + "Non-nil if xmtn-missing is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (and (not (xmtn-status-data-need-refresh data)) + (eq 'need-update (xmtn-status-data-heads data))))) + +(defun xmtn-status-merge () + "Run dvc-merge on current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem)) + (default-directory (xmtn-status-work data))) + (xmtn-status-need-refresh elem data) + (xmtn-status-save-conflicts-buffer data) + (xmtn-dvc-merge-1 default-directory nil))) + +(defun xmtn-status-heads () + "Run xmtn-heads on current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-status-ewoc)) + (data (ewoc-data elem)) + (default-directory (xmtn-status-work data))) + (xmtn-status-need-refresh elem data) + (xmtn-view-heads-revlist))) + +(defun xmtn-status-headsp () + "Non-nil if xmtn-heads is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) + (and (not (xmtn-status-data-need-refresh data)) + (eq 'need-merge (xmtn-status-data-heads data))))) + +(defvar xmtn-status-actions-map + (let ((map (make-sparse-keymap "actions"))) + (define-key map [?c] '(menu-item "c) clean/delete" + xmtn-status-clean + :visible (xmtn-status-cleanp))) + (define-key map [?g] '(menu-item "g) refresh" + xmtn-status-do-refresh-one + :visible (xmtn-status-refreshp))) + (define-key map [?i] '(menu-item "i) ignore local changes" + xmtn-status-status-ok + :visible (xmtn-status-statusp))) + (define-key map [?5] '(menu-item "5) update" + xmtn-status-update + :visible (xmtn-status-updatep))) + (define-key map [?4] '(menu-item "4) xmtn-merge" + xmtn-status-merge + :visible (xmtn-status-headsp))) + (define-key map [?3] '(menu-item "3) xmtn-heads" + xmtn-status-heads + :visible (xmtn-status-headsp))) + (define-key map [?2] '(menu-item "2) resolve conflicts" + xmtn-status-resolve-conflicts + :visible (xmtn-status-resolve-conflictsp))) + (define-key map [?1] '(menu-item "1) dvc-missing" + xmtn-status-missing + :visible (xmtn-status-missingp))) + (define-key map [?0] '(menu-item "0) status" + xmtn-status-status + :visible (xmtn-status-statusp))) + map) + "Keyboard menu keymap used in multiple-status mode.") + +(dvc-make-ewoc-next xmtn-status-next xmtn-status-ewoc) +(dvc-make-ewoc-prev xmtn-status-prev xmtn-status-ewoc) + +(defvar xmtn-multiple-status-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\M-d" xmtn-status-actions-map) + (define-key map [?g] 'xmtn-status-refresh) + (define-key map [?n] 'xmtn-status-next) + (define-key map [?p] 'xmtn-status-prev) + (define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer)))) + map) + "Keymap used in `xmtn-multiple-status-mode'.") + +(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status" + "Major mode to show status of multiple workspaces." + (setq dvc-buffer-current-active-dvc 'xmtn) + (setq buffer-read-only nil) + + ;; don't do normal clean up stuff + (set (make-local-variable 'before-save-hook) nil) + (set (make-local-variable 'write-file-functions) nil) + + (dvc-install-buffer-menu) + (setq buffer-read-only t) + (buffer-disable-undo) + + (set-buffer-modified-p nil)) + +(defun xmtn-status-conflicts (data) + "Return value for xmtn-status-data-conflicts for DATA." + ;; Can't check for "current heads", since there could be more than + ;; 2, so just recreate conflicts + (let* ((work (xmtn-status-work data)) + (default-directory work)) + + (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) + (kill-buffer (xmtn-status-data-conflicts-buffer data))) + + ;; create conflicts file + (xmtn-conflicts-clean work) + (xmtn-conflicts-save-opts work work (xmtn-status-data-branch data) (xmtn-status-data-branch data)) + (dvc-run-dvc-sync + 'xmtn + (list "conflicts" "store") + :error (lambda (output error status arguments) + (pop-to-buffer error))) + + ;; create conflicts buffer + (setf (xmtn-status-data-conflicts-buffer data) + (save-excursion + (let ((dvc-switch-to-buffer-first nil)) + (xmtn-conflicts-review work) + (current-buffer)))) + + (with-current-buffer (xmtn-status-data-conflicts-buffer data) + (case xmtn-conflicts-total-count + (0 'none) + (t + (if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-internal-count) + 'need-review-resolve-internal + 'need-resolve)))))) + +(defun xmtn-status-refresh-one (data refresh-local-changes) + "Refresh DATA." + (let ((work (xmtn-status-work data))) + + (message "checking heads for %s " work) + + (let ((heads (xmtn--heads work (xmtn-status-data-branch data))) + (base-rev (xmtn--get-base-revision-hash-id-or-null work))) + (case (length heads) + (1 + (setf (xmtn-status-data-head-rev data) (nth 0 heads)) + (setf (xmtn-status-data-conflicts data) 'none) + (if (string= (xmtn-status-data-head-rev data) base-rev) + (setf (xmtn-status-data-heads data) 'at-head) + (setf (xmtn-status-data-heads data) 'need-update))) + (t + (setf (xmtn-status-data-head-rev data) nil) + (setf (xmtn-status-data-heads data) 'need-merge) + (case (xmtn-status-data-conflicts data) + (resolved + ;; Assume the resolution was just completed, so don't erase it! + nil) + (t + (setf (xmtn-status-data-conflicts data) 'need-scan)))))) + + (message "") + + (if refresh-local-changes + (setf (xmtn-status-data-local-changes data) 'need-scan)) + + (case (xmtn-status-data-local-changes data) + (need-scan + (setf (xmtn-status-data-local-changes data) (xmtn-automate-local-changes work))) + (t nil)) + + (case (xmtn-status-data-conflicts data) + (need-scan + (setf (xmtn-status-data-conflicts data) + (xmtn-status-conflicts data))) + (t nil)) + + (setf (xmtn-status-data-need-refresh data) nil)) + + ;; return non-nil to refresh display as we go along + t) + +(defun xmtn-status-refresh () + "Refresh status of each ewoc element. With prefix arg, reset local changes status to `unknown'." + (interactive) + (ewoc-map 'xmtn-status-refresh-one xmtn-status-ewoc current-prefix-arg) + (message "done")) + +;;;###autoload +(defun xmtn-update-multiple (dir &optional workspaces) + "Update all projects under DIR." + (interactive "DUpdate all in (root directory): ") + (let ((root (file-name-as-directory (substitute-in-file-name dir)))) + + (if (not workspaces) (setq workspaces (xmtn--filter-non-dir root))) + + (dolist (workspace workspaces) + (let ((default-directory (concat root workspace))) + (xmtn-dvc-update nil t))) + (message "Update %s done" root))) + +;;;###autoload +(defun xmtn-status-multiple (dir &optional workspaces skip-initial-scan) + "Show actions to update all projects under DIR." + (interactive "DStatus for all (root directory): \ni\nP") + (pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) + (setq default-directory (file-name-as-directory (substitute-in-file-name dir))) + (if (not workspaces) (setq workspaces (xmtn--filter-non-dir default-directory))) + (setq xmtn-status-root (file-name-as-directory default-directory)) + (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") + (dolist (workspace workspaces) + (ewoc-enter-last xmtn-status-ewoc + (make-xmtn-status-data + :work workspace + :branch (xmtn--tree-default-branch (concat xmtn-status-root workspace)) + :need-refresh t + :heads 'need-scan))) + (xmtn-multiple-status-mode) + (when (not skip-initial-scan) + (progn + (xmtn-status-refresh) + (xmtn-status-next)))) + +;;;###autoload +(defun xmtn-status-one (work) + "Show actions to update WORK." + (interactive "DStatus for (workspace): ") + (pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) + (setq default-directory work) + (setq xmtn-status-root (expand-file-name (concat (file-name-as-directory work) "../"))) + (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") + (ewoc-enter-last xmtn-status-ewoc + (make-xmtn-status-data + :work (file-name-nondirectory (directory-file-name work)) + :branch (xmtn--tree-default-branch default-directory) + :need-refresh t + :heads 'need-scan)) + (xmtn-multiple-status-mode) + (xmtn-status-refresh) + (xmtn-status-next)) + +(provide 'xmtn-multi-status) + +;; end of file diff --git a/dvc/lisp/xmtn-propagate.el b/dvc/lisp/xmtn-propagate.el index e65b31e..5930379 100644 --- a/dvc/lisp/xmtn-propagate.el +++ b/dvc/lisp/xmtn-propagate.el @@ -149,17 +149,21 @@ The elements must all be of class xmtn-propagate-data.") (insert (dvc-face-add " need propagate\n" 'dvc-conflict))))) (if (eq 'at-head (xmtn-propagate-data-to-heads data)) - (insert " need clean\n")) + (insert (dvc-face-add " need clean\n" 'dvc-conflict))) )) ;; ewoc ought to do this, but it doesn't (redisplay)) -(defun xmtn-kill-conflicts-buffer (data) +(defun xmtn-propagate-kill-conflicts-buffer (data) (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) (let ((buffer (xmtn-propagate-data-conflicts-buffer data))) (with-current-buffer buffer (save-buffer)) (kill-buffer buffer)))) +(defun xmtn-propagate-save-conflicts-buffer (data) + (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer)))) + (defun xmtn-propagate-clean () "Clean current workspace, delete from ewoc" (interactive) @@ -167,8 +171,8 @@ The elements must all be of class xmtn-propagate-data.") (data (ewoc-data elem))) ;; only one conflicts file and buffer + (xmtn-propagate-kill-conflicts-buffer data) (xmtn-conflicts-clean (xmtn-propagate-to-work data)) - (xmtn-kill-conflicts-buffer data) (let ((inhibit-read-only t)) (ewoc-delete xmtn-propagate-ewoc elem)))) @@ -229,6 +233,12 @@ The elements must all be of class xmtn-propagate-data.") (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) (data (ewoc-data elem))) (xmtn-propagate-need-refresh elem data) + + (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))) + ;; user deleted conflicts buffer after resolving conflicts; get it back + (setf (xmtn-propagate-data-conflicts-buffer data) + (xmtn-propagate-conflicts-buffer data))) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (let ((xmtn-confirm-operation nil)) (xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data)))) @@ -274,7 +284,7 @@ The elements must all be of class xmtn-propagate-data.") ;; can't create log-edit buffer with both conflicts and status ;; buffer open, and we'll be killing this as part of the refresh ;; anyway. - (xmtn-kill-conflicts-buffer data) + (xmtn-propagate-kill-conflicts-buffer data) (setf (xmtn-propagate-data-to-local-changes data) 'ok) (xmtn-status (xmtn-propagate-to-work data)))) @@ -452,49 +462,6 @@ The elements must all be of class xmtn-propagate-data.") (xmtn-propagate-refresh) (xmtn-propagate-next nil t)) -(defun xmtn-propagate-local-changes (work) - "Value for xmtn-propagate-data-local-changes for WORK." - (message "checking %s for local changes" work) - (let ((default-directory work) - result) - - (dvc-run-dvc-sync - 'xmtn - (list "status") - :finished (lambda (output error status arguments) - ;; we don't get an error status for not up-to-date, - ;; so parse the output. - ;; FIXME: add option to automate inventory to just return status; can return on first change - ;; FIXME: 'patch' may be internationalized. - - (message "") ; clear minibuffer - (set-buffer output) - (goto-char (point-min)) - (if (search-forward "patch" (point-max) t) - (setq result 'need-commit) - (setq result 'ok))) - - :error (lambda (output error status arguments) - (pop-to-buffer error))) - - (if (eq result 'ok) - ;; check for unknown - (dvc-run-dvc-sync - 'xmtn - (list "ls" "unknown") - :finished (lambda (output error status arguments) - (message "") ; clear minibuffer - (set-buffer output) - (if (not (= (point-min) (point-max))) - (setq result 'need-commit) - (setq result 'ok))) - - :error (lambda (output error status arguments) - (pop-to-buffer error)))) - - result) - ) - (defun xmtn-propagate-needed (data) "t if DATA needs propagate." (let ((result t) @@ -558,18 +525,24 @@ The elements must all be of class xmtn-propagate-data.") (defun xmtn-propagate-conflicts (data) "Return value for xmtn-propagate-data-conflicts for DATA." - ;; if conflicts-buffer is nil, this does the right thing. + + (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))) + ;; user may have deleted conflicts buffer after resolving + ;; conflicts; don't throw that away. + (setf (xmtn-propagate-data-conflicts-buffer data) + (xmtn-propagate-conflicts-buffer data))) + (let ((revs-current - (and (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) - (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) - (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision) - (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision) + (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision))))) (if revs-current (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) - (xmtn-conflicts-update-counts)) + (xmtn-conflicts-update-counts) + (save-buffer)) - ;; recreate conflicts - (xmtn-kill-conflicts-buffer data) + ;; else recreate conflicts + (xmtn-propagate-kill-conflicts-buffer data) (xmtn-conflicts-clean (xmtn-propagate-to-work data)) @@ -629,19 +602,25 @@ The elements must all be of class xmtn-propagate-data.") (progn (ecase (xmtn-propagate-data-from-local-changes data) ((need-scan need-commit) - (setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work))) + (setf (xmtn-propagate-data-from-local-changes data) (xmtn-automate-local-changes from-work))) (ok nil)) (ecase (xmtn-propagate-data-to-local-changes data) ((need-scan need-commit) - (setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work))) + (setf (xmtn-propagate-data-to-local-changes data) (xmtn-automate-local-changes to-work))) (ok nil)))) (if (xmtn-propagate-data-propagate-needed data) - ;; can't compute conflicts if propagate not needed - (setf (xmtn-propagate-data-conflicts data) - (xmtn-propagate-conflicts data)) + (progn + (if refresh-local-changes + (progn + (xmtn-propagate-kill-conflicts-buffer data) + (xmtn-conflicts-clean (xmtn-propagate-to-work data)))) + (setf (xmtn-propagate-data-conflicts data) + (xmtn-propagate-conflicts data))) + + ;; can't compute conflicts if propagate not needed (setf (xmtn-propagate-data-conflicts data) 'need-scan)) (setf (xmtn-propagate-data-need-refresh data) nil)) @@ -725,6 +704,8 @@ scanned and all common ones found are used." (from-session (xmtn-automate-cache-session from-work)) (to-session (xmtn-automate-cache-session to-work))) (pop-to-buffer (get-buffer-create "*xmtn-propagate*")) + ;; default-directory is wrong if buffer is reused + (setq default-directory to-work) (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../"))) (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../"))) (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer)) diff --git a/dvc/lisp/xmtn-revlist.el b/dvc/lisp/xmtn-revlist.el index e69bdbc..5849a43 100644 --- a/dvc/lisp/xmtn-revlist.el +++ b/dvc/lisp/xmtn-revlist.el @@ -148,78 +148,77 @@ arg; root. Result is of the form: (assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids)) (ewoc-set-hf ewoc header footer) (ewoc-filter ewoc (lambda (x) nil)) ; Clear it. - (xmtn-automate-with-session (session root) - (setq revision-hash-ids (xmtn--toposort root revision-hash-ids)) - (if last-n - (let ((len (length revision-hash-ids))) - (if (> len last-n) - (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids))))) - (setq revision-hash-ids (coerce revision-hash-ids 'vector)) - (xmtn--dotimes-with-progress-reporter (i (length revision-hash-ids)) - (case (length revision-hash-ids) - (1 "Setting up revlist buffer (1 revision)...") - (t (format "Setting up revlist buffer (%s revisions)..." - (length revision-hash-ids)))) - ;; Maybe also show parents and children? (Could add toggle - ;; commands to show/hide these.) - (lexical-let ((rev (aref revision-hash-ids i)) - (branches (list)) - (authors (list)) - (dates (list)) - (changelogs (list)) - (tags (list))) - (xmtn--map-parsed-certs - root rev - (lambda (key signature name value trusted) - (declare (ignore key)) - (unless (not trusted) - (cond ((equal name "author") - (push value authors)) - ((equal name "date") - (push value dates)) - ((equal name "changelog") - (push value changelogs)) - ((equal name "branch") - (push value branches)) - ((equal name "tag") - (push value tags)) - (t - (progn)))))) - (setq authors (nreverse authors) - dates (nreverse dates) - changelogs (nreverse changelogs) - branches (nreverse branches) - tags (nreverse tags)) - (let ((parent-hash-ids - (xmtn-automate-simple-command-output-lines root `("parents" - ,rev))) - (child-hash-ids - (xmtn-automate-simple-command-output-lines root `("children" - ,rev)))) - (xmtn--assert-optional (every #'stringp authors)) - (xmtn--assert-optional (every #'stringp dates)) - (xmtn--assert-optional (every #'stringp changelogs)) - (xmtn--assert-optional (every #'stringp branches)) - (xmtn--assert-optional (every #'stringp tags)) - (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids)) - (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids)) - (ewoc-enter-last ewoc - ;; Creating a list `(entry-patch - ;; ,instance-of-dvc-revlist-entry-patch) seems - ;; to be part of DVC's API. - `(entry-patch - ,(make-dvc-revlist-entry-patch - :dvc 'xmtn - :rev-id `(xmtn (revision ,rev)) - :struct (xmtn--make-revlist-entry - :revision-hash-id rev - :branches branches - :authors authors - :dates dates - :changelogs changelogs - :tags tags - :parent-hash-ids parent-hash-ids - :child-hash-ids child-hash-ids)))))))) + (setq revision-hash-ids (xmtn--toposort root revision-hash-ids)) + (if last-n + (let ((len (length revision-hash-ids))) + (if (> len last-n) + (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids))))) + (setq revision-hash-ids (coerce revision-hash-ids 'vector)) + (dotimes-with-progress-reporter (i (length revision-hash-ids)) + (case (length revision-hash-ids) + (1 "Setting up revlist buffer (1 revision)...") + (t (format "Setting up revlist buffer (%s revisions)..." + (length revision-hash-ids)))) + ;; Maybe also show parents and children? (Could add toggle + ;; commands to show/hide these.) + (lexical-let ((rev (aref revision-hash-ids i)) + (branches (list)) + (authors (list)) + (dates (list)) + (changelogs (list)) + (tags (list))) + (xmtn--map-parsed-certs + root rev + (lambda (key signature name value trusted) + (declare (ignore key)) + (unless (not trusted) + (cond ((equal name "author") + (push value authors)) + ((equal name "date") + (push value dates)) + ((equal name "changelog") + (push value changelogs)) + ((equal name "branch") + (push value branches)) + ((equal name "tag") + (push value tags)) + (t + (progn)))))) + (setq authors (nreverse authors) + dates (nreverse dates) + changelogs (nreverse changelogs) + branches (nreverse branches) + tags (nreverse tags)) + (let ((parent-hash-ids + (xmtn-automate-simple-command-output-lines root `("parents" + ,rev))) + (child-hash-ids + (xmtn-automate-simple-command-output-lines root `("children" + ,rev)))) + (xmtn--assert-optional (every #'stringp authors)) + (xmtn--assert-optional (every #'stringp dates)) + (xmtn--assert-optional (every #'stringp changelogs)) + (xmtn--assert-optional (every #'stringp branches)) + (xmtn--assert-optional (every #'stringp tags)) + (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids)) + (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids)) + (ewoc-enter-last ewoc + ;; Creating a list `(entry-patch + ;; ,instance-of-dvc-revlist-entry-patch) seems + ;; to be part of DVC's API. + `(entry-patch + ,(make-dvc-revlist-entry-patch + :dvc 'xmtn + :rev-id `(xmtn (revision ,rev)) + :struct (xmtn--make-revlist-entry + :revision-hash-id rev + :branches branches + :authors authors + :dates dates + :changelogs changelogs + :tags tags + :parent-hash-ids parent-hash-ids + :child-hash-ids child-hash-ids))))))) nil) (defun xmtn-revision-st-message (entry) @@ -257,14 +256,14 @@ arg; root. Result is of the form: (defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n) ;; Adapted from `dvc-build-revision-list'. ;; info-generator-fn must return a list of back-end revision ids (strings) - (xmtn-automate-with-session (nil root) - (let ((dvc-temp-current-active-dvc 'xmtn) - (buffer (dvc-revlist-create-buffer - 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n))) - (with-current-buffer buffer - (setq xmtn--revlist-*info-generator-fn* info-generator-fn) - (xmtn--revlist-refresh)) - (xmtn--display-buffer-maybe buffer nil))) + (xmtn-automate-cache-session root) + (let ((dvc-temp-current-active-dvc 'xmtn) + (buffer (dvc-revlist-create-buffer + 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n))) + (with-current-buffer buffer + (setq xmtn--revlist-*info-generator-fn* info-generator-fn) + (xmtn--revlist-refresh)) + (xmtn--display-buffer-maybe buffer nil)) nil) ;;;###autoload @@ -293,57 +292,54 @@ arg; root. Result is of the form: (xmtn--setup-revlist root (lambda (root) - (xmtn-automate-with-session - (nil root) - (let ((branch (xmtn--tree-default-branch root))) - (list branch - (list - (if dvc-revlist-last-n - (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n) - (format "Log for branch %s (all entries):" branch))) - '() - (xmtn--expand-selector - root - ;; This restriction to current branch is completely - ;; arbitrary. - (concat - "b:" ;; returns all revs for current branch - (xmtn--escape-branch-name-for-selector - branch))))))) + (let ((branch (xmtn--tree-default-branch root))) + (list branch + (list + (if dvc-revlist-last-n + (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n) + (format "Log for branch %s (all entries):" branch))) + '() + (xmtn--expand-selector + root + ;; This restriction to current branch is completely + ;; arbitrary. + (concat + "b:" ;; returns all revs for current branch + (xmtn--escape-branch-name-for-selector + branch)))))) first-line-only-p last-n))) (defun xmtn--revlist--missing-get-info (root) - (xmtn-automate-with-session (nil root) - (let* ((branch (xmtn--tree-default-branch root)) - (heads (xmtn--heads root branch)) - (base-revision-hash-id (xmtn--get-base-revision-hash-id root)) - (difference - (delete-duplicates - (mapcan - (lambda (head) - (xmtn-automate-simple-command-output-lines - root - `("ancestry_difference" - ,head ,base-revision-hash-id))) - heads)))) - (list - branch - `(,(format "Tree %s" root) - ,(format "Branch %s" branch) - ,(format "Base %s" base-revision-hash-id) - ,(case (length heads) - (1 "branch is merged") - (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict))) - nil - ,(case (length difference) - (0 "No revisions that are not in base revision") - (1 "1 revision that is not in base revision:") - (t (format - "%s revisions that are not in base revision:" - (length difference))))) - '() - difference)))) + (let* ((branch (xmtn--tree-default-branch root)) + (heads (xmtn--heads root branch)) + (base-revision-hash-id (xmtn--get-base-revision-hash-id root)) + (difference + (delete-duplicates + (mapcan + (lambda (head) + (xmtn-automate-simple-command-output-lines + root + `("ancestry_difference" + ,head ,base-revision-hash-id))) + heads)))) + (list + branch + `(,(format "Tree %s" root) + ,(format "Branch %s" branch) + ,(format "Base %s" base-revision-hash-id) + ,(case (length heads) + (1 "branch is merged") + (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict))) + nil + ,(case (length difference) + (0 "No revisions that are not in base revision") + (1 "1 revision that is not in base revision:") + (t (format + "%s revisions that are not in base revision:" + (length difference))))) + '() + difference))) (defun xmtn-revlist-show-conflicts () "If point is on a revision that has two parents, show conflicts @@ -459,20 +455,19 @@ from the merge." (xmtn--setup-revlist root (lambda (root) - (xmtn-automate-with-session (nil root) - (let* ((branch (xmtn--tree-default-branch root)) - (head-revision-hash-ids (xmtn--heads root branch)) - (head-count (length head-revision-hash-ids))) - (list - branch - (list (format "Tree %s" root) - (format "Branch %s" branch) - (case head-count - (0 "No head revisions (branch empty (or circular ;))") - (1 "1 head revision:") - (t (format "%s head revisions: " head-count)))) - '() - head-revision-hash-ids)))) + (let* ((branch (xmtn--tree-default-branch root)) + (head-revision-hash-ids (xmtn--heads root branch)) + (head-count (length head-revision-hash-ids))) + (list + branch + (list (format "Tree %s" root) + (format "Branch %s" branch) + (case head-count + (0 "No head revisions (branch empty (or circular ;))") + (1 "1 head revision:") + (t (format "%s head revisions: " head-count)))) + '() + head-revision-hash-ids))) ;; Passing nil as first-line-only-p, last-n is arbitrary here. nil nil)) nil) @@ -498,20 +493,19 @@ to the base revision of the current tree." (xmtn--setup-revlist root (lambda (root) - (xmtn-automate-with-session (nil root) - (let ((branch (xmtn--tree-default-branch root)) - (revision-hash-ids - (mapcar #'first - (xmtn--get-content-changed-closure - root last-backend-id normalized-file dvc-revlist-last-n)))) - (list - branch - (list - (if dvc-revlist-last-n - (format "Log for %s (last %d entries)" file dvc-revlist-last-n) - (format "Log for %s" file))) - '() - revision-hash-ids)))) + (let ((branch (xmtn--tree-default-branch root)) + (revision-hash-ids + (mapcar #'first + (xmtn--get-content-changed-closure + root last-backend-id normalized-file dvc-revlist-last-n)))) + (list + branch + (list + (if dvc-revlist-last-n + (format "Log for %s (last %d entries)" file dvc-revlist-last-n) + (format "Log for %s" file))) + '() + revision-hash-ids))) first-line-only-p last-n)))) @@ -530,25 +524,24 @@ to the base revision of the current tree." (xmtn--setup-revlist root (lambda (root) - (xmtn-automate-with-session (nil root) - (let* ((branch (xmtn--tree-default-branch root)) - (revision-hash-ids (xmtn--expand-selector root selector)) - (count (length revision-hash-ids))) - (list - branch - (list (format "Tree %s" root) - (format "Default branch %s" branch) - (if (with-syntax-table (standard-syntax-table) - (string-match "\\`\\s *\\'" selector)) - "Blank selector" - (format "Selector %s" selector)) - (case count - (0 "No revisions matching selector") - (1 "1 revision matching selector:") - (t (format "%s revisions matching selector: " - count)))) - '() - revision-hash-ids)))) + (let* ((branch (xmtn--tree-default-branch root)) + (revision-hash-ids (xmtn--expand-selector root selector)) + (count (length revision-hash-ids))) + (list + branch + (list (format "Tree %s" root) + (format "Default branch %s" branch) + (if (with-syntax-table (standard-syntax-table) + (string-match "\\`\\s *\\'" selector)) + "Blank selector" + (format "Selector %s" selector)) + (case count + (0 "No revisions matching selector") + (1 "1 revision matching selector:") + (t (format "%s revisions matching selector: " + count)))) + '() + revision-hash-ids))) ;; Passing nil as first-line-only-p is arbitrary here. nil ;; FIXME: it might be useful to specify last-n here @@ -560,28 +553,26 @@ to the base revision of the current tree." ;;;###autoload (defun xmtn-dvc-revlog-get-revision (revision-id) (let ((root (dvc-tree-root))) - (xmtn-automate-with-session (nil root) - (let ((backend-id (xmtn--resolve-revision-id root revision-id))) - (xmtn-match backend-id - ((local-tree $path) (error "Not implemented")) - ((revision $revision-hash-id) - (with-output-to-string - (flet ((write-line (format &rest args) - (princ (apply #'format format args)) - (terpri))) - (write-line "Revision %s" revision-hash-id) - ;; FIXME: It would be good to sort the standard certs - ;; like author, date, branch, tag and changelog into - ;; some canonical order and format changelog specially - ;; since it usually spans multiple lines. - (xmtn--map-parsed-certs - root revision-hash-id - (lambda (key signature name value trusted) - (declare (ignore key)) - (if (not trusted) - (write-line "Untrusted cert, name=%s" name) - (write-line "%s: %s" name value)))))))))))) - + (let ((backend-id (xmtn--resolve-revision-id root revision-id))) + (xmtn-match backend-id + ((local-tree $path) (error "Not implemented")) + ((revision $revision-hash-id) + (with-output-to-string + (flet ((write-line (format &rest args) + (princ (apply #'format format args)) + (terpri))) + (write-line "Revision %s" revision-hash-id) + ;; FIXME: It would be good to sort the standard certs + ;; like author, date, branch, tag and changelog into + ;; some canonical order and format changelog specially + ;; since it usually spans multiple lines. + (xmtn--map-parsed-certs + root revision-hash-id + (lambda (key signature name value trusted) + (declare (ignore key)) + (if (not trusted) + (write-line "Untrusted cert, name=%s" name) + (write-line "%s: %s" name value))))))))))) (defun xmtn-revlist-explicit-merge () "Run mtn explicit_merge on the two marked revisions. @@ -618,29 +609,6 @@ To be invoked from an xmtn revlist buffer." (target-hash-id (xmtn--revlist-entry-revision-hash-id entry))) (xmtn--update root target-hash-id nil nil))) -;; Being able to conveniently disapprove whole batches of revisions -;; is going to be a lot of fun. -(defun xmtn-revlist-disapprove () - "Disapprove the marked revisions, or the revision at point if none marked. - -To be invoked from an xmtn revlist buffer." - (interactive) - (let* ((root (dvc-tree-root)) - (entries (or (dvc-revision-marked-revisions) - (list (dvc-revlist-current-patch-struct)))) - (hash-ids (map 'vector #'xmtn--revlist-entry-revision-hash-id entries)) - (description (case (length hash-ids) - (0 (xmtn--assert-nil)) - (1 (format "revision %s" (elt hash-ids 0))) - (t (format "%s revisions" (length hash-ids)))))) - (assert (every #'xmtn--hash-id-p hash-ids)) - (unless (yes-or-no-p (format "Disapprove %s? " description)) - (error "Aborted disapprove")) - (xmtn--dotimes-with-progress-reporter (i (length hash-ids)) - (format "Disapproving %s..." description) - (let ((hash-id (aref hash-ids i))) - (funcall (xmtn--do-disapprove-future root hash-id)))))) - (provide 'xmtn-revlist) ;;; xmtn-revlist.el ends here diff --git a/dvc/lisp/xmtn-run.el b/dvc/lisp/xmtn-run.el index a8ec62c..cdc34ae 100644 --- a/dvc/lisp/xmtn-run.el +++ b/dvc/lisp/xmtn-run.el @@ -43,31 +43,18 @@ (define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix) -(defun xmtn--call-with-environment-for-subprocess (xmtn--thunk) - (let ((process-environment (list* "LC_ALL=" - "LC_CTYPE=en_US.UTF-8" - "LC_MESSAGES=C" - process-environment))) - (funcall xmtn--thunk))) - -(defmacro* xmtn--with-environment-for-subprocess (() &body body) - (declare (indent 1) (debug (sexp body))) - `(xmtn--call-with-environment-for-subprocess (lambda () ,@body))) - (defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key) (xmtn--check-cached-command-version) (let ((default-directory (file-truename (or root default-directory)))) - (let ((coding-system-for-write 'xmtn--monotone-normal-form)) - (xmtn--with-environment-for-subprocess () - (apply #'dvc-run-dvc-sync - 'xmtn - `(,@xmtn-additional-arguments - ;; We don't pass the --root argument here; it is not - ;; necessary since default-directory is set, and it - ;; confuses the Cygwin version of mtn when run with a - ;; non-Cygwin Emacs. - ,@arguments) - dvc-run-keys))))) + (dvc-run-dvc-sync + 'xmtn + `(,@xmtn-additional-arguments + ;; We don't pass the --root argument here; it is not + ;; necessary since default-directory is set, and it + ;; confuses the Cygwin version of mtn when run with a + ;; non-Cygwin Emacs. + ,@arguments) + dvc-run-keys))) ;;; The `dvc-run-dvc-*' functions use `call-process', which, for some ;;; reason, spawns the subprocess with a working directory with all @@ -80,141 +67,36 @@ (defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key) (xmtn--check-cached-command-version) (let ((default-directory (file-truename (or root default-directory)))) - (let ((coding-system-for-write 'xmtn--monotone-normal-form)) - (xmtn--with-environment-for-subprocess () - (apply #'dvc-run-dvc-async - 'xmtn - `(,@xmtn-additional-arguments - ;; We don't pass the --root argument here; it is not - ;; necessary since default-directory is set, and it - ;; confuses the Cygwin version of mtn when run with a - ;; non-Cygwin Emacs. - ,@arguments) - dvc-run-keys))))) - -(defun* xmtn--command-append-to-buffer-async (buffer root arguments - &rest dvc-run-keys - &key finished) - (xmtn--check-cached-command-version) - (let ((default-directory (file-truename (or root default-directory)))) - (let ((coding-system-for-write 'xmtn--monotone-normal-form)) - (xmtn--with-environment-for-subprocess () - (apply #'dvc-run-dvc-async - 'xmtn - `(,@xmtn-additional-arguments - ,@(if root `(,(concat "--root=" (file-truename root)))) - ,@arguments) - :finished (lexical-let ((buffer buffer) - (finished finished)) - (lambda (output error status arguments) - (with-current-buffer buffer - (save-excursion - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert-buffer-substring output)))) - (funcall (or finished #'dvc-default-finish-function) - output error status arguments))) - :related-buffer buffer - dvc-run-keys))))) - -(defun* xmtn--command-lines-future (root which-buffer arguments) - (xmtn--check-cached-command-version) - (lexical-let ((got-output-p nil) - lines) - (lexical-let - ((process - (let ((default-directory (file-truename (or root - default-directory)))) - (let ((coding-system-for-write 'xmtn--monotone-normal-form)) - (xmtn--with-environment-for-subprocess () - (dvc-run-dvc-async - 'xmtn - `(,@xmtn-additional-arguments - ,@(if root `(,(concat "--root=" (file-truename root)))) - ,@arguments) - :finished - (lexical-let ((which-buffer which-buffer)) - (lambda (output error status arguments) - (with-current-buffer (ecase which-buffer - (output output) - (error error)) - (save-excursion - (goto-char (point-min)) - (setq lines - (loop until (eobp) - collect - (buffer-substring-no-properties - (point) - (progn (end-of-line) (point))) - do (forward-line 1))) - (setq got-output-p t))) - nil)))))))) - (lambda () - (assert (member (process-status process) '(run exit signal)) t) - (while (and (eql (process-status process) 'run) - (accept-process-output process))) - (assert (member (process-status process) '(exit signal)) t) - ;; This (including discarding input) is needed to allow the - ;; sentinel to run, at least on GNU Emacs 21.4.2 and on GNU - ;; Emacs 22.0.50.1 of 2006-06-13. Sentinels are supposed to - ;; be run when `accept-process-output' is called, but they - ;; apparently aren't reliably. I haven't investigated this - ;; further. - ;; - ;; Problems with the sentinel not running mostly seem to be - ;; reproducible (after commenting out the code below) by - ;; pressing C-x V c immediately followed by a few other keys, - ;; or by pressing C-x V c not followed by any further input, - ;; or by editing a file in the tree without saving it, then - ;; pressing C-x V c, waiting for the "Save buffer?" prompt and - ;; then pressing y immediately followed by a few other keys. - ;; - ;; I hate having to discard the input because it interferes - ;; with typing ahead while Emacs is still busy. But hanging - ;; indefinitely waiting for `got-output-p' from a sentinel - ;; that never runs is even worse. - (while (and (eql (process-status process) 'exit) - (eql (process-exit-status process) 0) - (not got-output-p)) - (discard-input) - (sit-for .01)) - (unless got-output-p - (assert (not (and (eql (process-status process) 'exit) - (eql (process-exit-status process) 0)))) - (error "Process %s terminated abnormally, status=%s, exit code=%s" - (process-name process) - (process-status process) - (process-exit-status process))) - lines)))) - -(defun* xmtn--command-output-lines-future (root arguments) - (xmtn--command-lines-future root 'output arguments)) - -(defun* xmtn--command-error-output-lines-future (root arguments) - (xmtn--command-lines-future root 'error arguments)) + (apply #'dvc-run-dvc-async + 'xmtn + `(,@xmtn-additional-arguments + ;; We don't pass the --root argument here; it is not + ;; necessary since default-directory is set, and it + ;; confuses the Cygwin version of mtn when run with a + ;; non-Cygwin Emacs. + ,@arguments) + dvc-run-keys))) (defun xmtn--command-output-lines (root arguments) "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings." (xmtn--check-cached-command-version) (let ((accu (list))) (let ((default-directory (file-truename (or root default-directory)))) - (let ((coding-system-for-write 'xmtn--monotone-normal-form)) - (xmtn--with-environment-for-subprocess () - (dvc-run-dvc-sync - 'xmtn - `(,@xmtn-additional-arguments - ,@(if root `(,(concat "--root=" (file-truename root)))) - ,@arguments) - :finished (lambda (output error status arguments) - (with-current-buffer output - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (push (buffer-substring-no-properties - (point) - (progn (end-of-line) (point))) - accu) - (forward-line 1))))))))) + (dvc-run-dvc-sync + 'xmtn + `(,@xmtn-additional-arguments + ,@(if root `(,(concat "--root=" (file-truename root)))) + ,@arguments) + :finished (lambda (output error status arguments) + (with-current-buffer output + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (push (buffer-substring-no-properties + (point) + (progn (end-of-line) (point))) + accu) + (forward-line 1))))))) (setq accu (nreverse accu)) accu))