updating from vcs
This commit is contained in:
Kai Tetzlaff
parent
36bade2cdc
commit
cd0a7d42a0
@ -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 <daniel.dehennin@baby-gnu.org> Fri, 29 Aug 2008 19:27:14 +0200
|
||||
-- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Sun, 06 Dec 2009 11:54:58 +0100
|
||||
|
||||
@ -1 +1 @@
|
||||
4
|
||||
7
|
||||
|
||||
@ -2,15 +2,15 @@ Source: dvc
|
||||
Section: devel
|
||||
Priority: optional
|
||||
Maintainer: Daniel Dehennin <daniel.dehennin@baby-gnu.org>
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 <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.)
|
||||
;; In the output buffer, the mtn stdio output header (<command
|
||||
;; number>:<err code>:<last?>:<size>:<data>) 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)))
|
||||
"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 key session xmtn-automate--*sessions*))
|
||||
session))
|
||||
(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)
|
||||
"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
|
||||
(xmtn--insert-buffer-substring-no-properties
|
||||
(xmtn-automate-command-buffer handle))))))
|
||||
(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
|
||||
(let* ((command-number
|
||||
(1- (incf (xmtn-automate--session-next-command-number
|
||||
session))))
|
||||
(session-number
|
||||
(1- (incf (xmtn-automate--session-next-session-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,7 +512,7 @@ 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
|
||||
(insert-buffer-substring-no-properties session-buffer
|
||||
read-marker
|
||||
end))
|
||||
(set-marker write-marker (point))))
|
||||
@ -802,7 +572,8 @@ 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
|
||||
(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))
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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)
|
||||
(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))))))
|
||||
,@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,7 +1081,6 @@ 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)
|
||||
|
||||
@ -1280,7 +1096,7 @@ finished."
|
||||
(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))))))))
|
||||
branch (length heads)))))))
|
||||
nil)
|
||||
|
||||
(defun xmtn-propagate-from (other &optional cached-branch)
|
||||
@ -1325,8 +1141,6 @@ 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
|
||||
@ -1336,7 +1150,7 @@ finished."
|
||||
(xmtn-dvc-log-message))
|
||||
:finished (lambda (output error status arguments)
|
||||
(if refresh-status
|
||||
(xmtn--refresh-status-header (current-buffer))))))))
|
||||
(xmtn--refresh-status-header (current-buffer)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun xmtn-dvc-merge (&optional other)
|
||||
@ -1410,7 +1224,6 @@ 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
|
||||
@ -1425,7 +1238,7 @@ finished."
|
||||
(let ((temp-dir nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq temp-dir (xmtn--make-temp-file
|
||||
(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
|
||||
@ -1440,7 +1253,7 @@ finished."
|
||||
(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)
|
||||
(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)))
|
||||
@ -1450,23 +1263,20 @@ finished."
|
||||
(with-current-buffer output-buffer
|
||||
(insert-buffer-substring input-buffer)))))))
|
||||
(when temp-dir
|
||||
(dvc-delete-recursively 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)
|
||||
(set-buffer-multibyte nil)
|
||||
(setq buffer-file-coding-system 'binary)
|
||||
(xmtn--insert-file-contents root file-id (current-buffer)))))
|
||||
(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)
|
||||
@ -1477,7 +1287,7 @@ finished."
|
||||
while stanza
|
||||
collect (xmtn-match stanza
|
||||
((("content_mark" (id $previous-id)))
|
||||
previous-id))))))))
|
||||
previous-id)))))))
|
||||
|
||||
(defun xmtn--limit-length (list n)
|
||||
(or (null n) (<= (length list) n)))
|
||||
@ -1499,7 +1309,6 @@ 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
|
||||
@ -1530,8 +1339,7 @@ finished."
|
||||
((local-tree $path) (error "Not implemented"))
|
||||
((revision $id) (changed-self-or-ancestors
|
||||
`(,id ,normalized-file))))
|
||||
last-n)))))
|
||||
|
||||
last-n))))
|
||||
|
||||
(defun xmtn--get-corresponding-path-raw (root normalized-file-name
|
||||
source-revision-hash-id
|
||||
@ -1553,7 +1361,6 @@ 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))
|
||||
@ -1599,7 +1406,7 @@ finished."
|
||||
target-revision-hash-id)))
|
||||
(if (null result)
|
||||
nil
|
||||
(funcall file-name-postprocessor result)))))))
|
||||
(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))
|
||||
|
||||
@ -217,9 +217,9 @@ 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))
|
||||
(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
|
||||
@ -231,7 +231,8 @@ must be a workspace."
|
||||
(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)
|
||||
|
||||
450
dvc/lisp/xmtn-multi-status.el
Normal file
450
dvc/lisp/xmtn-multi-status.el
Normal file
@ -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
|
||||
@ -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))))))
|
||||
(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))
|
||||
|
||||
@ -148,14 +148,13 @@ 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))
|
||||
(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)..."
|
||||
@ -219,7 +218,7 @@ arg; root. Result is of the form:
|
||||
:changelogs changelogs
|
||||
:tags tags
|
||||
:parent-hash-ids parent-hash-ids
|
||||
:child-hash-ids child-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)
|
||||
(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)))
|
||||
(xmtn--display-buffer-maybe buffer nil))
|
||||
nil)
|
||||
|
||||
;;;###autoload
|
||||
@ -293,8 +292,6 @@ 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
|
||||
@ -309,12 +306,11 @@ arg; root. Result is of the form:
|
||||
(concat
|
||||
"b:" ;; returns all revs for current branch
|
||||
(xmtn--escape-branch-name-for-selector
|
||||
branch)))))))
|
||||
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))
|
||||
@ -343,7 +339,7 @@ arg; root. Result is of the form:
|
||||
"%s revisions that are not in base revision:"
|
||||
(length difference)))))
|
||||
'()
|
||||
difference))))
|
||||
difference)))
|
||||
|
||||
(defun xmtn-revlist-show-conflicts ()
|
||||
"If point is on a revision that has two parents, show conflicts
|
||||
@ -459,7 +455,6 @@ 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)))
|
||||
@ -472,7 +467,7 @@ from the merge."
|
||||
(1 "1 head revision:")
|
||||
(t (format "%s head revisions: " head-count))))
|
||||
'()
|
||||
head-revision-hash-ids))))
|
||||
head-revision-hash-ids)))
|
||||
;; Passing nil as first-line-only-p, last-n is arbitrary here.
|
||||
nil nil))
|
||||
nil)
|
||||
@ -498,7 +493,6 @@ 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
|
||||
@ -511,7 +505,7 @@ to the base revision of the current tree."
|
||||
(format "Log for %s (last %d entries)" file dvc-revlist-last-n)
|
||||
(format "Log for %s" file)))
|
||||
'()
|
||||
revision-hash-ids))))
|
||||
revision-hash-ids)))
|
||||
first-line-only-p
|
||||
last-n))))
|
||||
|
||||
@ -530,7 +524,6 @@ 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)))
|
||||
@ -548,7 +541,7 @@ to the base revision of the current tree."
|
||||
(t (format "%s revisions matching selector: "
|
||||
count))))
|
||||
'()
|
||||
revision-hash-ids))))
|
||||
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,7 +553,6 @@ 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"))
|
||||
@ -580,8 +572,7 @@ to the base revision of the current tree."
|
||||
(declare (ignore key))
|
||||
(if (not trusted)
|
||||
(write-line "Untrusted cert, name=%s" name)
|
||||
(write-line "%s: %s" name value))))))))))))
|
||||
|
||||
(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
|
||||
|
||||
@ -43,23 +43,10 @@
|
||||
|
||||
(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
|
||||
(dvc-run-dvc-sync
|
||||
'xmtn
|
||||
`(,@xmtn-additional-arguments
|
||||
;; We don't pass the --root argument here; it is not
|
||||
@ -67,7 +54,7 @@
|
||||
;; confuses the Cygwin version of mtn when run with a
|
||||
;; non-Cygwin Emacs.
|
||||
,@arguments)
|
||||
dvc-run-keys)))))
|
||||
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,8 +67,6 @@
|
||||
(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
|
||||
@ -90,116 +75,13 @@
|
||||
;; 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))
|
||||
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
|
||||
@ -214,7 +96,7 @@
|
||||
(point)
|
||||
(progn (end-of-line) (point)))
|
||||
accu)
|
||||
(forward-line 1)))))))))
|
||||
(forward-line 1)))))))
|
||||
(setq accu (nreverse accu))
|
||||
accu))
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user