public/elisp-vcs
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

updating from vcs

Browse Source
This commit is contained in:
Kai Tetzlaff 2009-12-20 23:30:23 +01:00
parent 36bade2cdc
commit cd0a7d42a0
13 changed files with 1021 additions and 1314 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
dvc/debian/changelog
View File

@ -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

2
dvc/debian/compat
View File

@ -1 +1 @@
4
7

6
dvc/debian/control
View File

@ -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

3
dvc/debian/copyright
View File

@ -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

449
dvc/lisp/xmtn-automate.el
View File

@ -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)))
(setq xmtn-automate--*sessions*
(acons key session xmtn-automate--*sessions*))
session))
"If necessary, create a mtn automate session for workspace
ROOT, store it in session cache. Return session."
;; we require an explicit root argument here, rather than relying on
;; default-directory, because one application is to create several
;; sessions for several workspaces, and operate on them as a group
;; (see xmtn-multi-status.el, for example).
(let* ((default-directory (dvc-uniquify-file-name root))
(session (xmtn-automate-get-cached-session default-directory)))
(or session
(progn
(setq session (xmtn-automate--make-session default-directory default-directory))
(setq xmtn-automate--*sessions*
(acons default-directory session xmtn-automate--*sessions*))
session))))
(defun xmtn-automate-get-cached-session (key)
"Return a session from the cache, or nil."
;; separate function so we can debug it
"Return a session from the cache, or nil. KEY is uniquified
workspace root."
(cdr (assoc key xmtn-automate--*sessions*)))
(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key)
&body body)
"Call BODY, after ensuring an automate session for ROOT-FORM is active."
(declare (indent 1) (debug (sexp body)))
;; I would prefer to factor out a function
;; `xmtn-automate--call-with-session' here, but that would make
;; profiler output unreadable, since every function would only
;; appear to call `xmtn-automate--call-with-session', and that
;; function would appear to do all computation.
;;
;; mtn automate stdio requires a valid database, so we require a
;; root directory here.
(let ((session (gensym))
(session-var (or session-var-or-null (gensym)))
(root (gensym))
(key (gensym))
(thunk (gensym)))
`(let* ((,root (file-name-as-directory ,root-form))
(,key (file-truename ,root))
(,session (xmtn-automate-get-cached-session ,key))
(,thunk (lambda ()
(let ((,session-var ,session))
,@body))))
(if ,session
(funcall ,thunk)
(unwind-protect
(progn
(setq ,session (xmtn-automate--make-session ,root ,key))
(let ((xmtn-automate--*sessions*
;; note the let-binding here; these sessions are _not_
;; available for later commands. use
;; xmtn-automate-cache-session to get a persistent
;; session.
(acons ,key ,session xmtn-automate--*sessions*)))
(funcall ,thunk)))
(when ,session (xmtn-automate--close-session ,session)))))))
(defmacro* xmtn-automate-with-command ((handle-var session-form command-form
&key ((:may-kill-p
may-kill-p-form)))
&body body)
"Send COMMAND_FORM (a list of strings, or cons of lists of
strings) to session SESSION_FORM (current if nil). If car
COMMAND_FORM is a list, car COMMAND_FORM is options, cdr is command.
Then execute BODY."
(declare (indent 1) (debug (sexp body)))
(let ((session (gensym))
(command (gensym))
(may-kill-p (gensym))
(handle (gensym)))
`(let ((,session ,session-form)
(,command ,command-form)
(,may-kill-p ,may-kill-p-form)
(,handle nil))
(unwind-protect
(progn
(setq ,handle (xmtn-automate--new-command ,session
,command
,may-kill-p))
(xmtn--assert-optional (xmtn-automate--command-handle-p ,handle))
(let ((,handle-var ,handle))
,@body))
(when ,handle
(xmtn-automate--cleanup-command ,handle))))))
(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle)
(xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle)
(buffer-substring-no-properties (point-min) (point-max))))
(prog1
(buffer-substring-no-properties (point-min) (point-max))
(xmtn-automate--cleanup-command handle))))
(defun xmtn-automate-command-check-for-and-report-error (handle)
(unless (eql (xmtn-automate-command-error-code handle) 0)
@ -351,30 +163,27 @@ Then execute BODY."
nil)
(defun xmtn-automate-simple-command-output-string (root command)
"Send COMMAND (a list of strings, or cons of lists of strings)
to current session. If car COMMAND is a list, car COMMAND is
options, cdr is command. Return result as a string."
(xmtn-automate-with-session (session root)
(xmtn-automate-with-command (handle session command)
(xmtn-automate-command-check-for-and-report-error handle)
(xmtn-automate--command-output-as-string-ignoring-exit-code handle))))
"Send COMMAND to session for ROOT. Return result as a string."
(let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil)))
(xmtn-automate-command-check-for-and-report-error command-handle)
(xmtn-automate--command-output-as-string-ignoring-exit-code command-handle)))
(defun xmtn-automate-simple-command-output-insert-into-buffer
(root buffer command)
"Send COMMAND (a list of strings, or cons of lists of strings)
to current session. If car COMMAND is a list, car COMMAND is
options, cdr is command. Insert result into BUFFER."
(xmtn-automate-with-session (session root)
(xmtn-automate-with-command (handle session command)
(xmtn-automate-command-check-for-and-report-error handle)
(xmtn-automate-command-wait-until-finished handle)
(with-current-buffer buffer
(xmtn--insert-buffer-substring-no-properties
(xmtn-automate-command-buffer handle))))))
"Send COMMAND to session for ROOT, insert result into BUFFER."
(let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil)))
(xmtn-automate-command-check-for-and-report-error command-handle)
(xmtn-automate-command-wait-until-finished command-handle)
(with-current-buffer buffer
(insert-buffer-substring-no-properties
(xmtn-automate-command-buffer command-handle)))
(xmtn-automate--cleanup-command command-handle)))
(defun xmtn-automate-command-output-lines (handle)
;; Return list of lines of output; first line output is first in
;; list.
"Return list of lines of output in HANDLE; first line output is
first in list."
(xmtn-automate-command-check-for-and-report-error handle)
(xmtn-automate-command-wait-until-finished handle)
(save-excursion
@ -387,16 +196,16 @@ options, cdr is command. Insert result into BUFFER."
(progn (end-of-line) (point)))
result))
(forward-line 1))
(xmtn-automate--cleanup-command handle)
(nreverse result))))
(defun xmtn-automate-simple-command-output-lines (root command)
"Return list of strings containing output of COMMAND, one line per string."
(xmtn-automate-with-session (session root)
(xmtn-automate-with-command (handle session command)
(xmtn-automate-command-output-lines handle))))
"Return list of strings containing output of COMMAND, one line per
string."
(let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil)))
(xmtn-automate-command-output-lines command-handle)))
;; This one is used twice. I think the error checking it provides is
;; a reasonable simplification for its callers.
(defun xmtn-automate-simple-command-output-line (root command)
"Return the one line output from mtn automate as a string.
@ -409,19 +218,11 @@ Signals an error if output contains zero lines or more than one line."
command))
(first lines)))
(defun xmtn-automate--set-process-session (process session)
(xmtn--assert-optional (typep session 'xmtn-automate--session) t)
(xmtn--process-put process 'xmtn-automate--session session))
(process-put process 'xmtn-automate--session session))
(defun xmtn-automate--process-session (process)
(xmtn--assert-optional (processp process) t)
(let ((session (xmtn--process-get process 'xmtn-automate--session)))
;; This seems to fail sometimes with session being nil. Not sure
;; why. The problem seems to be reproducible by calling
;; (dvc-dvc-revision-nth-ancestor `(xmtn (local-tree ,(dvc-tree-root))) 10).
(xmtn--assert-optional (typep session 'xmtn-automate--session) t)
session))
(process-get process 'xmtn-automate--session))
(defstruct (xmtn-automate--decoder-state
(:constructor xmtn-automate--%make-raw-decoder-state))
@ -437,8 +238,7 @@ Signals an error if output contains zero lines or more than one line."
(buffer nil)
(process nil)
(decoder-state)
(next-mtn-command-number)
(next-session-command-number 0)
(next-command-number 0)
(must-not-kill-counter)
(remaining-command-handles)
(sent-kill-p)
@ -492,6 +292,7 @@ Signals an error if output contains zero lines or more than one line."
nil)
(defun xmtn-automate--close-session (session)
"Kill session process, buffer."
(setf (xmtn-automate--session-closed-p session) t)
(let ((process (xmtn-automate--session-process session)))
(cond
@ -537,9 +338,8 @@ Signals an error if output contains zero lines or more than one line."
(let ((process-connection-type nil)
(default-directory root))
(let ((process
(xmtn--with-environment-for-subprocess ()
(apply #'start-process name buffer xmtn-executable
"automate" "stdio" xmtn-additional-arguments))))
(apply 'start-process name buffer xmtn-executable
"automate" "stdio" xmtn-additional-arguments)))
(xmtn-automate--set-process-session process session)
(set-process-filter process 'xmtn-automate--process-filter)
(set-process-sentinel process 'xmtn-automate--process-sentinel)
@ -555,13 +355,13 @@ Signals an error if output contains zero lines or more than one line."
(xmtn--assert-optional (eql (point-min) (point)) t)
(set-marker (make-marker)
(point-min)))))
(setf (xmtn-automate--session-next-mtn-command-number session) 0)
(setf (xmtn-automate--session-must-not-kill-counter session) 0)
(setf (xmtn-automate--session-remaining-command-handles session) (list))
(setf (xmtn-automate--session-sent-kill-p session) nil)
process))))
(defun xmtn-automate--ensure-process (session)
"Ensure SESSION has an active process; restart it if it died."
(let ((process (xmtn-automate--session-process session)))
(when (or (null process)
(ecase (process-status process)
@ -575,33 +375,16 @@ Signals an error if output contains zero lines or more than one line."
process))
(defun xmtn-automate--new-buffer (session)
(let* ((buffer-base-name (format "*%s: session*"
(let* ((buffer-base-name (format " *%s: session*"
(xmtn-automate--session-name session)))
(buffer (generate-new-buffer buffer-base-name)))
(with-current-buffer buffer
(buffer-disable-undo)
(xmtn--set-buffer-multibyte nil)
(set-buffer-multibyte nil)
(setq buffer-read-only t))
(setf (xmtn-automate--session-buffer session) buffer)
buffer))
(defun xmtn-automate-terminate-processes-in-root (root)
(xmtn-automate-with-session (session root)
(xmtn-automate--close-session session)
(let ((process (xmtn-automate--session-process session)))
(when process
(while (ecase (process-status process)
(run t)
(exit nil)
(signal nil))
(accept-process-output process))
(dvc-trace "Process in root %s terminated" root)
))
(xmtn-automate--initialize-session
session
:root (xmtn-automate--session-root session)
:name (xmtn-automate--session-name session))))
(defun xmtn-automate--append-encoded-strings (strings)
"Encode STRINGS (a list of strings or nil) in automate stdio format,
insert into current buffer. Assumes that point is at the end of
@ -616,12 +399,10 @@ the buffer."
(goto-char (point-max)))))
nil)
(defun xmtn-automate--send-command-string (session command option-plist
mtn-number session-number)
(defun xmtn-automate--send-command-string (session command option-plist session-number)
"Send COMMAND and OPTION-PLIST to SESSION."
(let* ((buffer-name (format "*%s: input for command %s(%s)*"
(let* ((buffer-name (format "*%s: input for command %s*"
(xmtn-automate--session-name session)
mtn-number
session-number))
(buffer nil))
(unwind-protect
@ -635,7 +416,7 @@ the buffer."
(setq buffer (get-buffer-create buffer-name))
(with-current-buffer buffer
(buffer-disable-undo)
(xmtn--set-buffer-multibyte t)
(set-buffer-multibyte t)
(setq buffer-read-only t)
(let ((inhibit-read-only t))
(when option-plist
@ -655,22 +436,14 @@ the buffer."
(kill-buffer buffer))))))
(defun xmtn-automate--new-command (session command may-kill-p)
"Send COMMAND (a list of strings, or cons of lists of strings)
to the current automate stdio session. If car COMMAND is a list,
car COMMAND is options, cdr is command."
;; For debugging.
;;(xmtn-automate-terminate-processes-in-root
;; (xmtn-automate--session-root session))
"Send COMMAND to SESSION."
(xmtn-automate--ensure-process session)
(let* ((mtn-number (1- (incf (xmtn-automate--session-next-mtn-command-number
session))))
(session-number
(1- (incf (xmtn-automate--session-next-session-command-number
(let* ((command-number
(1- (incf (xmtn-automate--session-next-command-number
session))))
(buffer-name (format "*%s: output for command %s(%s)*"
(buffer-name (format " *%s: output for command %s*"
(xmtn-automate--session-name session)
mtn-number
session-number))
command-number))
(buffer
(progn (when (get-buffer buffer-name)
;; Make sure no local variables or mode changes
@ -681,21 +454,18 @@ car COMMAND is options, cdr is command."
(fundamental-mode)))
(get-buffer-create buffer-name))))
(if (not (listp (car command)))
(xmtn-automate--send-command-string session command '()
mtn-number session-number)
(xmtn-automate--send-command-string session (cdr command) (car command)
mtn-number session-number))
(xmtn-automate--send-command-string session command '() command-number)
(xmtn-automate--send-command-string session (cdr command) (car command) command-number))
(with-current-buffer buffer
(buffer-disable-undo)
(xmtn--set-buffer-multibyte nil)
(set-buffer-multibyte nil)
(setq buffer-read-only t)
(xmtn--assert-optional (and (eql (point) (point-min))
(eql (point) (point-max))))
(let ((handle (xmtn-automate--%make-raw-command-handle
:session session
:arguments command
:mtn-command-number mtn-number
:session-command-number session-number
:session-command-number command-number
:may-kill-p may-kill-p
:buffer buffer
:write-marker (set-marker (make-marker) (point)))))
@ -742,9 +512,9 @@ car COMMAND is options, cdr is command."
(goto-char write-marker)
(let ((inhibit-read-only t)
deactivate-mark)
(xmtn--insert-buffer-substring-no-properties session-buffer
read-marker
end))
(insert-buffer-substring-no-properties session-buffer
read-marker
end))
(set-marker write-marker (point))))
;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil)
)
@ -802,8 +572,9 @@ car COMMAND is options, cdr is command."
(xmtn-automate--decoder-state-last-p state))
(xmtn--assert-optional command)
(setf (xmtn-automate--command-handle-finished-p command) t)
(xmtn--with-no-warnings
(pop (xmtn-automate--session-remaining-command-handles session)))
(with-no-warnings
;; discard result
(pop (xmtn-automate--session-remaining-command-handles session)))
(setq tag 'check-for-more)
(when (not (xmtn-automate--command-handle-may-kill-p command))
(when (zerop (decf (xmtn-automate--session-must-not-kill-counter
@ -919,7 +690,7 @@ car COMMAND is options, cdr is command."
(message "Process %s died due to signal" (process-name process))
(when (not (zerop (xmtn-automate--session-must-not-kill-counter
session)))
(xmtn--lwarn
(lwarn
'xmtn ':error
"Process %s died due to signal during a critical operation"
(process-name process))))))))))
@ -1007,6 +778,18 @@ Each element of the list is a list; key, signature, name, value, trust."
(defun xmtn--tree-default-branch (root)
(xmtn-automate-simple-command-output-line root `("get_option" "branch")))
(defun xmtn-automate-local-changes (work)
"Summary of status for WORK; 'ok if no changes, 'need-commit if changes."
(message "checking %s for local changes" work)
(let ((default-directory work))
(let ((result (xmtn-automate-simple-command-output-string
default-directory
(list (list "no-unchanged" "no-ignored")
"inventory"))))
(if (> (length result) 0)
'need-commit
'ok))))
(provide 'xmtn-automate)

80
dvc/lisp/xmtn-compat.el
View File

@ -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

4
dvc/lisp/xmtn-conflicts.el
View File

@ -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 ()

614
dvc/lisp/xmtn-dvc.el
View File

@ -83,16 +83,14 @@
`(let ((,root ,root-form)
(,command ,command-form)
(,may-kill-p ,may-kill-p-form))
(xmtn-automate-with-session (,session ,root)
(xmtn-automate-with-command (,handle
,session ,command
:may-kill-p ,may-kill-p)
(xmtn-automate-command-check-for-and-report-error ,handle)
(xmtn-automate-command-wait-until-finished ,handle)
(xmtn-basic-io-with-stanza-parser (,parser
(xmtn-automate-command-buffer
,handle))
,@body))))))
(let* ((,session (xmtn-automate-cache-session ,root))
(,handle (xmtn-automate--new-command ,session ,command ,may-kill-p)))
(xmtn-automate-command-check-for-and-report-error ,handle)
(xmtn-automate-command-wait-until-finished ,handle)
(xmtn-basic-io-with-stanza-parser (,parser
(xmtn-automate-command-buffer
,handle))
,@body)))))
;;;###autoload
(defun xmtn-dvc-log-edit-file-name-func (&optional root)
@ -104,154 +102,6 @@
`("toposort"
,@revision-hash-ids)))
(defun xmtn--insert-log-edit-hints (root branch buffer prefix normalized-files)
(with-current-buffer buffer
(flet ((insert-line (&optional format-string-or-null &rest format-args)
(if format-string-or-null
(let ((line (apply #'format
format-string-or-null format-args)))
(assert (not (position ?\n line)))
(insert prefix line ?\n))
(assert (endp format-args))
(insert prefix ?\n))))
(save-excursion
;; Launching these mtn processes in parallel is a noticeable
;; speedup (~14% on some informal benchmarks). At least it
;; was with the version that I benchmarked, etc.
(xmtn-automate-with-session (nil root)
(let* ((unknown-future (xmtn--unknown-files-future root))
(missing-future (xmtn--missing-files-future root))
(consistent-p-future (xmtn--tree-consistent-p-future root))
(heads (xmtn--heads root branch))
(inconsistent-p (not (funcall consistent-p-future)))
(revision (if inconsistent-p
nil
(xmtn--get-revision root `(local-tree ,root))))
(missing (funcall missing-future)))
(when inconsistent-p
(insert-line
"WARNING: Tree is not consistent.")
(insert-line "Commit will fail unless you fix this first.")
(insert-line))
(when missing
(insert-line "%s missing file(s):" (length missing))
(dolist (file missing) (insert-line "%s" file))
(insert-line)
(insert-line))
(insert-line "Committing on branch:")
(insert-line branch)
(insert-line)
(unless
(let* ((parents (xmtn--revision-old-revision-hash-ids revision))
(all-parents-are-heads-p
(subsetp parents heads :test #'equal))
(all-heads-are-parents-p
(subsetp heads parents :test #'equal)))
(cond ((and (not all-heads-are-parents-p)
(not all-parents-are-heads-p))
(insert-line "This commit will create divergence.")
(insert-line))
((not all-heads-are-parents-p)
(insert-line (concat "Divergence will continue to exist"
" after this commit."))
(insert-line))
(t
(progn)))))
(case normalized-files
(all
(insert-line "All files selected for commit."))
(t
(insert-line "File(s) selected for commit:")
;; Normalized file names are easier to read when coming
;; from dired buffer, since otherwise, they would contain
;; the entire path.
(dolist (file
;; Sort in an attempt to match the order of
;; "patch" lines, below.
(sort (copy-list normalized-files) #'string<))
(insert-line "%s" file))))
;; Due to the possibility of race conditions, this check
;; doesn't guarantee the operation will succeed.
(if inconsistent-p
;; FIXME: Since automate get_revision can't deal with
;; inconsistent workspaces, we should be using
;; automate inventory instead.
(progn (insert-line)
(insert-line
(concat "Unable to compute modified files while"
" the tree is inconsistent.")))
(let ((committed-changes (list))
(other-changes (list)))
(flet ((collect (path message)
(if (or (eql normalized-files 'all)
(member path normalized-files))
(push message committed-changes)
(push message other-changes))))
(loop
for (path) in (xmtn--revision-delete revision)
do (collect path (format "delete %s" path)))
(loop
for (from to) in (xmtn--revision-rename revision)
;; FIXME: collect from or collect to? Monotone
;; doesn't specify how restrictions work for
;; renamings.
do (collect to (format "rename %s to %s" from to)))
(loop
for (path) in (xmtn--revision-add-dir revision)
do (collect path (format "add_dir %s" path)))
(loop
for (path contents)
in (xmtn--revision-add-file revision)
do (collect path (format "add_file %s" path)))
(loop
for (path from-contents to-contents)
in (xmtn--revision-patch-file revision)
do (collect path (format "patch %s" path)))
(loop
for (path attr-name)
in (xmtn--revision-clear-attr revision)
do (collect path (format "clear %s %s"
path attr-name)))
(loop
for (path attr-name attr-value)
in (xmtn--revision-set-attr revision)
do (collect path (format "set %s %s %s"
path attr-name attr-value))))
(setq committed-changes (nreverse committed-changes))
(setq other-changes (nreverse other-changes))
(loop
for (lines heading-if heading-if-not) in
`((,committed-changes
,(format "%s change(s) in selected files:"
(length committed-changes))
"No changes in selected files.")
(,other-changes
,(format
"%s change(s) in files not selected for commit:"
(length other-changes))
"No changes in files not selected for commit."))
do
(insert-line)
(insert-line "%s" (if lines heading-if heading-if-not))
(dolist (line lines) (insert-line "%s" line)))))
(let ((unknown (funcall unknown-future)))
(insert-line)
(if (endp unknown)
(insert-line "No unknown files.")
(insert-line "%s unknown file(s):" (length unknown))
(dolist (file unknown) (insert-line "%s" file))))))))
(cond ((eql (point) (point-min))
;; We take this as an indicator that there is no log message
;; yet. So insert a blank line.
(insert "\n")
(goto-char (point-min)))
(t
;; Moving up onto the last line of the log message seems to
;; be better than having the cursor sit at the ## prefix of
;; the first line of our hints.
(forward-line -1))))
nil)
(add-to-list 'format-alist
'(xmtn--log-file
"This format automatically removes xmtn's log edit hints from
@ -670,18 +520,6 @@ otherwise newer."
(setq xmtn-dvc-automate-version
(string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))
(defun xmtn--unknown-files-future (root)
(xmtn--command-output-lines-future root '("ls" "unknown")))
(defun xmtn--missing-files-future (root)
(xmtn--command-output-lines-future root '("ls" "missing")))
(defun xmtn--tree-consistent-p-future (root)
;; FIXME: Should also check for file/dir mismatches.
(lexical-let ((missing-files-future (xmtn--missing-files-future root)))
(lambda ()
(null (funcall missing-files-future)))))
(defun xmtn--changes-image (change)
(ecase change
(content "content")
@ -1073,20 +911,6 @@ otherwise newer."
(xmtn--run-command-sync root
`("add" "--" ,@file-names)))
(defun xmtn--file-registered-p (root file-name)
;; FIXME: need a better way to implement this
(let ((normalized-file-name (xmtn--normalize-file-name root file-name)))
(block parse
(xmtn--with-automate-command-output-basic-io-parser
(parser root `("inventory"))
(xmtn--parse-inventory parser
(lambda (path status changes old-path new-path
old-type new-type fs-type)
(when (equal normalized-file-name path)
(return-from parse
t)))))
nil)))
;;;###autoload
(defun xmtn-dvc-add-files (&rest files)
(xmtn--add-files (dvc-tree-root) files))
@ -1214,13 +1038,6 @@ finished."
nil)
nil)
(defun xmtn--do-disapprove-future (root revision-hash-id)
;; Returns a future so the calling code can block on its completion
;; if it wants to.
(check-type root string)
(check-type revision-hash-id xmtn--hash-id)
(xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id)))
(defun xmtn--do-update (root target-revision-hash-id post-update-p)
(check-type root string)
(check-type target-revision-hash-id xmtn--hash-id)
@ -1264,23 +1081,22 @@ finished."
;;;###autoload
(defun xmtn-dvc-update (&optional revision-id no-ding)
(let ((root (dvc-tree-root)))
(xmtn-automate-with-session (nil root)
(if revision-id
(xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
(if revision-id
(xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
(let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch)))
(case (length heads)
(0 (assert nil))
(1
(xmtn--update root (first heads) t no-ding))
(let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch)))
(case (length heads)
(0 (assert nil))
(1
(xmtn--update root (first heads) t no-ding))
(t
;; User can choose one head from a revlist, or merge them.
(error (substitute-command-keys
(concat "Branch %s is unmerged (%s heads)."
" Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
branch (length heads))))))))
(t
;; User can choose one head from a revlist, or merge them.
(error (substitute-command-keys
(concat "Branch %s is unmerged (%s heads)."
" Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
branch (length heads)))))))
nil)
(defun xmtn-propagate-from (other &optional cached-branch)
@ -1325,18 +1141,16 @@ finished."
(defun xmtn-dvc-merge-1 (root refresh-status)
(lexical-let ((refresh-status refresh-status))
(xmtn-automate-with-session
(nil root)
(xmtn--run-command-async
root
(list
"merge"
(if (file-exists-p (concat root "/_MTN/conflicts"))
"--resolve-conflicts-file=_MTN/conflicts")
(xmtn-dvc-log-message))
:finished (lambda (output error status arguments)
(if refresh-status
(xmtn--refresh-status-header (current-buffer))))))))
(xmtn--run-command-async
root
(list
"merge"
(if (file-exists-p (concat root "/_MTN/conflicts"))
"--resolve-conflicts-file=_MTN/conflicts")
(xmtn-dvc-log-message))
:finished (lambda (output error status arguments)
(if refresh-status
(xmtn--refresh-status-header (current-buffer)))))))
;;;###autoload
(defun xmtn-dvc-merge (&optional other)
@ -1410,74 +1224,70 @@ finished."
(defun xmtn--revision-get-file-helper (file backend-id)
"Fill current buffer with the contents of FILE revision BACKEND-ID."
(let ((root (dvc-tree-root)))
(xmtn-automate-with-session (nil root)
(let* ((normalized-file (xmtn--normalize-file-name root file))
(corresponding-file
(xmtn--get-corresponding-path root normalized-file
`(local-tree ,root) backend-id)))
(if (null corresponding-file)
;; File doesn't exist. Since this function is (as far
;; as I know) only called from diff-like functions, a
;; missing file is not an error but just means the diff
;; should be computed against an empty file. So just
;; leave the buffer empty.
(progn)
(let ((temp-dir nil))
(unwind-protect
(progn
(setq temp-dir (xmtn--make-temp-file
"xmtn--revision-get-file-" t))
;; Going through a temporary file and using
;; `insert-file-contents' in conjunction with as
;; much of the original file name as possible seems
;; to be the best way to make sure that Emacs'
;; entire file coding system detection logic is
;; applied. Functions like
;; `find-operation-coding-system' and
;; `find-file-name-handler' are not a complete
;; replacement since they don't look at the contents
;; at all.
(let ((temp-file (concat temp-dir "/" corresponding-file)))
(make-directory (file-name-directory temp-file) t)
(with-temp-file temp-file
(xmtn--set-buffer-multibyte nil)
(setq buffer-file-coding-system 'binary)
(xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
(let ((output-buffer (current-buffer)))
(with-temp-buffer
(insert-file-contents temp-file)
(let ((input-buffer (current-buffer)))
(with-current-buffer output-buffer
(insert-buffer-substring input-buffer)))))))
(when temp-dir
(dvc-delete-recursively temp-dir)))))))))
(let* ((normalized-file (xmtn--normalize-file-name root file))
(corresponding-file
(xmtn--get-corresponding-path root normalized-file
`(local-tree ,root) backend-id)))
(if (null corresponding-file)
;; File doesn't exist. Since this function is (as far
;; as I know) only called from diff-like functions, a
;; missing file is not an error but just means the diff
;; should be computed against an empty file. So just
;; leave the buffer empty.
(progn)
(let ((temp-dir nil))
(unwind-protect
(progn
(setq temp-dir (make-temp-file
"xmtn--revision-get-file-" t))
;; Going through a temporary file and using
;; `insert-file-contents' in conjunction with as
;; much of the original file name as possible seems
;; to be the best way to make sure that Emacs'
;; entire file coding system detection logic is
;; applied. Functions like
;; `find-operation-coding-system' and
;; `find-file-name-handler' are not a complete
;; replacement since they don't look at the contents
;; at all.
(let ((temp-file (concat temp-dir "/" corresponding-file)))
(make-directory (file-name-directory temp-file) t)
(with-temp-file temp-file
(set-buffer-multibyte nil)
(setq buffer-file-coding-system 'binary)
(xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
(let ((output-buffer (current-buffer)))
(with-temp-buffer
(insert-file-contents temp-file)
(let ((input-buffer (current-buffer)))
(with-current-buffer output-buffer
(insert-buffer-substring input-buffer)))))))
(when temp-dir
(dvc-delete-recursively temp-dir))))))))
(defun xmtn--get-file-by-id (root file-id save-as)
"Store contents of FILE-ID in file SAVE-AS."
(xmtn-automate-with-session
(nil root)
(with-temp-file save-as
(xmtn--set-buffer-multibyte nil)
(setq buffer-file-coding-system 'binary)
(xmtn--insert-file-contents root file-id (current-buffer)))))
(with-temp-file save-as
(set-buffer-multibyte nil)
(setq buffer-file-coding-system 'binary)
(xmtn--insert-file-contents root file-id (current-buffer))))
(defun xmtn--revision-parents (root revision-hash-id)
(xmtn-automate-simple-command-output-lines root
`("parents" ,revision-hash-id)))
(defun xmtn--get-content-changed (root backend-id normalized-file)
(xmtn-automate-with-session (nil root)
(xmtn-match (xmtn--resolve-backend-id root backend-id)
((local-tree $path) (error "Not implemented"))
((revision $revision-hash-id)
(xmtn--with-automate-command-output-basic-io-parser
(parser root `("get_content_changed" ,revision-hash-id
,normalized-file))
(loop for stanza = (funcall parser)
while stanza
collect (xmtn-match stanza
((("content_mark" (id $previous-id)))
previous-id))))))))
(xmtn-match (xmtn--resolve-backend-id root backend-id)
((local-tree $path) (error "Not implemented"))
((revision $revision-hash-id)
(xmtn--with-automate-command-output-basic-io-parser
(parser root `("get_content_changed" ,revision-hash-id
,normalized-file))
(loop for stanza = (funcall parser)
while stanza
collect (xmtn-match stanza
((("content_mark" (id $previous-id)))
previous-id)))))))
(defun xmtn--limit-length (list n)
(or (null n) (<= (length list) n)))
@ -1499,39 +1309,37 @@ finished."
current-set))
(defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n)
(xmtn-automate-with-session (nil root)
(lexical-let ((root root))
(labels ((changed-self-or-ancestors (entry)
(destructuring-bind (hash-id file-name) entry
(check-type file-name string)
;; get-content-changed can return one or two revisions
(loop for next-change-id in (xmtn--get-content-changed
root `(revision ,hash-id)
file-name)
for corresponding-path =
(xmtn--get-corresponding-path-raw root file-name
hash-id next-change-id)
when corresponding-path
collect `(,next-change-id ,corresponding-path))))
(changed-proper-ancestors (entry)
(destructuring-bind (hash-id file-name) entry
(check-type file-name string)
;; revision-parents can return one or two revisions
(loop for parent-id in (xmtn--revision-parents root hash-id)
for path-in-parent =
(xmtn--get-corresponding-path-raw root file-name
hash-id parent-id)
when path-in-parent
append (changed-self-or-ancestors
`(,parent-id ,path-in-parent))))))
(xmtn--close-set
#'changed-proper-ancestors
(xmtn-match (xmtn--resolve-backend-id root backend-id)
((local-tree $path) (error "Not implemented"))
((revision $id) (changed-self-or-ancestors
`(,id ,normalized-file))))
last-n)))))
(lexical-let ((root root))
(labels ((changed-self-or-ancestors (entry)
(destructuring-bind (hash-id file-name) entry
(check-type file-name string)
;; get-content-changed can return one or two revisions
(loop for next-change-id in (xmtn--get-content-changed
root `(revision ,hash-id)
file-name)
for corresponding-path =
(xmtn--get-corresponding-path-raw root file-name
hash-id next-change-id)
when corresponding-path
collect `(,next-change-id ,corresponding-path))))
(changed-proper-ancestors (entry)
(destructuring-bind (hash-id file-name) entry
(check-type file-name string)
;; revision-parents can return one or two revisions
(loop for parent-id in (xmtn--revision-parents root hash-id)
for path-in-parent =
(xmtn--get-corresponding-path-raw root file-name
hash-id parent-id)
when path-in-parent
append (changed-self-or-ancestors
`(,parent-id ,path-in-parent))))))
(xmtn--close-set
#'changed-proper-ancestors
(xmtn-match (xmtn--resolve-backend-id root backend-id)
((local-tree $path) (error "Not implemented"))
((revision $id) (changed-self-or-ancestors
`(,id ,normalized-file))))
last-n))))
(defun xmtn--get-corresponding-path-raw (root normalized-file-name
source-revision-hash-id
@ -1553,53 +1361,52 @@ finished."
source-revision-backend-id
target-revision-backend-id)
(block get-corresponding-path
(xmtn-automate-with-session (nil root)
(let (source-revision-hash-id
target-revision-hash-id
(file-name-postprocessor #'identity))
(let ((resolved-source-revision
(xmtn--resolve-backend-id root source-revision-backend-id))
(resolved-target-revision
(xmtn--resolve-backend-id root target-revision-backend-id)))
(xmtn-match resolved-source-revision
((revision $hash-id)
(setq source-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
(xmtn-match resolved-target-revision
((revision $hash-id)
(return-from get-corresponding-path nil))
((local-tree $target-path)
(assert (xmtn--same-tree-p path target-path))
(return-from get-corresponding-path normalized-file-name)))
(setq normalized-file-name (xmtn--get-rename-in-workspace-to
path normalized-file-name))
(setq source-revision-hash-id base-revision-hash-id)))))
(xmtn-match resolved-target-revision
((revision $hash-id)
(setq target-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
(return-from get-corresponding-path nil)
(setq target-revision-hash-id base-revision-hash-id
file-name-postprocessor
(lexical-let ((path path))
(lambda (file-name)
(xmtn--get-rename-in-workspace-from path
file-name)))))))))
(let ((result
(xmtn--get-corresponding-path-raw root normalized-file-name
source-revision-hash-id
target-revision-hash-id)))
(if (null result)
nil
(funcall file-name-postprocessor result)))))))
(let (source-revision-hash-id
target-revision-hash-id
(file-name-postprocessor #'identity))
(let ((resolved-source-revision
(xmtn--resolve-backend-id root source-revision-backend-id))
(resolved-target-revision
(xmtn--resolve-backend-id root target-revision-backend-id)))
(xmtn-match resolved-source-revision
((revision $hash-id)
(setq source-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
(xmtn-match resolved-target-revision
((revision $hash-id)
(return-from get-corresponding-path nil))
((local-tree $target-path)
(assert (xmtn--same-tree-p path target-path))
(return-from get-corresponding-path normalized-file-name)))
(setq normalized-file-name (xmtn--get-rename-in-workspace-to
path normalized-file-name))
(setq source-revision-hash-id base-revision-hash-id)))))
(xmtn-match resolved-target-revision
((revision $hash-id)
(setq target-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
(return-from get-corresponding-path nil)
(setq target-revision-hash-id base-revision-hash-id
file-name-postprocessor
(lexical-let ((path path))
(lambda (file-name)
(xmtn--get-rename-in-workspace-from path
file-name)))))))))
(let ((result
(xmtn--get-corresponding-path-raw root normalized-file-name
source-revision-hash-id
target-revision-hash-id)))
(if (null result)
nil
(funcall file-name-postprocessor result))))))
(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)
;; FIXME: need a better way to implement this
@ -1632,25 +1439,6 @@ finished."
old-path)))))
normalized-target-file-name))
(defun xmtn--manifest-find-file (root manifest normalized-file-name)
(let ((matches (remove* normalized-file-name
(remove* 'file manifest :key #'first :test-not #'equal)
:key #'second :test-not #'equal)))
(xmtn--assert-optional (member (length matches) '(0 1)))
(first matches)))
(defun xmtn--revision-manifest-file-entry (root backend-id
normalized-file-name)
(let ((manifest (xmtn--get-manifest root backend-id)))
(xmtn--manifest-find-file root manifest normalized-file-name)))
(defun xmtn--revision-file-contents-hash (root backend-id normalized-file-name)
(xmtn-match (xmtn--revision-manifest-file-entry root backend-id
normalized-file-name)
((file $relative-path $file-contents-hash $attrs)
(assert (equal relative-path normalized-file-name))
file-contents-hash)))
(defun xmtn--file-contents-as-string (root content-hash-id)
(check-type content-hash-id xmtn--hash-id)
(xmtn-automate-simple-command-output-string
@ -1674,51 +1462,6 @@ finished."
(defun xmtn--same-tree-p (a b)
(equal (file-truename a) (file-truename b)))
(defun xmtn--get-manifest (root backend-id)
(xmtn-automate-with-session (nil root)
(let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
(xmtn--with-automate-command-output-basic-io-parser
(parser root `("get_manifest_of"
,@(xmtn-match resolved-id
((local-tree $path)
;; FIXME: I don't really know what to do if
;; PATH is not the same as ROOT. Maybe
;; revision id resolution needs to return
;; the proper root, too.
(assert (xmtn--same-tree-p root path))
(unless (funcall
(xmtn--tree-consistent-p-future root))
(error "Tree is inconsistent, unable to get manifest"))
'())
((revision $hash-id)
`(,hash-id)))))
(assert (equal (funcall parser) '(("format_version" (string "1")))))
(loop for stanza = (funcall parser)
while stanza
collect (xmtn-match stanza
((("dir" (string $normalized-path)))
(let ((dir (decode-coding-string
normalized-path
'xmtn--monotone-normal-form)))
(xmtn--assert-optional
(or (equal dir "")
(not (eql (aref dir (1- (length dir))) ?/))))
`(dir ,dir)))
((("file" (string $normalized-path))
("content" (id $hash-id))
. $attrs)
`(file
,(decode-coding-string
normalized-path 'xmtn--monotone-normal-form)
,hash-id
,(mapcar (lambda (attr-entry)
(xmtn-match attr-entry
(("attr"
(string $attr-name)
(string $attr-value))
(list attr-name attr-value))))
attrs)))))))))
(defstruct (xmtn--revision (:constructor xmtn--make-revision))
;; matches data output by 'mtn diff'
new-manifest-hash-id
@ -1732,35 +1475,6 @@ finished."
set-attr
)
(defun xmtn--get-revision (root backend-id)
(xmtn-automate-with-session (nil root)
(let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
(xmtn--with-automate-command-output-basic-io-parser
(parser root `("get_revision"
,@(xmtn-match resolved-id
((local-tree $path)
;; FIXME: I don't really know what to do if
;; PATH is not the same as ROOT. Maybe
;; revision id resolution needs to return
;; the proper root, too.
(assert (xmtn--same-tree-p root path))
(unless (funcall
(xmtn--tree-consistent-p-future root))
(error (concat "Tree is inconsistent,"
" unable to compute revision")))
'())
((revision $hash-id)
`(,hash-id)))))
(assert (equal (funcall parser) '(("format_version" (string "1")))))
(let ((new-manifest-hash-id (xmtn-match (funcall parser)
((("new_manifest" (id $hash-id)))
hash-id))))
(let ((proto-revision (xmtn--parse-partial-revision parser)))
(setf (xmtn--revision-new-manifest-hash-id proto-revision)
new-manifest-hash-id)
proto-revision))))))
(defun xmtn--parse-partial-revision (parser)
"Parse basic_io output from get_revision, starting with the old_revision stanzas."
(let ((old-revision-hash-ids (list))

31
dvc/lisp/xmtn-ids.el
View File

@ -217,21 +217,22 @@ See file commentary for details."
(defun xmtn--branches-of (hash-id)
"Return list of branch names for HASH-ID. `default-directory'
must be a workspace."
(let (result)
(xmtn-automate-with-session (session default-directory)
(xmtn-automate-with-command (handle session `("certs" ,hash-id))
(xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle)
;; now in buffer containing basic_io certs; find the branch certs
(goto-char (point-min))
(while (not (xmtn-basic-io-eof))
(xmtn-basic-io-optional-line "name"
(if (and (eq 'string (caar value))
(string= "branch" (cadar value)))
(xmtn-basic-io-parse-line
(if (string= symbol "value")
(add-to-list 'result (cadar value)))))
)))))
(let* (result
(session (xmtn-automate-cache-session default-directory))
(handle (xmtn-automate--new-command session `("certs" ,hash-id) nil)))
(xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle)
;; now in buffer containing basic_io certs; find the branch certs
(goto-char (point-min))
(while (not (xmtn-basic-io-eof))
(xmtn-basic-io-optional-line "name"
(if (and (eq 'string (caar value))
(string= "branch" (cadar value)))
(xmtn-basic-io-parse-line
(if (string= symbol "value")
(add-to-list 'result (cadar value)))))
)))
(xmtn-automate--cleanup-command handle)
result))
(defun xmtn--get-base-revision-hash-id-or-null (root)

450
dvc/lisp/xmtn-multi-status.el Normal file
View 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

101
dvc/lisp/xmtn-propagate.el
View 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))))))
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)
(string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))
(if revs-current
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(xmtn-conflicts-update-counts))
(xmtn-conflicts-update-counts)
(save-buffer))
;; recreate conflicts
(xmtn-kill-conflicts-buffer data)
;; else recreate conflicts
(xmtn-propagate-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
@ -629,19 +602,25 @@ The elements must all be of class xmtn-propagate-data.")
(progn
(ecase (xmtn-propagate-data-from-local-changes data)
((need-scan need-commit)
(setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work)))
(setf (xmtn-propagate-data-from-local-changes data) (xmtn-automate-local-changes from-work)))
(ok nil))
(ecase (xmtn-propagate-data-to-local-changes data)
((need-scan need-commit)
(setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work)))
(setf (xmtn-propagate-data-to-local-changes data) (xmtn-automate-local-changes to-work)))
(ok nil))))
(if (xmtn-propagate-data-propagate-needed data)
;; can't compute conflicts if propagate not needed
(setf (xmtn-propagate-data-conflicts data)
(xmtn-propagate-conflicts data))
(progn
(if refresh-local-changes
(progn
(xmtn-propagate-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))))
(setf (xmtn-propagate-data-conflicts data)
(xmtn-propagate-conflicts data)))
;; can't compute conflicts if propagate not needed
(setf (xmtn-propagate-data-conflicts data) 'need-scan))
(setf (xmtn-propagate-data-need-refresh data) nil))
@ -725,6 +704,8 @@ scanned and all common ones found are used."
(from-session (xmtn-automate-cache-session from-work))
(to-session (xmtn-automate-cache-session to-work)))
(pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
;; default-directory is wrong if buffer is reused
(setq default-directory to-work)
(setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))
(setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
(setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))

406
dvc/lisp/xmtn-revlist.el
View File

@ -148,78 +148,77 @@ arg; root. Result is of the form:
(assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids))
(ewoc-set-hf ewoc header footer)
(ewoc-filter ewoc (lambda (x) nil)) ; Clear it.
(xmtn-automate-with-session (session root)
(setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
(if last-n
(let ((len (length revision-hash-ids)))
(if (> len last-n)
(setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))
(setq revision-hash-ids (coerce revision-hash-ids 'vector))
(xmtn--dotimes-with-progress-reporter (i (length revision-hash-ids))
(case (length revision-hash-ids)
(1 "Setting up revlist buffer (1 revision)...")
(t (format "Setting up revlist buffer (%s revisions)..."
(length revision-hash-ids))))
;; Maybe also show parents and children? (Could add toggle
;; commands to show/hide these.)
(lexical-let ((rev (aref revision-hash-ids i))
(branches (list))
(authors (list))
(dates (list))
(changelogs (list))
(tags (list)))
(xmtn--map-parsed-certs
root rev
(lambda (key signature name value trusted)
(declare (ignore key))
(unless (not trusted)
(cond ((equal name "author")
(push value authors))
((equal name "date")
(push value dates))
((equal name "changelog")
(push value changelogs))
((equal name "branch")
(push value branches))
((equal name "tag")
(push value tags))
(t
(progn))))))
(setq authors (nreverse authors)
dates (nreverse dates)
changelogs (nreverse changelogs)
branches (nreverse branches)
tags (nreverse tags))
(let ((parent-hash-ids
(xmtn-automate-simple-command-output-lines root `("parents"
,rev)))
(child-hash-ids
(xmtn-automate-simple-command-output-lines root `("children"
,rev))))
(xmtn--assert-optional (every #'stringp authors))
(xmtn--assert-optional (every #'stringp dates))
(xmtn--assert-optional (every #'stringp changelogs))
(xmtn--assert-optional (every #'stringp branches))
(xmtn--assert-optional (every #'stringp tags))
(xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))
(xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))
(ewoc-enter-last ewoc
;; Creating a list `(entry-patch
;; ,instance-of-dvc-revlist-entry-patch) seems
;; to be part of DVC's API.
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'xmtn
:rev-id `(xmtn (revision ,rev))
:struct (xmtn--make-revlist-entry
:revision-hash-id rev
:branches branches
:authors authors
:dates dates
:changelogs changelogs
:tags tags
:parent-hash-ids parent-hash-ids
:child-hash-ids child-hash-ids))))))))
(setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
(if last-n
(let ((len (length revision-hash-ids)))
(if (> len last-n)
(setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))
(setq revision-hash-ids (coerce revision-hash-ids 'vector))
(dotimes-with-progress-reporter (i (length revision-hash-ids))
(case (length revision-hash-ids)
(1 "Setting up revlist buffer (1 revision)...")
(t (format "Setting up revlist buffer (%s revisions)..."
(length revision-hash-ids))))
;; Maybe also show parents and children? (Could add toggle
;; commands to show/hide these.)
(lexical-let ((rev (aref revision-hash-ids i))
(branches (list))
(authors (list))
(dates (list))
(changelogs (list))
(tags (list)))
(xmtn--map-parsed-certs
root rev
(lambda (key signature name value trusted)
(declare (ignore key))
(unless (not trusted)
(cond ((equal name "author")
(push value authors))
((equal name "date")
(push value dates))
((equal name "changelog")
(push value changelogs))
((equal name "branch")
(push value branches))
((equal name "tag")
(push value tags))
(t
(progn))))))
(setq authors (nreverse authors)
dates (nreverse dates)
changelogs (nreverse changelogs)
branches (nreverse branches)
tags (nreverse tags))
(let ((parent-hash-ids
(xmtn-automate-simple-command-output-lines root `("parents"
,rev)))
(child-hash-ids
(xmtn-automate-simple-command-output-lines root `("children"
,rev))))
(xmtn--assert-optional (every #'stringp authors))
(xmtn--assert-optional (every #'stringp dates))
(xmtn--assert-optional (every #'stringp changelogs))
(xmtn--assert-optional (every #'stringp branches))
(xmtn--assert-optional (every #'stringp tags))
(xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))
(xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))
(ewoc-enter-last ewoc
;; Creating a list `(entry-patch
;; ,instance-of-dvc-revlist-entry-patch) seems
;; to be part of DVC's API.
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'xmtn
:rev-id `(xmtn (revision ,rev))
:struct (xmtn--make-revlist-entry
:revision-hash-id rev
:branches branches
:authors authors
:dates dates
:changelogs changelogs
:tags tags
:parent-hash-ids parent-hash-ids
:child-hash-ids child-hash-ids)))))))
nil)
(defun xmtn-revision-st-message (entry)
@ -257,14 +256,14 @@ arg; root. Result is of the form:
(defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n)
;; Adapted from `dvc-build-revision-list'.
;; info-generator-fn must return a list of back-end revision ids (strings)
(xmtn-automate-with-session (nil root)
(let ((dvc-temp-current-active-dvc 'xmtn)
(buffer (dvc-revlist-create-buffer
'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))
(with-current-buffer buffer
(setq xmtn--revlist-*info-generator-fn* info-generator-fn)
(xmtn--revlist-refresh))
(xmtn--display-buffer-maybe buffer nil)))
(xmtn-automate-cache-session root)
(let ((dvc-temp-current-active-dvc 'xmtn)
(buffer (dvc-revlist-create-buffer
'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))
(with-current-buffer buffer
(setq xmtn--revlist-*info-generator-fn* info-generator-fn)
(xmtn--revlist-refresh))
(xmtn--display-buffer-maybe buffer nil))
nil)
;;;###autoload
@ -293,57 +292,54 @@ arg; root. Result is of the form:
(xmtn--setup-revlist
root
(lambda (root)
(xmtn-automate-with-session
(nil root)
(let ((branch (xmtn--tree-default-branch root)))
(list branch
(list
(if dvc-revlist-last-n
(format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)
(format "Log for branch %s (all entries):" branch)))
'()
(xmtn--expand-selector
root
;; This restriction to current branch is completely
;; arbitrary.
(concat
"b:" ;; returns all revs for current branch
(xmtn--escape-branch-name-for-selector
branch)))))))
(let ((branch (xmtn--tree-default-branch root)))
(list branch
(list
(if dvc-revlist-last-n
(format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)
(format "Log for branch %s (all entries):" branch)))
'()
(xmtn--expand-selector
root
;; This restriction to current branch is completely
;; arbitrary.
(concat
"b:" ;; returns all revs for current branch
(xmtn--escape-branch-name-for-selector
branch))))))
first-line-only-p
last-n)))
(defun xmtn--revlist--missing-get-info (root)
(xmtn-automate-with-session (nil root)
(let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch))
(base-revision-hash-id (xmtn--get-base-revision-hash-id root))
(difference
(delete-duplicates
(mapcan
(lambda (head)
(xmtn-automate-simple-command-output-lines
root
`("ancestry_difference"
,head ,base-revision-hash-id)))
heads))))
(list
branch
`(,(format "Tree %s" root)
,(format "Branch %s" branch)
,(format "Base %s" base-revision-hash-id)
,(case (length heads)
(1 "branch is merged")
(t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
nil
,(case (length difference)
(0 "No revisions that are not in base revision")
(1 "1 revision that is not in base revision:")
(t (format
"%s revisions that are not in base revision:"
(length difference)))))
'()
difference))))
(let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch))
(base-revision-hash-id (xmtn--get-base-revision-hash-id root))
(difference
(delete-duplicates
(mapcan
(lambda (head)
(xmtn-automate-simple-command-output-lines
root
`("ancestry_difference"
,head ,base-revision-hash-id)))
heads))))
(list
branch
`(,(format "Tree %s" root)
,(format "Branch %s" branch)
,(format "Base %s" base-revision-hash-id)
,(case (length heads)
(1 "branch is merged")
(t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
nil
,(case (length difference)
(0 "No revisions that are not in base revision")
(1 "1 revision that is not in base revision:")
(t (format
"%s revisions that are not in base revision:"
(length difference)))))
'()
difference)))
(defun xmtn-revlist-show-conflicts ()
"If point is on a revision that has two parents, show conflicts
@ -459,20 +455,19 @@ from the merge."
(xmtn--setup-revlist
root
(lambda (root)
(xmtn-automate-with-session (nil root)
(let* ((branch (xmtn--tree-default-branch root))
(head-revision-hash-ids (xmtn--heads root branch))
(head-count (length head-revision-hash-ids)))
(list
branch
(list (format "Tree %s" root)
(format "Branch %s" branch)
(case head-count
(0 "No head revisions (branch empty (or circular ;))")
(1 "1 head revision:")
(t (format "%s head revisions: " head-count))))
'()
head-revision-hash-ids))))
(let* ((branch (xmtn--tree-default-branch root))
(head-revision-hash-ids (xmtn--heads root branch))
(head-count (length head-revision-hash-ids)))
(list
branch
(list (format "Tree %s" root)
(format "Branch %s" branch)
(case head-count
(0 "No head revisions (branch empty (or circular ;))")
(1 "1 head revision:")
(t (format "%s head revisions: " head-count))))
'()
head-revision-hash-ids)))
;; Passing nil as first-line-only-p, last-n is arbitrary here.
nil nil))
nil)
@ -498,20 +493,19 @@ to the base revision of the current tree."
(xmtn--setup-revlist
root
(lambda (root)
(xmtn-automate-with-session (nil root)
(let ((branch (xmtn--tree-default-branch root))
(revision-hash-ids
(mapcar #'first
(xmtn--get-content-changed-closure
root last-backend-id normalized-file dvc-revlist-last-n))))
(list
branch
(list
(if dvc-revlist-last-n
(format "Log for %s (last %d entries)" file dvc-revlist-last-n)
(format "Log for %s" file)))
'()
revision-hash-ids))))
(let ((branch (xmtn--tree-default-branch root))
(revision-hash-ids
(mapcar #'first
(xmtn--get-content-changed-closure
root last-backend-id normalized-file dvc-revlist-last-n))))
(list
branch
(list
(if dvc-revlist-last-n
(format "Log for %s (last %d entries)" file dvc-revlist-last-n)
(format "Log for %s" file)))
'()
revision-hash-ids)))
first-line-only-p
last-n))))
@ -530,25 +524,24 @@ to the base revision of the current tree."
(xmtn--setup-revlist
root
(lambda (root)
(xmtn-automate-with-session (nil root)
(let* ((branch (xmtn--tree-default-branch root))
(revision-hash-ids (xmtn--expand-selector root selector))
(count (length revision-hash-ids)))
(list
branch
(list (format "Tree %s" root)
(format "Default branch %s" branch)
(if (with-syntax-table (standard-syntax-table)
(string-match "\\`\\s *\\'" selector))
"Blank selector"
(format "Selector %s" selector))
(case count
(0 "No revisions matching selector")
(1 "1 revision matching selector:")
(t (format "%s revisions matching selector: "
count))))
'()
revision-hash-ids))))
(let* ((branch (xmtn--tree-default-branch root))
(revision-hash-ids (xmtn--expand-selector root selector))
(count (length revision-hash-ids)))
(list
branch
(list (format "Tree %s" root)
(format "Default branch %s" branch)
(if (with-syntax-table (standard-syntax-table)
(string-match "\\`\\s *\\'" selector))
"Blank selector"
(format "Selector %s" selector))
(case count
(0 "No revisions matching selector")
(1 "1 revision matching selector:")
(t (format "%s revisions matching selector: "
count))))
'()
revision-hash-ids)))
;; Passing nil as first-line-only-p is arbitrary here.
nil
;; FIXME: it might be useful to specify last-n here
@ -560,28 +553,26 @@ to the base revision of the current tree."
;;;###autoload
(defun xmtn-dvc-revlog-get-revision (revision-id)
(let ((root (dvc-tree-root)))
(xmtn-automate-with-session (nil root)
(let ((backend-id (xmtn--resolve-revision-id root revision-id)))
(xmtn-match backend-id
((local-tree $path) (error "Not implemented"))
((revision $revision-hash-id)
(with-output-to-string
(flet ((write-line (format &rest args)
(princ (apply #'format format args))
(terpri)))
(write-line "Revision %s" revision-hash-id)
;; FIXME: It would be good to sort the standard certs
;; like author, date, branch, tag and changelog into
;; some canonical order and format changelog specially
;; since it usually spans multiple lines.
(xmtn--map-parsed-certs
root revision-hash-id
(lambda (key signature name value trusted)
(declare (ignore key))
(if (not trusted)
(write-line "Untrusted cert, name=%s" name)
(write-line "%s: %s" name value))))))))))))
(let ((backend-id (xmtn--resolve-revision-id root revision-id)))
(xmtn-match backend-id
((local-tree $path) (error "Not implemented"))
((revision $revision-hash-id)
(with-output-to-string
(flet ((write-line (format &rest args)
(princ (apply #'format format args))
(terpri)))
(write-line "Revision %s" revision-hash-id)
;; FIXME: It would be good to sort the standard certs
;; like author, date, branch, tag and changelog into
;; some canonical order and format changelog specially
;; since it usually spans multiple lines.
(xmtn--map-parsed-certs
root revision-hash-id
(lambda (key signature name value trusted)
(declare (ignore key))
(if (not trusted)
(write-line "Untrusted cert, name=%s" name)
(write-line "%s: %s" name value)))))))))))
(defun xmtn-revlist-explicit-merge ()
"Run mtn explicit_merge on the two marked revisions.
@ -618,29 +609,6 @@ To be invoked from an xmtn revlist buffer."
(target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))
(xmtn--update root target-hash-id nil nil)))
;; Being able to conveniently disapprove whole batches of revisions
;; is going to be a lot of fun.
(defun xmtn-revlist-disapprove ()
"Disapprove the marked revisions, or the revision at point if none marked.
To be invoked from an xmtn revlist buffer."
(interactive)
(let* ((root (dvc-tree-root))
(entries (or (dvc-revision-marked-revisions)
(list (dvc-revlist-current-patch-struct))))
(hash-ids (map 'vector #'xmtn--revlist-entry-revision-hash-id entries))
(description (case (length hash-ids)
(0 (xmtn--assert-nil))
(1 (format "revision %s" (elt hash-ids 0)))
(t (format "%s revisions" (length hash-ids))))))
(assert (every #'xmtn--hash-id-p hash-ids))
(unless (yes-or-no-p (format "Disapprove %s? " description))
(error "Aborted disapprove"))
(xmtn--dotimes-with-progress-reporter (i (length hash-ids))
(format "Disapproving %s..." description)
(let ((hash-id (aref hash-ids i)))
(funcall (xmtn--do-disapprove-future root hash-id))))))
(provide 'xmtn-revlist)
;;; xmtn-revlist.el ends here

184
dvc/lisp/xmtn-run.el
View File

@ -43,31 +43,18 @@
(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)
(defun xmtn--call-with-environment-for-subprocess (xmtn--thunk)
(let ((process-environment (list* "LC_ALL="
"LC_CTYPE=en_US.UTF-8"
"LC_MESSAGES=C"
process-environment)))
(funcall xmtn--thunk)))
(defmacro* xmtn--with-environment-for-subprocess (() &body body)
(declare (indent 1) (debug (sexp body)))
`(xmtn--call-with-environment-for-subprocess (lambda () ,@body)))
(defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key)
(xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory))))
(let ((coding-system-for-write 'xmtn--monotone-normal-form))
(xmtn--with-environment-for-subprocess ()
(apply #'dvc-run-dvc-sync
'xmtn
`(,@xmtn-additional-arguments
;; We don't pass the --root argument here; it is not
;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs.
,@arguments)
dvc-run-keys)))))
(dvc-run-dvc-sync
'xmtn
`(,@xmtn-additional-arguments
;; We don't pass the --root argument here; it is not
;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs.
,@arguments)
dvc-run-keys)))
;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
;;; reason, spawns the subprocess with a working directory with all
@ -80,141 +67,36 @@
(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key)
(xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory))))
(let ((coding-system-for-write 'xmtn--monotone-normal-form))
(xmtn--with-environment-for-subprocess ()
(apply #'dvc-run-dvc-async
'xmtn
`(,@xmtn-additional-arguments
;; We don't pass the --root argument here; it is not
;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs.
,@arguments)
dvc-run-keys)))))
(defun* xmtn--command-append-to-buffer-async (buffer root arguments
&rest dvc-run-keys
&key finished)
(xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory))))
(let ((coding-system-for-write 'xmtn--monotone-normal-form))
(xmtn--with-environment-for-subprocess ()
(apply #'dvc-run-dvc-async
'xmtn
`(,@xmtn-additional-arguments
,@(if root `(,(concat "--root=" (file-truename root))))
,@arguments)
:finished (lexical-let ((buffer buffer)
(finished finished))
(lambda (output error status arguments)
(with-current-buffer buffer
(save-excursion
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert-buffer-substring output))))
(funcall (or finished #'dvc-default-finish-function)
output error status arguments)))
:related-buffer buffer
dvc-run-keys)))))
(defun* xmtn--command-lines-future (root which-buffer arguments)
(xmtn--check-cached-command-version)
(lexical-let ((got-output-p nil)
lines)
(lexical-let
((process
(let ((default-directory (file-truename (or root
default-directory))))
(let ((coding-system-for-write 'xmtn--monotone-normal-form))
(xmtn--with-environment-for-subprocess ()
(dvc-run-dvc-async
'xmtn
`(,@xmtn-additional-arguments
,@(if root `(,(concat "--root=" (file-truename root))))
,@arguments)
:finished
(lexical-let ((which-buffer which-buffer))
(lambda (output error status arguments)
(with-current-buffer (ecase which-buffer
(output output)
(error error))
(save-excursion
(goto-char (point-min))
(setq lines
(loop until (eobp)
collect
(buffer-substring-no-properties
(point)
(progn (end-of-line) (point)))
do (forward-line 1)))
(setq got-output-p t)))
nil))))))))
(lambda ()
(assert (member (process-status process) '(run exit signal)) t)
(while (and (eql (process-status process) 'run)
(accept-process-output process)))
(assert (member (process-status process) '(exit signal)) t)
;; This (including discarding input) is needed to allow the
;; sentinel to run, at least on GNU Emacs 21.4.2 and on GNU
;; Emacs 22.0.50.1 of 2006-06-13. Sentinels are supposed to
;; be run when `accept-process-output' is called, but they
;; apparently aren't reliably. I haven't investigated this
;; further.
;;
;; Problems with the sentinel not running mostly seem to be
;; reproducible (after commenting out the code below) by
;; pressing C-x V c immediately followed by a few other keys,
;; or by pressing C-x V c not followed by any further input,
;; or by editing a file in the tree without saving it, then
;; pressing C-x V c, waiting for the "Save buffer?" prompt and
;; then pressing y immediately followed by a few other keys.
;;
;; I hate having to discard the input because it interferes
;; with typing ahead while Emacs is still busy. But hanging
;; indefinitely waiting for `got-output-p' from a sentinel
;; that never runs is even worse.
(while (and (eql (process-status process) 'exit)
(eql (process-exit-status process) 0)
(not got-output-p))
(discard-input)
(sit-for .01))
(unless got-output-p
(assert (not (and (eql (process-status process) 'exit)
(eql (process-exit-status process) 0))))
(error "Process %s terminated abnormally, status=%s, exit code=%s"
(process-name process)
(process-status process)
(process-exit-status process)))
lines))))
(defun* xmtn--command-output-lines-future (root arguments)
(xmtn--command-lines-future root 'output arguments))
(defun* xmtn--command-error-output-lines-future (root arguments)
(xmtn--command-lines-future root 'error arguments))
(apply #'dvc-run-dvc-async
'xmtn
`(,@xmtn-additional-arguments
;; We don't pass the --root argument here; it is not
;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs.
,@arguments)
dvc-run-keys)))
(defun xmtn--command-output-lines (root arguments)
"Run mtn in ROOT with ARGUMENTS and return its output as a list of strings."
(xmtn--check-cached-command-version)
(let ((accu (list)))
(let ((default-directory (file-truename (or root default-directory))))
(let ((coding-system-for-write 'xmtn--monotone-normal-form))
(xmtn--with-environment-for-subprocess ()
(dvc-run-dvc-sync
'xmtn
`(,@xmtn-additional-arguments
,@(if root `(,(concat "--root=" (file-truename root))))
,@arguments)
:finished (lambda (output error status arguments)
(with-current-buffer output
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(push (buffer-substring-no-properties
(point)
(progn (end-of-line) (point)))
accu)
(forward-line 1)))))))))
(dvc-run-dvc-sync
'xmtn
`(,@xmtn-additional-arguments
,@(if root `(,(concat "--root=" (file-truename root))))
,@arguments)
:finished (lambda (output error status arguments)
(with-current-buffer output
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(push (buffer-substring-no-properties
(point)
(progn (end-of-line) (point)))
accu)
(forward-line 1)))))))
(setq accu (nreverse accu))
accu))