1014 lines
46 KiB
EmacsLisp
1014 lines
46 KiB
EmacsLisp
;;; xmtn-automate.el --- Interface to monotone's "automate" functionality
|
|
|
|
;; Copyright (C) 2008, 2009 Stephen Leake
|
|
;; Copyright (C) 2006, 2007 Christian M. Ohler
|
|
|
|
;; Author: Christian M. Ohler
|
|
;; 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.
|
|
|
|
;;; Commentary:
|
|
|
|
;; 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.)
|
|
;;
|
|
;; 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.
|
|
;;
|
|
;; 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.
|
|
;;
|
|
;; The following operations are defined on command handles.
|
|
;;
|
|
;; * 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.
|
|
;;
|
|
;; The intention behind this protocol is to allow Emacs Lisp code to
|
|
;; process command output incrementally as it arrives instead of
|
|
;; waiting until it is complete. However, for xmtn-basic-io, the
|
|
;; bookkeeping overhead for this kind of pipelining was excessive --
|
|
;; byte-compiled Emacs Lisp is rather slow. But I didn't try very
|
|
;; hard to tune it, either. So I'm not sure whether incremental
|
|
;; processing is useful.
|
|
;;
|
|
;; In the output buffer, the "chunking" (the <command number>:<err
|
|
;; code>:<last?>:<size>:<output> 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.)
|
|
|
|
;;; 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
|
|
(require 'xmtn-base)
|
|
(require 'xmtn-run)
|
|
(require 'xmtn-compat))
|
|
|
|
(defun xmtn-automate-command-error-code (command)
|
|
(let ((process (xmtn-automate--session-process
|
|
(xmtn-automate--command-handle-session command))))
|
|
(while (null (xmtn-automate--command-handle-error-code command))
|
|
(xmtn--assert-for-effect
|
|
(accept-process-output process))))
|
|
(xmtn-automate--command-handle-error-code command))
|
|
|
|
(defun xmtn-automate-command-buffer (command)
|
|
(xmtn-automate--command-handle-buffer command))
|
|
|
|
(defun xmtn-automate-command-write-marker-position (command)
|
|
(marker-position (xmtn-automate--command-handle-write-marker command)))
|
|
|
|
(defun xmtn-automate-command-accept-output (command)
|
|
(let ((previous-write-marker-position
|
|
(marker-position (xmtn-automate--command-handle-write-marker
|
|
command))))
|
|
(while (and (= (marker-position (xmtn-automate--command-handle-write-marker
|
|
command))
|
|
previous-write-marker-position)
|
|
(not (xmtn-automate--command-handle-finished-p command)))
|
|
(xmtn--assert-for-effect
|
|
(accept-process-output
|
|
(xmtn-automate--session-process
|
|
(xmtn-automate--command-handle-session command)))))
|
|
(> (marker-position (xmtn-automate--command-handle-write-marker
|
|
command))
|
|
previous-write-marker-position)))
|
|
|
|
(defun xmtn-automate-command-finished-p (command)
|
|
(xmtn-automate--command-handle-finished-p command))
|
|
|
|
(defun xmtn-automate-command-wait-until-finished (handle)
|
|
(while (not (xmtn-automate-command-finished-p handle))
|
|
(xmtn--assert-for-effect (or (xmtn-automate-command-accept-output handle)
|
|
(xmtn-automate-command-finished-p handle))))
|
|
nil)
|
|
|
|
(defvar xmtn-automate--*sessions* '())
|
|
|
|
(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))
|
|
|
|
(defun xmtn-automate-get-cached-session (key)
|
|
"Return a session from the cache, or nil."
|
|
;; separate function so we can debug it
|
|
(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))))
|
|
|
|
(defun xmtn-automate-command-check-for-and-report-error (handle)
|
|
(unless (eql (xmtn-automate-command-error-code handle) 0)
|
|
(error "mtn automate command (arguments %S) reported an error (code %s):\n%s"
|
|
(xmtn-automate--command-handle-arguments handle)
|
|
(xmtn-automate-command-error-code handle)
|
|
(xmtn-automate--command-output-as-string-ignoring-exit-code handle)))
|
|
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))))
|
|
|
|
(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))))))
|
|
|
|
(defun xmtn-automate-command-output-lines (handle)
|
|
;; Return list of lines of output; 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
|
|
(set-buffer (xmtn-automate-command-buffer handle))
|
|
(goto-char (point-min))
|
|
(let (result)
|
|
(while (< (point) (point-max))
|
|
(setq result (cons (buffer-substring-no-properties
|
|
(point)
|
|
(progn (end-of-line) (point)))
|
|
result))
|
|
(forward-line 1))
|
|
(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))))
|
|
|
|
;; 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.
|
|
|
|
Signals an error if output contains zero lines or more than one line."
|
|
(let ((lines (xmtn-automate-simple-command-output-lines root command)))
|
|
(unless (eql (length lines) 1)
|
|
(error "Expected precisely one line of output from mtn automate, got %s: %s %S"
|
|
(length lines)
|
|
xmtn-executable
|
|
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))
|
|
|
|
(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))
|
|
|
|
(defstruct (xmtn-automate--decoder-state
|
|
(:constructor xmtn-automate--%make-raw-decoder-state))
|
|
(read-marker)
|
|
(remaining-chars 0)
|
|
(last-p nil))
|
|
|
|
(defstruct (xmtn-automate--session
|
|
(:constructor xmtn-automate--%make-raw-session)
|
|
(:copier xmtn-automate--copy-session))
|
|
(root)
|
|
(name)
|
|
(buffer nil)
|
|
(process nil)
|
|
(decoder-state)
|
|
(next-mtn-command-number)
|
|
(next-session-command-number 0)
|
|
(must-not-kill-counter)
|
|
(remaining-command-handles)
|
|
(sent-kill-p)
|
|
(closed-p nil))
|
|
|
|
(defstruct (xmtn-automate--command-handle
|
|
(:constructor xmtn-automate--%make-raw-command-handle))
|
|
(arguments)
|
|
(mtn-command-number)
|
|
(session-command-number)
|
|
(session)
|
|
(buffer)
|
|
(write-marker)
|
|
(may-kill-p)
|
|
(finished-p nil)
|
|
(error-code nil))
|
|
|
|
(defun* xmtn-automate--initialize-session (session &key root name)
|
|
(xmtn--assert-optional (equal root (file-name-as-directory root)) t)
|
|
(setf (xmtn-automate--session-root session) root
|
|
(xmtn-automate--session-name session) name
|
|
(xmtn-automate--session-process session) nil
|
|
(xmtn-automate--session-closed-p session) nil)
|
|
nil)
|
|
|
|
(defun xmtn-automate--make-session (root key)
|
|
(dvc-trace "new session %s" key)
|
|
(let* ((name (format "xmtn automate session for %s" key)))
|
|
(let ((session (xmtn-automate--%make-raw-session)))
|
|
(xmtn-automate--initialize-session session :root root :name name)
|
|
session)))
|
|
|
|
(defun xmtn-automate--session-send-process-kill (session)
|
|
(let ((process (xmtn-automate--session-process session)))
|
|
;; Stop parser.
|
|
(setf (xmtn-automate--session-sent-kill-p session) t)
|
|
(with-current-buffer (xmtn-automate--session-buffer session)
|
|
(let ((inhibit-read-only t)
|
|
deactivate-mark)
|
|
(save-excursion
|
|
(goto-char (process-mark process))
|
|
(insert "\n(killing process)\n")
|
|
(set-marker (process-mark process) (point)))))
|
|
;; Maybe this should really be a sigpipe. But let's not get too
|
|
;; fancy (ha!) and non-portable.
|
|
;;(signal-process (xmtn-automate--session-process session) 'PIPE)
|
|
;; This call to `sit-for' is apparently needed in some situations to
|
|
;; make sure the process really gets killed.
|
|
(sit-for 0)
|
|
(interrupt-process process))
|
|
nil)
|
|
|
|
(defun xmtn-automate--close-session (session)
|
|
(setf (xmtn-automate--session-closed-p session) t)
|
|
(let ((process (xmtn-automate--session-process session)))
|
|
(cond
|
|
((null process)
|
|
;; Process died for some reason - most likely 'mtn not found in
|
|
;; path'. Don't warn if buffer hasn't been deleted; that
|
|
;; obscures the real error message
|
|
nil)
|
|
((ecase (process-status process)
|
|
(run nil)
|
|
(exit t)
|
|
(signal t))
|
|
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
|
(kill-buffer (xmtn-automate--session-buffer session))))
|
|
(t
|
|
(process-send-eof process)
|
|
(if (zerop (xmtn-automate--session-must-not-kill-counter session))
|
|
(xmtn-automate--session-send-process-kill session)
|
|
;; We can't kill the buffer yet. We need to dump mtn's output
|
|
;; in there so we can parse it and determine when the critical
|
|
;; commands are finished so we can then kill mtn.
|
|
(dvc-trace
|
|
"Not killing process %s yet: %s out of %s remaining commands are critical"
|
|
(process-name process)
|
|
(xmtn-automate--session-must-not-kill-counter session)
|
|
(length (xmtn-automate--session-remaining-command-handles session))))
|
|
(with-current-buffer (xmtn-automate--session-buffer session)
|
|
;; This isn't essential but helps debugging.
|
|
(rename-buffer (format "*%s: killed session*"
|
|
(xmtn-automate--session-name session))
|
|
t))
|
|
(let ((fake-session (xmtn-automate--copy-session session)))
|
|
(xmtn-automate--set-process-session process fake-session)))))
|
|
nil)
|
|
|
|
(defun xmtn-automate--start-process (session)
|
|
(xmtn--check-cached-command-version)
|
|
(xmtn--assert-optional (not (xmtn-automate--session-closed-p session)))
|
|
(xmtn--assert-optional (typep session 'xmtn-automate--session))
|
|
(let ((name (xmtn-automate--session-name session))
|
|
(buffer (xmtn-automate--new-buffer session))
|
|
(root (xmtn-automate--session-root session)))
|
|
(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))))
|
|
(xmtn-automate--set-process-session process session)
|
|
(set-process-filter process 'xmtn-automate--process-filter)
|
|
(set-process-sentinel process 'xmtn-automate--process-sentinel)
|
|
(xmtn--set-process-query-on-exit-flag process nil)
|
|
;; Need binary (or no-conversion or maybe raw-text-unix?)
|
|
;; since this is the format in which mtn automate stdio
|
|
;; computes the size of the output.
|
|
(set-process-coding-system process 'binary 'binary)
|
|
(setf (xmtn-automate--session-process session) process)
|
|
(setf (xmtn-automate--session-decoder-state session)
|
|
(xmtn-automate--%make-raw-decoder-state
|
|
:read-marker (with-current-buffer buffer
|
|
(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)
|
|
(let ((process (xmtn-automate--session-process session)))
|
|
(when (or (null process)
|
|
(ecase (process-status process)
|
|
(run nil)
|
|
(exit t)
|
|
(signal t)))
|
|
(setq process (xmtn-automate--start-process session))
|
|
(setf (xmtn-automate--session-process session) process))
|
|
(xmtn--assert-optional (buffer-live-p (xmtn-automate--session-buffer
|
|
session)))
|
|
process))
|
|
|
|
(defun xmtn-automate--new-buffer (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)
|
|
(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
|
|
the buffer."
|
|
(xmtn--assert-optional (eql (point) (point-max)))
|
|
(dolist (string strings)
|
|
(if string
|
|
(progn
|
|
(save-excursion (insert string))
|
|
(encode-coding-region (point) (point-max) 'xmtn--monotone-normal-form)
|
|
(insert (number-to-string (- (point-max) (point))) ":")
|
|
(goto-char (point-max)))))
|
|
nil)
|
|
|
|
(defun xmtn-automate--send-command-string (session command option-plist
|
|
mtn-number session-number)
|
|
"Send COMMAND and OPTION-PLIST to SESSION."
|
|
(let* ((buffer-name (format "*%s: input for command %s(%s)*"
|
|
(xmtn-automate--session-name session)
|
|
mtn-number
|
|
session-number))
|
|
(buffer nil))
|
|
(unwind-protect
|
|
(progn
|
|
(when (get-buffer buffer-name)
|
|
;; Make sure the buffer is in a clean state.
|
|
(with-current-buffer buffer-name
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer))
|
|
(fundamental-mode)))
|
|
(setq buffer (get-buffer-create buffer-name))
|
|
(with-current-buffer buffer
|
|
(buffer-disable-undo)
|
|
(xmtn--set-buffer-multibyte t)
|
|
(setq buffer-read-only t)
|
|
(let ((inhibit-read-only t))
|
|
(when option-plist
|
|
(insert "o")
|
|
(xmtn-automate--append-encoded-strings option-plist)
|
|
(insert "e"))
|
|
(insert "l")
|
|
(xmtn-automate--append-encoded-strings command)
|
|
(insert "e\n"))
|
|
|
|
(dvc-trace "mtn automate: '%s'" (buffer-substring (point-min) (point-max)))
|
|
|
|
(process-send-region (xmtn-automate--session-process session)
|
|
(point-min) (point-max))))
|
|
(when buffer
|
|
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
|
(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))
|
|
(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
|
|
session))))
|
|
(buffer-name (format "*%s: output for command %s(%s)*"
|
|
(xmtn-automate--session-name session)
|
|
mtn-number
|
|
session-number))
|
|
(buffer
|
|
(progn (when (get-buffer buffer-name)
|
|
;; Make sure no local variables or mode changes
|
|
;; remain from the previous command parser.
|
|
(with-current-buffer buffer-name
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer))
|
|
(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))
|
|
(with-current-buffer buffer
|
|
(buffer-disable-undo)
|
|
(xmtn--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
|
|
:may-kill-p may-kill-p
|
|
:buffer buffer
|
|
:write-marker (set-marker (make-marker) (point)))))
|
|
(setf
|
|
(xmtn-automate--session-remaining-command-handles session)
|
|
(nconc (xmtn-automate--session-remaining-command-handles session)
|
|
(list handle)))
|
|
(when (not may-kill-p)
|
|
(incf (xmtn-automate--session-must-not-kill-counter session))
|
|
(xmtn--set-process-query-on-exit-flag
|
|
(xmtn-automate--session-process session)
|
|
t))
|
|
handle))))
|
|
|
|
(defun xmtn-automate--cleanup-command (handle)
|
|
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
|
(kill-buffer (xmtn-automate--command-handle-buffer handle))))
|
|
|
|
(defsubst xmtn-automate--process-new-output--copy (session)
|
|
(let* ((session-buffer (xmtn-automate--session-buffer session))
|
|
(state (xmtn-automate--session-decoder-state session))
|
|
(read-marker (xmtn-automate--decoder-state-read-marker state))
|
|
(command (first (xmtn-automate--session-remaining-command-handles
|
|
session)))
|
|
(command-output-buffer
|
|
(xmtn-automate--command-handle-buffer command))
|
|
(write-marker
|
|
(xmtn-automate--command-handle-write-marker command)))
|
|
(xmtn--assert-optional (not (xmtn-automate--session-sent-kill-p session)))
|
|
(with-current-buffer session-buffer
|
|
(let* ((end (min (+ read-marker
|
|
(xmtn-automate--decoder-state-remaining-chars state))
|
|
(point-max)))
|
|
(chars-to-read (- end read-marker)))
|
|
(cond
|
|
((= chars-to-read 0)
|
|
nil)
|
|
((> chars-to-read 0)
|
|
(if (not (buffer-live-p command-output-buffer))
|
|
;; Buffer has already been killed, just discard input.
|
|
(progn)
|
|
(with-current-buffer command-output-buffer
|
|
(save-excursion
|
|
(goto-char write-marker)
|
|
(let ((inhibit-read-only t)
|
|
deactivate-mark)
|
|
(xmtn--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)
|
|
)
|
|
(set-marker read-marker end)
|
|
(decf (xmtn-automate--decoder-state-remaining-chars state)
|
|
chars-to-read)
|
|
t)
|
|
(t (xmtn--assert-nil))))))
|
|
;; Return value matters!
|
|
)
|
|
|
|
(defun xmtn--debug-mark-text-processed (buffer start end bold-p)
|
|
(xmtn--assert-optional (< start end) t)
|
|
(with-current-buffer buffer
|
|
(let ((inhibit-read-only t))
|
|
(if bold-p
|
|
(xmtn--assert-for-effect
|
|
(add-text-properties start end
|
|
'(face
|
|
(:strike-through
|
|
t
|
|
:weight semi-bold))))
|
|
(xmtn--assert-for-effect
|
|
(add-text-properties start end '(face (:strike-through
|
|
t))))))))
|
|
|
|
(defsubst xmtn-automate--process-new-output (session new-string)
|
|
(let* ((session-buffer (xmtn-automate--session-buffer session))
|
|
(state (xmtn-automate--session-decoder-state session))
|
|
(read-marker (xmtn-automate--decoder-state-read-marker state))
|
|
(write-marker (process-mark (xmtn-automate--session-process session)))
|
|
(tag 'check-for-more))
|
|
(with-current-buffer session-buffer
|
|
;; Why oh why doesn't (require 'cl) provide tagbody...
|
|
(loop
|
|
for command = (first (xmtn-automate--session-remaining-command-handles
|
|
session))
|
|
do
|
|
(xmtn--assert-optional (or (eql tag 'exit-loop)
|
|
(not (xmtn-automate--session-sent-kill-p
|
|
session))))
|
|
(ecase tag
|
|
(check-for-more
|
|
(xmtn--assert-optional (<= read-marker write-marker) t)
|
|
(if (= read-marker write-marker)
|
|
(setq tag 'exit-loop)
|
|
(setq tag 'again)))
|
|
(again
|
|
(cond
|
|
((> (xmtn-automate--decoder-state-remaining-chars state) 0)
|
|
(if (xmtn-automate--process-new-output--copy session)
|
|
(setq tag 'again)
|
|
(setq tag 'check-for-more)))
|
|
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0)
|
|
(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)))
|
|
(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
|
|
session)))
|
|
(xmtn--set-process-query-on-exit-flag
|
|
(xmtn-automate--session-process session)
|
|
nil)
|
|
(when (xmtn-automate--session-closed-p session)
|
|
(xmtn-automate--session-send-process-kill session)
|
|
(setq tag 'exit-loop))))
|
|
(setf (xmtn-automate--decoder-state-last-p state) nil))
|
|
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0)
|
|
(not (xmtn-automate--decoder-state-last-p state)))
|
|
(unless command
|
|
(error "Unexpected output from mtn: %s" new-string))
|
|
(save-excursion
|
|
(goto-char read-marker)
|
|
(cond ((looking-at
|
|
"\\([0-9]+\\):\\([012]\\):\\([lm]\\):\\([0-9]+\\):")
|
|
(let ((command-number (parse-integer (match-string 1)))
|
|
(error-code (parse-integer (match-string 2)))
|
|
(last-p (cond
|
|
((string= (match-string 3) "l") t)
|
|
((string= (match-string 3) "m") nil)
|
|
(t (xmtn--assert-nil))))
|
|
(size (parse-integer (match-string 4))))
|
|
(xmtn--assert-optional (typep command-number
|
|
'(integer 0 *))
|
|
t)
|
|
(xmtn--assert-optional (typep error-code '(member 0 1 2))
|
|
t)
|
|
(xmtn--assert-optional (typep size '(integer 0 *)) t)
|
|
(xmtn--assert-optional
|
|
(eql
|
|
command-number
|
|
(xmtn-automate--command-handle-mtn-command-number
|
|
command)))
|
|
(setf (xmtn-automate--command-handle-error-code command)
|
|
error-code)
|
|
(setf (xmtn-automate--decoder-state-remaining-chars
|
|
state)
|
|
size)
|
|
(setf (xmtn-automate--decoder-state-last-p state)
|
|
last-p)
|
|
;;(xmtn--debug-mark-text-processed session-buffer
|
|
;; read-marker
|
|
;; (match-end 0)
|
|
;; t)
|
|
(set-marker read-marker (match-end 0)))
|
|
(setq tag 'again))
|
|
;; This is just a simple heuristic, there are many
|
|
;; kinds of invalid input that it doesn't detect.
|
|
;; FIXME: This can errorneously be triggered by
|
|
;; warnings that mtn prints on stderr; but Emacs
|
|
;; interleaves stdout and stderr (see (elisp)
|
|
;; Output from Processes) with no way to
|
|
;; distinguish between them. We'll probably have
|
|
;; to spawn mtn inside a shell that redirects
|
|
;; stderr to a file. But I don't think that's
|
|
;; possible in a portable way...
|
|
((looking-at "[^0-9]")
|
|
(error "Invalid output from mtn: %s"
|
|
(buffer-substring-no-properties (point)
|
|
(point-max))))
|
|
(t
|
|
(xmtn--assert-optional command)
|
|
(setq tag 'exit-loop)))))
|
|
(t (xmtn--assert-nil))))
|
|
(exit-loop (return))))))
|
|
nil)
|
|
|
|
|
|
(defvar xmtn-automate--*preserve-buffers-for-debugging* nil)
|
|
|
|
(defun xmtn-automate--process-sentinel (process event-string)
|
|
(let ((status (process-status process))
|
|
(session (xmtn-automate--process-session process)))
|
|
(let ((buffer (xmtn-automate--session-buffer session)))
|
|
(when (buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(let ((inhibit-read-only t)
|
|
deactivate-mark)
|
|
(save-excursion
|
|
;; This seems to fail in XEmacs when running the test
|
|
;; `file-diff'. I don't know why.
|
|
(xmtn--assert-optional (marker-position (process-mark process))
|
|
t)
|
|
(goto-char (process-mark process))
|
|
(insert (format "\n(process exited: %S)\n"
|
|
(if (eql (aref event-string
|
|
(1- (length event-string)))
|
|
?\n)
|
|
(subseq event-string 0
|
|
(1- (length event-string)))
|
|
event-string)))
|
|
(set-marker (process-mark process) (point))))))
|
|
(flet ((reclaim-buffer ()
|
|
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
|
;; Maybe it's not such a good idea to kill the buffer
|
|
;; from here since that will run `kill-buffer-hook',
|
|
;; and the functions in there might not be prepared to
|
|
;; run inside a sentinel. But let's wait until someone
|
|
;; actually encounters this problem.
|
|
(kill-buffer buffer)
|
|
)))
|
|
(ecase status
|
|
(exit
|
|
(xmtn--assert-optional (eql (process-exit-status process) 0) t)
|
|
(reclaim-buffer))
|
|
(signal
|
|
(if (xmtn-automate--session-sent-kill-p session)
|
|
(reclaim-buffer)
|
|
(message "Process %s died due to signal" (process-name process))
|
|
(when (not (zerop (xmtn-automate--session-must-not-kill-counter
|
|
session)))
|
|
(xmtn--lwarn
|
|
'xmtn ':error
|
|
"Process %s died due to signal during a critical operation"
|
|
(process-name process))))))))))
|
|
|
|
(defun xmtn-automate--process-filter (process input-string)
|
|
(let ((session (xmtn-automate--process-session process)))
|
|
(let ((buffer (xmtn-automate--session-buffer session)))
|
|
(xmtn--assert-optional (eql (process-buffer process) buffer))
|
|
(xmtn--assert-optional (buffer-live-p buffer))
|
|
(with-current-buffer buffer
|
|
(let* ((mark (process-mark process))
|
|
(move-point-p (= (point) mark)))
|
|
(save-excursion
|
|
(goto-char mark)
|
|
(let ((inhibit-read-only t)
|
|
deactivate-mark)
|
|
(insert input-string))
|
|
(set-marker mark (point)))
|
|
(when move-point-p (goto-char mark))))
|
|
;;(with-local-quit ; For debugging.
|
|
;; Emacs receives a message "mtn: operation canceled: Interrupt"
|
|
;; from mtn after we kill it. Ignore such "input".
|
|
(unless (xmtn-automate--session-sent-kill-p session)
|
|
(xmtn-automate--process-new-output session input-string))
|
|
;;)
|
|
)))
|
|
|
|
(defun xmtn--map-parsed-certs (xmtn--root xmtn--revision-hash-id xmtn--thunk)
|
|
(lexical-let ((root xmtn--root)
|
|
(revision-hash-id xmtn--revision-hash-id)
|
|
(thunk xmtn--thunk))
|
|
(xmtn--with-automate-command-output-basic-io-parser
|
|
(xmtn--next-stanza root `("certs" ,revision-hash-id))
|
|
(loop
|
|
for xmtn--stanza = (funcall xmtn--next-stanza)
|
|
while xmtn--stanza
|
|
do (xmtn-match xmtn--stanza
|
|
((("key" (string $xmtn--key))
|
|
("signature" (string $xmtn--signature))
|
|
("name" (string $xmtn--name))
|
|
("value" (string $xmtn--value))
|
|
("trust" (string $xmtn--trust)))
|
|
(setq xmtn--signature (xmtn-match xmtn--signature
|
|
("ok" 'ok)
|
|
("bad" 'bad)
|
|
("unknown" 'unknown)))
|
|
(let ((xmtn--trusted (xmtn-match xmtn--trust
|
|
("trusted" t)
|
|
("untrusted" nil))))
|
|
(macrolet ((decodef (var)
|
|
`(setq ,var (decode-coding-string
|
|
,var 'xmtn--monotone-normal-form))))
|
|
(decodef xmtn--key)
|
|
(decodef xmtn--name)
|
|
;; I'm not sure this is correct. The documentation
|
|
;; mentions a cert_is_binary hook, but it doesn't
|
|
;; exist; and even if it did, we would have no way of
|
|
;; calling it from here. But, since cert values are
|
|
;; always passed on the command line, and command
|
|
;; line arguments are converted to utf-8, I suspect
|
|
;; certs will also always be in utf-8.
|
|
(decodef xmtn--value))
|
|
(funcall thunk
|
|
xmtn--key xmtn--signature xmtn--name xmtn--value
|
|
xmtn--trusted))))))))
|
|
|
|
(defun xmtn--list-parsed-certs (root revision-hash-id)
|
|
"Return a list of the contents of each cert attached to REVISION-HASH-ID.
|
|
Each element of the list is a list; key, signature, name, value, trust."
|
|
(lexical-let ((accu '()))
|
|
(xmtn--map-parsed-certs root revision-hash-id
|
|
(lambda (key signature name value trusted)
|
|
(push (list key signature name value trusted)
|
|
accu)))
|
|
(setq accu (nreverse accu))
|
|
accu))
|
|
|
|
(defun xmtn--heads (root branch)
|
|
;; apparently stdio automate doesn't default arguments properly;
|
|
;; this fails if branch is not passed to mtn.
|
|
(xmtn-automate-simple-command-output-lines root (list "heads"
|
|
(or branch
|
|
(xmtn--tree-default-branch root)))))
|
|
|
|
(defun xmtn--tree-default-branch (root)
|
|
(xmtn-automate-simple-command-output-line root `("get_option" "branch")))
|
|
|
|
|
|
(provide 'xmtn-automate)
|
|
|
|
;;; xmtn-automate.el ends here
|