dvc

Merge lp:~mathrick/dvc/trunk into lp:dvc

Proposed by Maciej Katafiasz
Status: Needs review
Proposed branch: lp:~mathrick/dvc/trunk
Merge into: lp:dvc
Diff against target: 3135 lines (+1121/-1382)
16 files modified
debian/changelog (+3/-2)
debian/compat (+1/-1)
debian/control (+3/-3)
debian/copyright (+2/-1)
lisp/dvc-bookmarks.el (+32/-16)
lisp/dvc-core.el (+50/-37)
lisp/xhg.el (+13/-10)
lisp/xmtn-automate.el (+118/-335)
lisp/xmtn-compat.el (+1/-79)
lisp/xmtn-conflicts.el (+4/-0)
lisp/xmtn-dvc.el (+166/-452)
lisp/xmtn-ids.el (+16/-15)
lisp/xmtn-multi-status.el (+450/-0)
lisp/xmtn-propagate.el (+42/-61)
lisp/xmtn-revlist.el (+187/-219)
lisp/xmtn-run.el (+33/-151)
To merge this branch: bzr merge lp:~mathrick/dvc/trunk
Reviewer Review Type Date Requested Status
dvc-dev Pending
Review via email: mp+20126@code.launchpad.net
To post a comment you must log in.
Revision history for this message
Maciej Katafiasz (mathrick) wrote :

Hi, I have a small patch to quote the command passed to sh -c. Otherwise sh only takes the first argument as the command, ie. runs "bzr" without any options, which doesn't do a whole lot. I'm not sure why no-one's noticed that before, but it definitely is necessary on my system to make the DVC commands do anything at all.

Revision history for this message
Maciej Katafiasz (mathrick) wrote :

Actually, the patch is wrong, and the cause is completely different -- I have the bzr-pager plugin installed, which spawns less, which makes it complain about dumb terminal and await RET to be pressed, which completely breaks everything. I'm investigating ways to fix that now. Please disregard this merge request for now.

lp:~mathrick/dvc/trunk updated
572. By Maciej Katafiasz <email address hidden>

Always redirect output to a file, to avoid things breaking with TERM=dumb

Revision history for this message
Maciej Katafiasz (mathrick) wrote :

Okay, this change fixes it properly by always redirecting the output to a file. An easier way would be just to pipe it through | tee /dev/null, but it'd mean additional pain for Win32 users. With redirecting nothing changes.

Apologies for the confusion and uncommitting the patch I've already pushed. The conflicts reported by lpad above are spurious, I've tested it and it merges just fine with lp:dvc.

Unmerged revisions

572. By Maciej Katafiasz <email address hidden>

Always redirect output to a file, to avoid things breaking with TERM=dumb

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
=== modified file 'debian/changelog'
--- debian/changelog 2008-09-02 18:05:50 +0000
+++ debian/changelog 2010-02-25 22:31:14 +0000
@@ -1,6 +1,7 @@
1dvc (0r20080829-1) unstable; urgency=low1dvc (0r20091206-1) unstable; urgency=low
22
3 * New snapshot.3 * New snapshot.
4 * Add dvc.texinfo license to debian/copyright.
4 * Julien Danjou is the sponsor for DVC (Closes: #496930).5 * Julien Danjou is the sponsor for DVC (Closes: #496930).
56
6 -- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Fri, 29 Aug 2008 19:27:14 +02007 -- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Sun, 06 Dec 2009 11:54:58 +0100
78
=== modified file 'debian/compat'
--- debian/compat 2006-06-07 20:27:26 +0000
+++ debian/compat 2010-02-25 22:31:14 +0000
@@ -1,1 +1,1 @@
1417
22
=== modified file 'debian/control'
--- debian/control 2008-08-29 17:10:10 +0000
+++ debian/control 2010-02-25 22:31:14 +0000
@@ -2,15 +2,15 @@
2Section: devel2Section: devel
3Priority: optional3Priority: optional
4Maintainer: Daniel Dehennin <daniel.dehennin@baby-gnu.org>4Maintainer: Daniel Dehennin <daniel.dehennin@baby-gnu.org>
5Build-Depends: cdbs (>= 0.4.50), debhelper5Build-Depends: cdbs (>= 0.4.50), debhelper (>= 7)
6Build-Depends-Indep: autoconf, emacs22 | emacs21 | xemacs21 | emacsen, texinfo6Build-Depends-Indep: autoconf, emacs22 | emacs21 | xemacs21 | emacsen, texinfo
7Standards-Version: 3.8.0.17Standards-Version: 3.8.3
8Vcs-Bzr: http://bzr.xsteve.at/dvc/8Vcs-Bzr: http://bzr.xsteve.at/dvc/
9Homepage: http://download.gna.org/dvc/9Homepage: http://download.gna.org/dvc/
1010
11Package: dvc11Package: dvc
12Architecture: all12Architecture: all
13Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot13Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot, dpkg (>= 1.15.4) | install-info, ${misc:Depends}
14Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone14Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone
15Description: Emacs front-end to distributed version control systems15Description: Emacs front-end to distributed version control systems
16 DVC is an attempt to build a common infrastructure for various16 DVC is an attempt to build a common infrastructure for various
1717
=== modified file 'debian/copyright'
--- debian/copyright 2008-10-26 15:24:41 +0000
+++ debian/copyright 2010-02-25 22:31:14 +0000
@@ -37,7 +37,8 @@
3737
38 This package is free software; you can redistribute it and/or modify38 This package is free software; you can redistribute it and/or modify
39 it under the terms of the GNU General Public License as published by39 it under the terms of the GNU General Public License as published by
40 the Free Software Foundation; version 2 dated June, 1991.40 the Free Software Foundation; version 2 dated June, 1991, or
41 (at your option) any later version.
4142
42 This package is distributed in the hope that it will be useful,43 This package is distributed in the hope that it will be useful,
43 but WITHOUT ANY WARRANTY; without even the implied warranty of44 but WITHOUT ANY WARRANTY; without even the implied warranty of
4445
=== modified file 'lisp/dvc-bookmarks.el'
--- lisp/dvc-bookmarks.el 2009-05-01 05:10:03 +0000
+++ lisp/dvc-bookmarks.el 2010-02-25 22:31:14 +0000
@@ -167,7 +167,8 @@
167 (define-key map "\C-y" 'dvc-bookmarks-yank)167 (define-key map "\C-y" 'dvc-bookmarks-yank)
168 (define-key map "\C-k" 'dvc-bookmarks-kill)168 (define-key map "\C-k" 'dvc-bookmarks-kill)
169 (define-key map "D" 'dvc-bookmarks-delete)169 (define-key map "D" 'dvc-bookmarks-delete)
170 (define-key map "H" 'dvc-bookmarks-show-or-hide-subtree)170 (define-key map "Hs" 'dvc-bookmarks-show-or-hide-subtree)
171 (define-key map "Ha" 'dvc-bookmarks-show-or-hide-all-subtrees)
171 (define-key map "S" 'dvc-bookmarks-set-tree-properties)172 (define-key map "S" 'dvc-bookmarks-set-tree-properties)
172 (define-key map "s" 'dvc-bookmarks-status)173 (define-key map "s" 'dvc-bookmarks-status)
173 (define-key map "d" 'dvc-bookmarks-diff)174 (define-key map "d" 'dvc-bookmarks-diff)
@@ -1163,23 +1164,38 @@
1163(defvar dvc-bookmarks-hidden-subtree nil1164(defvar dvc-bookmarks-hidden-subtree nil
1164 "List of all hidden subtrees")1165 "List of all hidden subtrees")
11651166
1166(defun dvc-bookmarks-show-or-hide-subtree (&optional show)1167(defun dvc-bookmarks-show-or-hide-subtree ()
1167 "Hide subtree when called with no argument1168 "Toggle subtree visibility."
1168show subtree when called with prefix argument (C-u)"1169 (interactive)
1169 (interactive "P")
1170 (let ((current-tree (aref (dvc-bookmarks-current-bookmark) 1))1170 (let ((current-tree (aref (dvc-bookmarks-current-bookmark) 1))
1171 (parent))1171 (pos (point))
1172 (when (member (assoc current-tree dvc-bookmark-alist) dvc-bookmark-alist) ;check if we are really on a tree1172 parent)
1173 (if current-prefix-arg1173 (when (member (assoc current-tree dvc-bookmark-alist)
1174 dvc-bookmark-alist) ; Check if we are really on a tree.
1175 (if (member current-tree dvc-bookmarks-hidden-subtree)
1174 (progn1176 (progn
1175 (setq dvc-bookmarks-hidden-subtree (remove current-tree dvc-bookmarks-hidden-subtree))1177 (setq dvc-bookmarks-hidden-subtree
1176 (dvc-bookmarks))1178 (remove current-tree dvc-bookmarks-hidden-subtree))
1177 (add-to-list 'dvc-bookmarks-hidden-subtree current-tree))1179 (dvc-bookmarks))
1178 (ewoc-filter dvc-bookmarks-cookie #'(lambda (x)1180 (add-to-list 'dvc-bookmarks-hidden-subtree current-tree))
1179 (setq parent (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist))1181 (ewoc-filter dvc-bookmarks-cookie
1180 (if (not (member parent dvc-bookmarks-hidden-subtree))1182 #'(lambda (x)
1181 t1183 (setq parent
1182 nil))))))1184 (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist))
1185 (if (not (member parent dvc-bookmarks-hidden-subtree)) t nil))))
1186 (goto-char pos)))
1187
1188(defun dvc-bookmarks-show-or-hide-all-subtrees ()
1189 "Toggle visibility of all subtrees."
1190 (interactive)
1191 (with-current-buffer "*dvc-bookmarks*"
1192 (goto-char (point-min))
1193 (save-excursion
1194 (while (re-search-forward "^[^ ].+" nil t)
1195 (dvc-bookmarks-show-or-hide-subtree)
1196 (end-of-line)))
1197 (forward-line 1)))
1198
11831199
1184(defvar dvc-bookmarks-tmp-yank-item '("hg" (local-tree "~/work/hg/hg")))1200(defvar dvc-bookmarks-tmp-yank-item '("hg" (local-tree "~/work/hg/hg")))
11851201
11861202
=== modified file 'lisp/dvc-core.el'
--- lisp/dvc-core.el 2009-08-12 00:15:41 +0000
+++ lisp/dvc-core.el 2010-02-25 22:31:14 +0000
@@ -649,6 +649,7 @@
649 (let* ((output-buf (or (and output-buffer649 (let* ((output-buf (or (and output-buffer
650 (get-buffer-create output-buffer))650 (get-buffer-create output-buffer))
651 (dvc-new-process-buffer nil dvc)))651 (dvc-new-process-buffer nil dvc)))
652 (output-file (dvc-make-temp-name "dvc-output"))
652 (error-buf (or (and error-buffer (get-buffer-create error-buffer))653 (error-buf (or (and error-buffer (get-buffer-create error-buffer))
653 (dvc-new-error-buffer nil dvc)))654 (dvc-new-error-buffer nil dvc)))
654 (error-file (dvc-make-temp-name "dvc-errors"))655 (error-file (dvc-make-temp-name "dvc-errors"))
@@ -672,11 +673,20 @@
672 ;; we use a shell to redirect stderr before Emacs sees673 ;; we use a shell to redirect stderr before Emacs sees
673 ;; it. Note that this means we require "sh" even on674 ;; it. Note that this means we require "sh" even on
674 ;; MS Windows.675 ;; MS Windows.
676 ;;
677 ;; An added twist is that start-process creates an
678 ;; environment in which isatty() returns true. This has
679 ;; unpleasant consequences if anything tries to pipe
680 ;; through `less', because with TERM=dumb it will show a
681 ;; warning and then wait for RET to be pressed, which
682 ;; never happens, breaking our output processing. For
683 ;; this reason, we redirect the output to a file as
684 ;; well.
675 (start-process685 (start-process
676 (dvc-variable dvc "executable") output-buf686 (dvc-variable dvc "executable") output-buf
677 dvc-sh-executable "-c"687 dvc-sh-executable "-c"
678 (format "%s 2> %s"688 (format "%s > %s 2> %s"
679 command error-file))))689 command output-file error-file))))
680 (process-event690 (process-event
681 (list process691 (list process
682 (dvc-log-event output-buf692 (dvc-log-event output-buf
@@ -697,41 +707,44 @@
697 (set-process-sentinel707 (set-process-sentinel
698 process708 process
699 (dvc-capturing-lambda (process event)709 (dvc-capturing-lambda (process event)
700 (let ((default-directory (capture default-directory)))710 (labels ((slurp-file (file buffer)
701 (dvc-log-event (capture output-buf) (capture error-buf)711 (when (file-exists-p file)
702 (capture command)712 (with-current-buffer buffer
703 (capture default-directory)713 (insert-file-contents file))
704 (dvc-strip-final-newline event))714 (delete-file file))))
705 (setq dvc-process-running715 (let ((default-directory (capture default-directory)))
706 (delq (capture process-event) dvc-process-running))716 (dvc-log-event (capture output-buf) (capture error-buf)
707 (when (file-exists-p (capture error-file))717 (capture command)
708 (with-current-buffer (capture error-buf)718 (capture default-directory)
709 (insert-file-contents (capture error-file)))719 (dvc-strip-final-newline event))
710 (delete-file (capture error-file)))720 (setq dvc-process-running
711 (let ((state (process-status process))721 (delq (capture process-event) dvc-process-running))
712 (status (process-exit-status process))722 (slurp-file (capture output-file) (capture output-buf))
713 (dvc-temp-current-active-dvc (capture dvc)))723 (slurp-file (capture error-file) (capture error-buf))
714 (unwind-protect724 (let ((state (process-status process))
715 (cond ((and (eq state 'exit) (= status 0))725 (status (process-exit-status process))
716 (funcall (or (capture finished)726 (dvc-temp-current-active-dvc (capture dvc)))
717 'dvc-default-finish-function)727 (unwind-protect
718 (capture output-buf) (capture error-buf)728 (cond ((and (eq state 'exit) (= status 0))
719 status (capture arguments)))729 (funcall (or (capture finished)
720 ((eq state 'signal)730 'dvc-default-finish-function)
721 (funcall (or (capture killed)731 (capture output-buf) (capture error-buf)
722 'dvc-default-killed-function)732 status (capture arguments)))
723 (capture output-buf) (capture error-buf)733 ((eq state 'signal)
724 status (capture arguments)))734 (funcall (or (capture killed)
725 ((eq state 'exit) ;; status != 0735 'dvc-default-killed-function)
726 (funcall (or (capture error)736 (capture output-buf) (capture error-buf)
727 'dvc-default-error-function)737 status (capture arguments)))
728 (capture output-buf) (capture error-buf)738 ((eq state 'exit) ;; status != 0
729 status (capture arguments)))))739 (funcall (or (capture error)
730 ;; Schedule any buffers we created for killing740 'dvc-default-error-function)
731 (unless (capture output-buffer)741 (capture output-buf) (capture error-buf)
732 (dvc-kill-process-buffer (capture output-buf)))742 status (capture arguments)))))
733 (unless (capture error-buffer)743 ;; Schedule any buffers we created for killing
734 (dvc-kill-process-buffer (capture error-buf)))))))744 (unless (capture output-buffer)
745 (dvc-kill-process-buffer (capture output-buf)))
746 (unless (capture error-buffer)
747 (dvc-kill-process-buffer (capture error-buf))))))))
735 process))))748 process))))
736749
737(defun dvc-run-dvc-sync (dvc arguments &rest keys)750(defun dvc-run-dvc-sync (dvc arguments &rest keys)
738751
=== modified file 'lisp/xhg.el'
--- lisp/xhg.el 2009-08-31 11:43:24 +0000
+++ lisp/xhg.el 2010-02-25 22:31:14 +0000
@@ -1043,9 +1043,9 @@
1043 (dvc-default-finish-function output error status arguments)1043 (dvc-default-finish-function output error status arguments)
1044 (message "hg %s complete for %s" opt-string default-directory)))))1044 (message "hg %s complete for %s" opt-string default-directory)))))
10451045
1046(defun xhg-convert (source target)1046(defun xhg-convert (source target &optional revnum)
1047 "Convert a foreign SCM repository to a Mercurial one.1047 "Convert a foreign SCM repository to a Mercurial one.
10481048With prefix arg prompt for REVNUM.
1049 Accepted source formats [identifiers]:(Mercurial-1.1.2)1049 Accepted source formats [identifiers]:(Mercurial-1.1.2)
1050 - Mercurial [hg]1050 - Mercurial [hg]
1051 - CVS [cvs]1051 - CVS [cvs]
@@ -1063,14 +1063,17 @@
1063Read also: hg help convert.1063Read also: hg help convert.
1064"1064"
1065 (interactive "DSource: \nsTarget: ")1065 (interactive "DSource: \nsTarget: ")
1066 (message "Started hg conversion of [%s] to [%s] ..." source target)1066 (let* ((src (expand-file-name source))
1067 (dvc-run-dvc-async 'xhg (list "convert"1067 (tget (expand-file-name target))
1068 (expand-file-name source)1068 (rev (if current-prefix-arg (read-string "Revision: ") revnum))
1069 (expand-file-name target))1069 (arg-list (if rev (list "convert" src tget "-r" rev) (list "convert" src tget))))
1070 :finished (dvc-capturing-lambda (output error status arguments)1070 (message "HG conversion of `%s' to `%s' ..." source target)
1071 (let ((default-directory (capture target)))1071 (dvc-run-dvc-async 'xhg arg-list
1072 (xhg-update))1072 :finished (dvc-capturing-lambda (output error status arguments)
1073 (message "hg: [%s] successfully converted to [%s]" (capture source) (capture target)))))1073 (let ((default-directory (capture target)))
1074 (xhg-update))
1075 (message "HG conversion of `%s' to `%s' ... done."
1076 (capture source) (capture target))))))
10741077
1075;; --------------------------------------------------------------------------------1078;; --------------------------------------------------------------------------------
1076;; hg serve functionality1079;; hg serve functionality
10771080
=== modified file 'lisp/xmtn-automate.el'
--- lisp/xmtn-automate.el 2009-10-03 12:39:58 +0000
+++ lisp/xmtn-automate.el 2010-02-25 22:31:14 +0000
@@ -26,98 +26,39 @@
26;; This library provides access to monotone's "automate" interface26;; This library provides access to monotone's "automate" interface
27;; from Emacs Lisp.27;; from Emacs Lisp.
28;;28;;
29;; I found monotone's automate stdio mode (see29;; see http://www.monotone.ca/docs/Automation.html#Automation for
30;; http://www.venge.net/monotone/docs/Automation.html for details)30;; details of the monotone automate command.
31;; rather intriguing, so I tried to make full use of it. I don't know31;;
32;; whether it is really significantly more efficient than spawning a32;; mtn automate allows sending several commands to a single mtn
33;; new subprocess for each command. But, in theory, feeding multiple33;; process, and provides the results in a form that is easy to
34;; commands to one process allows that process to do all kinds of34;; parse. It does some caching between command, and will do more in
35;; smart caching, so it could make very large differences, even35;; the future, so this is a significant speed-up over spawning a new
36;; differences in orders of magnitude. I don't know whether monotone36;; subprocess for each command.
37;; currently does any caching, but at least this means we have an
38;; excuse for not doing any caching in Emacs. (If it becomes clear
39;; that caching would be a good idea, it can be implemented in
40;; monotone instead of Emacs; this way, other front-ends to monotone
41;; can also benefit from it.)
42;;37;;
43;; To allow xmtn-automate to track how long an automate stdio process38;; To allow xmtn-automate to track how long an automate stdio process
44;; needs to be kept around, we introduce the concept of a session. To39;; needs to be kept around, and to store meta data, we introduce the
45;; the programmer using this library, a session is an opaque object40;; concept of a session. To the programmer using this library, a
46;; that is needed to run automate commands. Each session is41;; session is an opaque object that is needed to run automate
47;; associated with a monotone workspace ("root") that the commands42;; commands. Each session is associated with a monotone workspace
48;; will operate on. (Using xmtn-auomate to run commands with no43;; ("root") that the commands will operate on. A session can be
49;; workspace is not currently part of the design.) A session can be44;; obtained using `xmtn-automate-cache-session'. Note that
50;; obtained using `xmtn-automate-with-session' and has dynamic extent.45;; `xmtn-automate-cache-session' doesn't necessarily start a fresh
51;; Note that `xmtn-automate-with-session' doesn't necessarily start a46;; monotone process, if a session with that root already exists. The
52;; fresh monotone process; xmtn-automate may reuse existing session47;; process must be killed with `xmtn-automate-kill-session'.
53;; objects and processes, or launch the process only when the first
54;; command is sent to the session. There is also no guarantee about
55;; how long xmtn-automate will keep the process running after
56;; `xmtn-automate-with-session' exits. (The function
57;; `xmtn-automate-terminate-processes-in-root' can be used to tell
58;; xmtn-automate to terminate all processes in a given root as soon as
59;; possible, and wait until they terminate. I imagine this could be
60;; necessary to free locks, but whether mtn automate stdio does any
61;; locking doesn't seem to be specified in monotone's manual.) To put
62;; it another way, the mapping between `xmtn-automate-with-session'
63;; forms and monotone processes is not necessarily one-to-one.
64;;
65;; `xmtn-automate-with-session' forms can safely be nested.
66;;48;;
67;; Once you have a session object, you can use49;; Once you have a session object, you can use
68;; `xmtn-automate-with-command' forms to send commands to monotone.50;; `xmtn-automate-new-command' to send commands to monotone.
69;; Each such form gets you a so-called command-handle. Again, this is51;;
70;; an opaque object with dynamic extent. You can use this handle to52;; A COMMAND is a list of strings (the command and its arguments), or
71;; check the error code of the command and obtain its output. Your53;; a cons of lists of strings. If car COMMAND is a list, car COMMAND is
72;; Emacs Lisp code can also do other computation while the monotone54;; options (without leading "--"), cdr is the command and arguments.
73;; command runs. Allowing this kind of parallelism and incremental55;;
74;; processing of command output is the main reason for introducing56;; `xmtn-automate-new-command' returns a command handle. You use this
75;; command handles.57;; handle to check the error code of the command and obtain its
76;;58;; output. Your Emacs Lisp code can also do other computation while
77;; The following operations are defined on command handles.59;; the monotone command runs. Allowing this kind of parallelism and
78;;60;; incremental processing of command output is the main reason for
79;; * xmtn-automate-command-error-code (command-handle) --> 0, 1 or 261;; introducing command handles.
80;;
81;; Returns the error code of the command. See monotone
82;; documentation. This operation blocks until the monotone process
83;; has sent the error code.
84;;
85;; * xmtn-automate-command-wait-until-finished (command-handle) -->
86;; nil
87;;
88;; Blocks until the command has finished (successfully or not).
89;; After this operation returns, `xmtn-automate-command-finished-p'
90;; will return true for this command.
91;;
92;; * xmtn-automate-command-buffer (command-handle) --> buffer
93;;
94;; Returns the so-called command buffer associated with the command
95;; handle. This is a buffer with the output that the command has
96;; generated so far. The buffer contents will be updated as new
97;; output arrives. The buffer has the same extent as the command
98;; handle. This operation does not block.
99;;
100;; * xmtn-automate-command-write-marker-position (command-handle)
101;; --> position
102;;
103;; The position in the output buffer after the last character of
104;; output the command has generated so far. This is also where new
105;; output will be inserted. This operation does not block.
106;;
107;; * xmtn-automate-command-finished-p (command-handle) --> boolean
108;;
109;; Returns nil if the command is still running, non-nil if it has
110;; finished (successfully or not). If this function returns non-nil,
111;; the full output of the command is available in the command buffer.
112;; This operation does not block.
113;;
114;; * xmtn-automate-command-accept-output (command-handle) -->
115;; output-received-p
116;;
117;; Allows Emacs to process more output from the command (and
118;; possibly from other processes). Blocks until more output has
119;; been received from the command or the command has finished.
120;; Returns non-nil if more output has been received.
121;;62;;
122;; The intention behind this protocol is to allow Emacs Lisp code to63;; The intention behind this protocol is to allow Emacs Lisp code to
123;; process command output incrementally as it arrives instead of64;; process command output incrementally as it arrives instead of
@@ -127,88 +68,15 @@
127;; hard to tune it, either. So I'm not sure whether incremental68;; hard to tune it, either. So I'm not sure whether incremental
128;; processing is useful.69;; processing is useful.
129;;70;;
130;; In the output buffer, the "chunking" (the <command number>:<err71;; In the output buffer, the mtn stdio output header (<command
131;; code>:<last?>:<size>:<output> thing) that monotone automate stdio does72;; number>:<err code>:<last?>:<size>:<data>) has been processed;
132;; has already been decoded and removed. However, no other processing or73;; only the data is present.
133;; parsing has been done. The output buffer contains raw 8-bit data.74
134;;75;; There are some notes on the design of xmtn in
135;; Different automate commands generate data in different formats: For76;; docs/xmtn-readme.txt.
136;; example, get_manifest generates basic_io; select generates a list
137;; of lines with one ID each, graph generates a list of lines with one
138;; or more IDs each; inventory and the packet_* commands generate
139;; different custom line-based formats; and get_file generates binary
140;; output. Parsing these formats is not part of xmtn-automate.
141;;
142;; You shouldn't manually kill the output buffer; xmtn-automate will take
143;; care of it when the `xmtn-automate-with-command' form exits.
144;;
145;; Example:
146;;
147;; (xmtn-automate-with-session (session "/path/to/workspace")
148;; ;; The variable `session' now holds a session object associated
149;; ;; with the workspace.
150;; (xmtn-automate-with-command (handle session '("get_base_revision_id"))
151;; ;; The variable `handle' now holds a command handle.
152;; ;; Check that the command was successful (not described above);
153;; ;; generate a default error message otherwise and abort.
154;; (xmtn-automate-command-check-for-and-report-error handle)
155;; ;; Wait until the entire output of the command has arrived.
156;; (xmtn-automate-command-wait-until-finished handle)
157;; ;; Process output (in command buffer).
158;; (message "Base revision id is %s"
159;; (with-current-buffer (xmtn-automate-command-buffer handle)
160;; (buffer-substring (point-min)
161;; ;; Ignore final newline.
162;; (1- (point-max)))))))
163;;
164;; There are some utility functions built on top of this general
165;; interface that help express common uses more concisely; for
166;; example,
167;;
168;; (message "Base revision id is %s"
169;; (xmtn-automate-simple-command-output-line
170;; "/path/to/workspace" '("get_base_revision_id")))
171;;
172;; does the same thing as the above code.
173;;
174;; If multiple "simple" automate commands are run in succession on the
175;; same workspace, it's a good idea to wrap an
176;; `xmtn-automate-with-session' form around them so xmtn knows that it
177;; should reuse the same process.
178;;
179;; (xmtn-automate-with-session (nil "/path/to/workspace")
180;; (message "Base revision id is %s, current revision is %s"
181;; (xmtn-automate-simple-command-output-line
182;; "/path/to/workspace" '("get_base_revision_id"))
183;; (xmtn-automate-simple-command-output-line
184;; "/path/to/workspace" '("get_current_revision_id")))
185;;
186;; Here, the session object is not explicitly passed to the functions
187;; that actually feed commands to monotone. But, since the containing
188;; session is still open after the first command, xmtn knows that it
189;; should keep the process alive, and it is smart enough to reuse the
190;; process for the second command.
191;;
192;; The fact that `xmtn-automate-with-command' always forces commands
193;; to either happen in sequence or properly nested can be a
194;; limitation. For example, it's not possible to write a
195;; (non-recursive) loop that runs N automate commands and processes
196;; their output, always launching the (k+1)th automate command ahead
197;; of time to run in parallel with the kth iteration. (Some of the
198;; revlist and cert-parsing code really wants to do this, I think.)
199;; (But maybe writing this recursively wouldn't be all that bad... It
200;; is asymptotically less (stack-!)space-efficient but makes it
201;; impossible to get the cleanup wrong.) Providing the two halves of
202;; `xmtn-automate-with-command' as two functions
203;; `xmtn-automate-open-command' and `xmtn-automate-close-command' that
204;; always need to be called in pairs would be more flexible. (Common
205;; Lisp also has with-open-file but also open and close.)
20677
207;;; Code:78;;; Code:
20879
209;;; There are some notes on the design of xmtn in
210;;; docs/xmtn-readme.txt.
211
212(eval-and-compile80(eval-and-compile
213 (require 'cl)81 (require 'cl)
214 (require 'parse-time) ;for parse-integer82 (require 'parse-time) ;for parse-integer
@@ -255,92 +123,36 @@
255 (xmtn-automate-command-finished-p handle))))123 (xmtn-automate-command-finished-p handle))))
256 nil)124 nil)
257125
258(defvar xmtn-automate--*sessions* '())126(defvar xmtn-automate--*sessions* '()
127 "Assoc list of sessions, indexed by uniquified root directory.")
259128
260(defun xmtn-automate-cache-session (root)129(defun xmtn-automate-cache-session (root)
261 "Create a mtn automate session for workspace ROOT, store it in130 "If necessary, create a mtn automate session for workspace
262session cache, return it (for later kill)."131ROOT, store it in session cache. Return session."
263 (let* ((default-directory (file-name-as-directory root))132 ;; we require an explicit root argument here, rather than relying on
264 (key (file-truename default-directory))133 ;; default-directory, because one application is to create several
265 (session (xmtn-automate--make-session root key)))134 ;; sessions for several workspaces, and operate on them as a group
266 (setq xmtn-automate--*sessions*135 ;; (see xmtn-multi-status.el, for example).
267 (acons key session xmtn-automate--*sessions*))136 (let* ((default-directory (dvc-uniquify-file-name root))
268 session))137 (session (xmtn-automate-get-cached-session default-directory)))
138 (or session
139 (progn
140 (setq session (xmtn-automate--make-session default-directory default-directory))
141 (setq xmtn-automate--*sessions*
142 (acons default-directory session xmtn-automate--*sessions*))
143 session))))
269144
270(defun xmtn-automate-get-cached-session (key)145(defun xmtn-automate-get-cached-session (key)
271 "Return a session from the cache, or nil."146 "Return a session from the cache, or nil. KEY is uniquified
272 ;; separate function so we can debug it147workspace root."
273 (cdr (assoc key xmtn-automate--*sessions*)))148 (cdr (assoc key xmtn-automate--*sessions*)))
274149
275(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key)
276 &body body)
277 "Call BODY, after ensuring an automate session for ROOT-FORM is active."
278 (declare (indent 1) (debug (sexp body)))
279 ;; I would prefer to factor out a function
280 ;; `xmtn-automate--call-with-session' here, but that would make
281 ;; profiler output unreadable, since every function would only
282 ;; appear to call `xmtn-automate--call-with-session', and that
283 ;; function would appear to do all computation.
284 ;;
285 ;; mtn automate stdio requires a valid database, so we require a
286 ;; root directory here.
287 (let ((session (gensym))
288 (session-var (or session-var-or-null (gensym)))
289 (root (gensym))
290 (key (gensym))
291 (thunk (gensym)))
292 `(let* ((,root (file-name-as-directory ,root-form))
293 (,key (file-truename ,root))
294 (,session (xmtn-automate-get-cached-session ,key))
295 (,thunk (lambda ()
296 (let ((,session-var ,session))
297 ,@body))))
298 (if ,session
299 (funcall ,thunk)
300 (unwind-protect
301 (progn
302 (setq ,session (xmtn-automate--make-session ,root ,key))
303 (let ((xmtn-automate--*sessions*
304 ;; note the let-binding here; these sessions are _not_
305 ;; available for later commands. use
306 ;; xmtn-automate-cache-session to get a persistent
307 ;; session.
308 (acons ,key ,session xmtn-automate--*sessions*)))
309 (funcall ,thunk)))
310 (when ,session (xmtn-automate--close-session ,session)))))))
311
312(defmacro* xmtn-automate-with-command ((handle-var session-form command-form
313 &key ((:may-kill-p
314 may-kill-p-form)))
315 &body body)
316 "Send COMMAND_FORM (a list of strings, or cons of lists of
317strings) to session SESSION_FORM (current if nil). If car
318COMMAND_FORM is a list, car COMMAND_FORM is options, cdr is command.
319Then execute BODY."
320 (declare (indent 1) (debug (sexp body)))
321 (let ((session (gensym))
322 (command (gensym))
323 (may-kill-p (gensym))
324 (handle (gensym)))
325 `(let ((,session ,session-form)
326 (,command ,command-form)
327 (,may-kill-p ,may-kill-p-form)
328 (,handle nil))
329 (unwind-protect
330 (progn
331 (setq ,handle (xmtn-automate--new-command ,session
332 ,command
333 ,may-kill-p))
334 (xmtn--assert-optional (xmtn-automate--command-handle-p ,handle))
335 (let ((,handle-var ,handle))
336 ,@body))
337 (when ,handle
338 (xmtn-automate--cleanup-command ,handle))))))
339
340(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle)150(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle)
341 (xmtn-automate-command-wait-until-finished handle)151 (xmtn-automate-command-wait-until-finished handle)
342 (with-current-buffer (xmtn-automate-command-buffer handle)152 (with-current-buffer (xmtn-automate-command-buffer handle)
343 (buffer-substring-no-properties (point-min) (point-max))))153 (prog1
154 (buffer-substring-no-properties (point-min) (point-max))
155 (xmtn-automate--cleanup-command handle))))
344156
345(defun xmtn-automate-command-check-for-and-report-error (handle)157(defun xmtn-automate-command-check-for-and-report-error (handle)
346 (unless (eql (xmtn-automate-command-error-code handle) 0)158 (unless (eql (xmtn-automate-command-error-code handle) 0)
@@ -351,30 +163,27 @@
351 nil)163 nil)
352164
353(defun xmtn-automate-simple-command-output-string (root command)165(defun xmtn-automate-simple-command-output-string (root command)
354 "Send COMMAND (a list of strings, or cons of lists of strings)166 "Send COMMAND to session for ROOT. Return result as a string."
355to current session. If car COMMAND is a list, car COMMAND is167 (let* ((session (xmtn-automate-cache-session root))
356options, cdr is command. Return result as a string."168 (command-handle (xmtn-automate--new-command session command nil)))
357 (xmtn-automate-with-session (session root)169 (xmtn-automate-command-check-for-and-report-error command-handle)
358 (xmtn-automate-with-command (handle session command)170 (xmtn-automate--command-output-as-string-ignoring-exit-code command-handle)))
359 (xmtn-automate-command-check-for-and-report-error handle)
360 (xmtn-automate--command-output-as-string-ignoring-exit-code handle))))
361171
362(defun xmtn-automate-simple-command-output-insert-into-buffer172(defun xmtn-automate-simple-command-output-insert-into-buffer
363 (root buffer command)173 (root buffer command)
364 "Send COMMAND (a list of strings, or cons of lists of strings)174 "Send COMMAND to session for ROOT, insert result into BUFFER."
365to current session. If car COMMAND is a list, car COMMAND is175 (let* ((session (xmtn-automate-cache-session root))
366options, cdr is command. Insert result into BUFFER."176 (command-handle (xmtn-automate--new-command session command nil)))
367 (xmtn-automate-with-session (session root)177 (xmtn-automate-command-check-for-and-report-error command-handle)
368 (xmtn-automate-with-command (handle session command)178 (xmtn-automate-command-wait-until-finished command-handle)
369 (xmtn-automate-command-check-for-and-report-error handle)179 (with-current-buffer buffer
370 (xmtn-automate-command-wait-until-finished handle)180 (insert-buffer-substring-no-properties
371 (with-current-buffer buffer181 (xmtn-automate-command-buffer command-handle)))
372 (xmtn--insert-buffer-substring-no-properties182 (xmtn-automate--cleanup-command command-handle)))
373 (xmtn-automate-command-buffer handle))))))
374183
375(defun xmtn-automate-command-output-lines (handle)184(defun xmtn-automate-command-output-lines (handle)
376 ;; Return list of lines of output; first line output is first in185 "Return list of lines of output in HANDLE; first line output is
377 ;; list.186first in list."
378 (xmtn-automate-command-check-for-and-report-error handle)187 (xmtn-automate-command-check-for-and-report-error handle)
379 (xmtn-automate-command-wait-until-finished handle)188 (xmtn-automate-command-wait-until-finished handle)
380 (save-excursion189 (save-excursion
@@ -387,16 +196,16 @@
387 (progn (end-of-line) (point)))196 (progn (end-of-line) (point)))
388 result))197 result))
389 (forward-line 1))198 (forward-line 1))
199 (xmtn-automate--cleanup-command handle)
390 (nreverse result))))200 (nreverse result))))
391201
392(defun xmtn-automate-simple-command-output-lines (root command)202(defun xmtn-automate-simple-command-output-lines (root command)
393 "Return list of strings containing output of COMMAND, one line per string."203 "Return list of strings containing output of COMMAND, one line per
394 (xmtn-automate-with-session (session root)204string."
395 (xmtn-automate-with-command (handle session command)205 (let* ((session (xmtn-automate-cache-session root))
396 (xmtn-automate-command-output-lines handle))))206 (command-handle (xmtn-automate--new-command session command nil)))
207 (xmtn-automate-command-output-lines command-handle)))
397208
398;; This one is used twice. I think the error checking it provides is
399;; a reasonable simplification for its callers.
400(defun xmtn-automate-simple-command-output-line (root command)209(defun xmtn-automate-simple-command-output-line (root command)
401 "Return the one line output from mtn automate as a string.210 "Return the one line output from mtn automate as a string.
402211
@@ -409,19 +218,11 @@
409 command))218 command))
410 (first lines)))219 (first lines)))
411220
412
413(defun xmtn-automate--set-process-session (process session)221(defun xmtn-automate--set-process-session (process session)
414 (xmtn--assert-optional (typep session 'xmtn-automate--session) t)222 (process-put process 'xmtn-automate--session session))
415 (xmtn--process-put process 'xmtn-automate--session session))
416223
417(defun xmtn-automate--process-session (process)224(defun xmtn-automate--process-session (process)
418 (xmtn--assert-optional (processp process) t)225 (process-get process 'xmtn-automate--session))
419 (let ((session (xmtn--process-get process 'xmtn-automate--session)))
420 ;; This seems to fail sometimes with session being nil. Not sure
421 ;; why. The problem seems to be reproducible by calling
422 ;; (dvc-dvc-revision-nth-ancestor `(xmtn (local-tree ,(dvc-tree-root))) 10).
423 (xmtn--assert-optional (typep session 'xmtn-automate--session) t)
424 session))
425226
426(defstruct (xmtn-automate--decoder-state227(defstruct (xmtn-automate--decoder-state
427 (:constructor xmtn-automate--%make-raw-decoder-state))228 (:constructor xmtn-automate--%make-raw-decoder-state))
@@ -437,8 +238,7 @@
437 (buffer nil)238 (buffer nil)
438 (process nil)239 (process nil)
439 (decoder-state)240 (decoder-state)
440 (next-mtn-command-number)241 (next-command-number 0)
441 (next-session-command-number 0)
442 (must-not-kill-counter)242 (must-not-kill-counter)
443 (remaining-command-handles)243 (remaining-command-handles)
444 (sent-kill-p)244 (sent-kill-p)
@@ -492,6 +292,7 @@
492 nil)292 nil)
493293
494(defun xmtn-automate--close-session (session)294(defun xmtn-automate--close-session (session)
295 "Kill session process, buffer."
495 (setf (xmtn-automate--session-closed-p session) t)296 (setf (xmtn-automate--session-closed-p session) t)
496 (let ((process (xmtn-automate--session-process session)))297 (let ((process (xmtn-automate--session-process session)))
497 (cond298 (cond
@@ -537,9 +338,8 @@
537 (let ((process-connection-type nil)338 (let ((process-connection-type nil)
538 (default-directory root))339 (default-directory root))
539 (let ((process340 (let ((process
540 (xmtn--with-environment-for-subprocess ()341 (apply 'start-process name buffer xmtn-executable
541 (apply #'start-process name buffer xmtn-executable342 "automate" "stdio" xmtn-additional-arguments)))
542 "automate" "stdio" xmtn-additional-arguments))))
543 (xmtn-automate--set-process-session process session)343 (xmtn-automate--set-process-session process session)
544 (set-process-filter process 'xmtn-automate--process-filter)344 (set-process-filter process 'xmtn-automate--process-filter)
545 (set-process-sentinel process 'xmtn-automate--process-sentinel)345 (set-process-sentinel process 'xmtn-automate--process-sentinel)
@@ -555,13 +355,13 @@
555 (xmtn--assert-optional (eql (point-min) (point)) t)355 (xmtn--assert-optional (eql (point-min) (point)) t)
556 (set-marker (make-marker)356 (set-marker (make-marker)
557 (point-min)))))357 (point-min)))))
558 (setf (xmtn-automate--session-next-mtn-command-number session) 0)
559 (setf (xmtn-automate--session-must-not-kill-counter session) 0)358 (setf (xmtn-automate--session-must-not-kill-counter session) 0)
560 (setf (xmtn-automate--session-remaining-command-handles session) (list))359 (setf (xmtn-automate--session-remaining-command-handles session) (list))
561 (setf (xmtn-automate--session-sent-kill-p session) nil)360 (setf (xmtn-automate--session-sent-kill-p session) nil)
562 process))))361 process))))
563362
564(defun xmtn-automate--ensure-process (session)363(defun xmtn-automate--ensure-process (session)
364 "Ensure SESSION has an active process; restart it if it died."
565 (let ((process (xmtn-automate--session-process session)))365 (let ((process (xmtn-automate--session-process session)))
566 (when (or (null process)366 (when (or (null process)
567 (ecase (process-status process)367 (ecase (process-status process)
@@ -575,33 +375,16 @@
575 process))375 process))
576376
577(defun xmtn-automate--new-buffer (session)377(defun xmtn-automate--new-buffer (session)
578 (let* ((buffer-base-name (format "*%s: session*"378 (let* ((buffer-base-name (format " *%s: session*"
579 (xmtn-automate--session-name session)))379 (xmtn-automate--session-name session)))
580 (buffer (generate-new-buffer buffer-base-name)))380 (buffer (generate-new-buffer buffer-base-name)))
581 (with-current-buffer buffer381 (with-current-buffer buffer
582 (buffer-disable-undo)382 (buffer-disable-undo)
583 (xmtn--set-buffer-multibyte nil)383 (set-buffer-multibyte nil)
584 (setq buffer-read-only t))384 (setq buffer-read-only t))
585 (setf (xmtn-automate--session-buffer session) buffer)385 (setf (xmtn-automate--session-buffer session) buffer)
586 buffer))386 buffer))
587387
588(defun xmtn-automate-terminate-processes-in-root (root)
589 (xmtn-automate-with-session (session root)
590 (xmtn-automate--close-session session)
591 (let ((process (xmtn-automate--session-process session)))
592 (when process
593 (while (ecase (process-status process)
594 (run t)
595 (exit nil)
596 (signal nil))
597 (accept-process-output process))
598 (dvc-trace "Process in root %s terminated" root)
599 ))
600 (xmtn-automate--initialize-session
601 session
602 :root (xmtn-automate--session-root session)
603 :name (xmtn-automate--session-name session))))
604
605(defun xmtn-automate--append-encoded-strings (strings)388(defun xmtn-automate--append-encoded-strings (strings)
606 "Encode STRINGS (a list of strings or nil) in automate stdio format,389 "Encode STRINGS (a list of strings or nil) in automate stdio format,
607insert into current buffer. Assumes that point is at the end of390insert into current buffer. Assumes that point is at the end of
@@ -616,12 +399,10 @@
616 (goto-char (point-max)))))399 (goto-char (point-max)))))
617 nil)400 nil)
618401
619(defun xmtn-automate--send-command-string (session command option-plist402(defun xmtn-automate--send-command-string (session command option-plist session-number)
620 mtn-number session-number)
621 "Send COMMAND and OPTION-PLIST to SESSION."403 "Send COMMAND and OPTION-PLIST to SESSION."
622 (let* ((buffer-name (format "*%s: input for command %s(%s)*"404 (let* ((buffer-name (format "*%s: input for command %s*"
623 (xmtn-automate--session-name session)405 (xmtn-automate--session-name session)
624 mtn-number
625 session-number))406 session-number))
626 (buffer nil))407 (buffer nil))
627 (unwind-protect408 (unwind-protect
@@ -635,7 +416,7 @@
635 (setq buffer (get-buffer-create buffer-name))416 (setq buffer (get-buffer-create buffer-name))
636 (with-current-buffer buffer417 (with-current-buffer buffer
637 (buffer-disable-undo)418 (buffer-disable-undo)
638 (xmtn--set-buffer-multibyte t)419 (set-buffer-multibyte t)
639 (setq buffer-read-only t)420 (setq buffer-read-only t)
640 (let ((inhibit-read-only t))421 (let ((inhibit-read-only t))
641 (when option-plist422 (when option-plist
@@ -655,22 +436,14 @@
655 (kill-buffer buffer))))))436 (kill-buffer buffer))))))
656437
657(defun xmtn-automate--new-command (session command may-kill-p)438(defun xmtn-automate--new-command (session command may-kill-p)
658 "Send COMMAND (a list of strings, or cons of lists of strings)439 "Send COMMAND to SESSION."
659to the current automate stdio session. If car COMMAND is a list,
660car COMMAND is options, cdr is command."
661 ;; For debugging.
662 ;;(xmtn-automate-terminate-processes-in-root
663 ;; (xmtn-automate--session-root session))
664 (xmtn-automate--ensure-process session)440 (xmtn-automate--ensure-process session)
665 (let* ((mtn-number (1- (incf (xmtn-automate--session-next-mtn-command-number441 (let* ((command-number
666 session))))442 (1- (incf (xmtn-automate--session-next-command-number
667 (session-number
668 (1- (incf (xmtn-automate--session-next-session-command-number
669 session))))443 session))))
670 (buffer-name (format "*%s: output for command %s(%s)*"444 (buffer-name (format " *%s: output for command %s*"
671 (xmtn-automate--session-name session)445 (xmtn-automate--session-name session)
672 mtn-number446 command-number))
673 session-number))
674 (buffer447 (buffer
675 (progn (when (get-buffer buffer-name)448 (progn (when (get-buffer buffer-name)
676 ;; Make sure no local variables or mode changes449 ;; Make sure no local variables or mode changes
@@ -681,21 +454,18 @@
681 (fundamental-mode)))454 (fundamental-mode)))
682 (get-buffer-create buffer-name))))455 (get-buffer-create buffer-name))))
683 (if (not (listp (car command)))456 (if (not (listp (car command)))
684 (xmtn-automate--send-command-string session command '()457 (xmtn-automate--send-command-string session command '() command-number)
685 mtn-number session-number)458 (xmtn-automate--send-command-string session (cdr command) (car command) command-number))
686 (xmtn-automate--send-command-string session (cdr command) (car command)
687 mtn-number session-number))
688 (with-current-buffer buffer459 (with-current-buffer buffer
689 (buffer-disable-undo)460 (buffer-disable-undo)
690 (xmtn--set-buffer-multibyte nil)461 (set-buffer-multibyte nil)
691 (setq buffer-read-only t)462 (setq buffer-read-only t)
692 (xmtn--assert-optional (and (eql (point) (point-min))463 (xmtn--assert-optional (and (eql (point) (point-min))
693 (eql (point) (point-max))))464 (eql (point) (point-max))))
694 (let ((handle (xmtn-automate--%make-raw-command-handle465 (let ((handle (xmtn-automate--%make-raw-command-handle
695 :session session466 :session session
696 :arguments command467 :arguments command
697 :mtn-command-number mtn-number468 :session-command-number command-number
698 :session-command-number session-number
699 :may-kill-p may-kill-p469 :may-kill-p may-kill-p
700 :buffer buffer470 :buffer buffer
701 :write-marker (set-marker (make-marker) (point)))))471 :write-marker (set-marker (make-marker) (point)))))
@@ -742,9 +512,9 @@
742 (goto-char write-marker)512 (goto-char write-marker)
743 (let ((inhibit-read-only t)513 (let ((inhibit-read-only t)
744 deactivate-mark)514 deactivate-mark)
745 (xmtn--insert-buffer-substring-no-properties session-buffer515 (insert-buffer-substring-no-properties session-buffer
746 read-marker516 read-marker
747 end))517 end))
748 (set-marker write-marker (point))))518 (set-marker write-marker (point))))
749 ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil)519 ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil)
750 )520 )
@@ -802,8 +572,9 @@
802 (xmtn-automate--decoder-state-last-p state))572 (xmtn-automate--decoder-state-last-p state))
803 (xmtn--assert-optional command)573 (xmtn--assert-optional command)
804 (setf (xmtn-automate--command-handle-finished-p command) t)574 (setf (xmtn-automate--command-handle-finished-p command) t)
805 (xmtn--with-no-warnings575 (with-no-warnings
806 (pop (xmtn-automate--session-remaining-command-handles session)))576 ;; discard result
577 (pop (xmtn-automate--session-remaining-command-handles session)))
807 (setq tag 'check-for-more)578 (setq tag 'check-for-more)
808 (when (not (xmtn-automate--command-handle-may-kill-p command))579 (when (not (xmtn-automate--command-handle-may-kill-p command))
809 (when (zerop (decf (xmtn-automate--session-must-not-kill-counter580 (when (zerop (decf (xmtn-automate--session-must-not-kill-counter
@@ -919,7 +690,7 @@
919 (message "Process %s died due to signal" (process-name process))690 (message "Process %s died due to signal" (process-name process))
920 (when (not (zerop (xmtn-automate--session-must-not-kill-counter691 (when (not (zerop (xmtn-automate--session-must-not-kill-counter
921 session)))692 session)))
922 (xmtn--lwarn693 (lwarn
923 'xmtn ':error694 'xmtn ':error
924 "Process %s died due to signal during a critical operation"695 "Process %s died due to signal during a critical operation"
925 (process-name process))))))))))696 (process-name process))))))))))
@@ -1007,6 +778,18 @@
1007(defun xmtn--tree-default-branch (root)778(defun xmtn--tree-default-branch (root)
1008 (xmtn-automate-simple-command-output-line root `("get_option" "branch")))779 (xmtn-automate-simple-command-output-line root `("get_option" "branch")))
1009780
781(defun xmtn-automate-local-changes (work)
782 "Summary of status for WORK; 'ok if no changes, 'need-commit if changes."
783 (message "checking %s for local changes" work)
784 (let ((default-directory work))
785
786 (let ((result (xmtn-automate-simple-command-output-string
787 default-directory
788 (list (list "no-unchanged" "no-ignored")
789 "inventory"))))
790 (if (> (length result) 0)
791 'need-commit
792 'ok))))
1010793
1011(provide 'xmtn-automate)794(provide 'xmtn-automate)
1012795
1013796
=== modified file 'lisp/xmtn-compat.el'
--- lisp/xmtn-compat.el 2009-10-03 12:39:58 +0000
+++ lisp/xmtn-compat.el 2010-02-25 22:31:14 +0000
@@ -1,6 +1,6 @@
1;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions1;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions
22
3;; Copyright (C) 2008 Stephen Leake3;; Copyright (C) 2008, 2009 Stephen Leake
4;; Copyright (C) 2006, 2007 Christian M. Ohler4;; Copyright (C) 2006, 2007 Christian M. Ohler
55
6;; Author: Christian M. Ohler6;; Author: Christian M. Ohler
@@ -34,36 +34,6 @@
34(eval-and-compile34(eval-and-compile
35 (require 'cl))35 (require 'cl))
3636
37(defun xmtn--temp-directory ()
38 (if (fboundp 'temp-directory)
39 (temp-directory)
40 temporary-file-directory))
41
42(defun xmtn--make-temp-file (prefix &optional dirp suffix)
43 ;; Do this in a temp buffer to ensure we use the default file output
44 ;; encoding. Emacs 21's `make-temp-file' uses the current buffer's
45 ;; output format function while writing the file with `write-region'
46 ;; with a string as its first argument, but coding conversion errors
47 ;; when `write-region' is called in this way.
48 (with-temp-buffer
49 ;; XEmacs' `make-temp-file' doesn't automatically use temp
50 ;; directory.
51 (setq prefix (expand-file-name prefix (xmtn--temp-directory)))
52 ;; FIXME: Ignoring suffix for now since Emacs 21 doesn't support it.
53 (make-temp-file prefix dirp)))
54
55(defvar xmtn--*process-plists* (make-hash-table :weakness 'key))
56
57;;; These should probably use `process-get' and `process-put' if
58;;; available, but that's not important.
59(defun xmtn--process-put (process propname value)
60 (setf (getf (gethash process xmtn--*process-plists*) propname) value)
61 ;; Mimic the return value that `process-put' would yield.
62 (gethash process xmtn--*process-plists*))
63
64(defsubst xmtn--process-get (process propname)
65 (getf (gethash process xmtn--*process-plists*) propname nil))
66
67(defmacro xmtn--set-process-query-on-exit-flag (process value)37(defmacro xmtn--set-process-query-on-exit-flag (process value)
68 (if (fboundp 'set-process-query-on-exit-flag)38 (if (fboundp 'set-process-query-on-exit-flag)
69 ;; emacs 22.2 and greater39 ;; emacs 22.2 and greater
@@ -73,54 +43,6 @@
73 (process-kill-without-query ,process ,value)43 (process-kill-without-query ,process ,value)
74 ,value)))44 ,value)))
7545
76(defmacro xmtn--insert-buffer-substring-no-properties (from-buffer
77 &optional start end)
78 (if (fboundp 'insert-buffer-substring-no-properties)
79 `(insert-buffer-substring-no-properties ,from-buffer ,start ,end)
80 `(progn
81 (insert (with-current-buffer ,from-buffer
82 (buffer-substring-no-properties (or ,start (point-min))
83 (or ,end (point-max)))))
84 nil)))
85
86(defun xmtn--lwarn (tag level message &rest args)
87 (if (fboundp 'lwarn)
88 (apply #'lwarn tag level message args)
89 (apply #'message message args))
90 ;; The return value of `lwarn' seems to be pretty much undefined, so
91 ;; we don't try to replicate it here.
92 nil)
93
94(defmacro* xmtn--with-no-warnings (&body body)
95 (if (fboundp 'with-no-warnings)
96 `(with-no-warnings ,@body)
97 `(progn ,@body)))
98
99(defmacro* xmtn--with-temp-message (message &body body)
100 (declare (indent 1) (debug (form body)))
101 (if (fboundp 'with-temp-message)
102 `(with-temp-message ,message ,@body)
103 `(progn ,@body)))
104
105(defmacro* xmtn--dotimes-with-progress-reporter ((i n-form &optional res-form)
106 message-form
107 &body body)
108 (declare (indent 2) (debug (sexp form body)))
109 (if (fboundp 'dotimes-with-progress-reporter)
110 `(dotimes-with-progress-reporter (,i ,n-form ,res-form)
111 ,message-form ,@body)
112 (let ((message (gensym)))
113 `(let ((,message ,message-form))
114 (prog1
115 (xmtn--with-temp-message ,message
116 (dotimes (,i ,n-form ,res-form)
117 ,@body))
118 (message "%sdone" ,message))))))
119
120(defmacro xmtn--set-buffer-multibyte (flag)
121 (when (fboundp 'set-buffer-multibyte)
122 `(set-buffer-multibyte ,flag)))
123
124(provide 'xmtn-compat)46(provide 'xmtn-compat)
12547
126;;; xmtn-compat.el ends here48;;; xmtn-compat.el ends here
12749
=== modified file 'lisp/xmtn-conflicts.el'
--- lisp/xmtn-conflicts.el 2009-10-03 12:41:39 +0000
+++ lisp/xmtn-conflicts.el 2010-02-25 22:31:14 +0000
@@ -1079,12 +1079,16 @@
1079 "Perform propagate on revisions in current conflict buffer."1079 "Perform propagate on revisions in current conflict buffer."
1080 (interactive)1080 (interactive)
1081 (save-some-buffers t); log buffer1081 (save-some-buffers t); log buffer
1082 ;; save-some-buffers does not save the conflicts buffer, which is the current buffer
1083 (save-buffer)
1082 (xmtn-propagate-from xmtn-conflicts-left-branch cached-branch))1084 (xmtn-propagate-from xmtn-conflicts-left-branch cached-branch))
10831085
1084(defun xmtn-conflicts-do-merge ()1086(defun xmtn-conflicts-do-merge ()
1085 "Perform merge on revisions in current conflict buffer."1087 "Perform merge on revisions in current conflict buffer."
1086 (interactive)1088 (interactive)
1087 (save-some-buffers t); log buffer1089 (save-some-buffers t); log buffer
1090 ;; save-some-buffers does not save the conflicts buffer, which is the current buffer
1091 (save-buffer)
1088 (xmtn-dvc-merge-1 default-directory nil))1092 (xmtn-dvc-merge-1 default-directory nil))
10891093
1090(defun xmtn-conflicts-ediff-resolution-ws ()1094(defun xmtn-conflicts-ediff-resolution-ws ()
10911095
=== modified file 'lisp/xmtn-dvc.el'
--- lisp/xmtn-dvc.el 2009-10-03 12:41:39 +0000
+++ lisp/xmtn-dvc.el 2010-02-25 22:31:14 +0000
@@ -83,16 +83,14 @@
83 `(let ((,root ,root-form)83 `(let ((,root ,root-form)
84 (,command ,command-form)84 (,command ,command-form)
85 (,may-kill-p ,may-kill-p-form))85 (,may-kill-p ,may-kill-p-form))
86 (xmtn-automate-with-session (,session ,root)86 (let* ((,session (xmtn-automate-cache-session ,root))
87 (xmtn-automate-with-command (,handle87 (,handle (xmtn-automate--new-command ,session ,command ,may-kill-p)))
88 ,session ,command88 (xmtn-automate-command-check-for-and-report-error ,handle)
89 :may-kill-p ,may-kill-p)89 (xmtn-automate-command-wait-until-finished ,handle)
90 (xmtn-automate-command-check-for-and-report-error ,handle)90 (xmtn-basic-io-with-stanza-parser (,parser
91 (xmtn-automate-command-wait-until-finished ,handle)91 (xmtn-automate-command-buffer
92 (xmtn-basic-io-with-stanza-parser (,parser92 ,handle))
93 (xmtn-automate-command-buffer93 ,@body)))))
94 ,handle))
95 ,@body))))))
9694
97;;;###autoload95;;;###autoload
98(defun xmtn-dvc-log-edit-file-name-func (&optional root)96(defun xmtn-dvc-log-edit-file-name-func (&optional root)
@@ -104,154 +102,6 @@
104 `("toposort"102 `("toposort"
105 ,@revision-hash-ids)))103 ,@revision-hash-ids)))
106104
107(defun xmtn--insert-log-edit-hints (root branch buffer prefix normalized-files)
108 (with-current-buffer buffer
109 (flet ((insert-line (&optional format-string-or-null &rest format-args)
110 (if format-string-or-null
111 (let ((line (apply #'format
112 format-string-or-null format-args)))
113 (assert (not (position ?\n line)))
114 (insert prefix line ?\n))
115 (assert (endp format-args))
116 (insert prefix ?\n))))
117 (save-excursion
118 ;; Launching these mtn processes in parallel is a noticeable
119 ;; speedup (~14% on some informal benchmarks). At least it
120 ;; was with the version that I benchmarked, etc.
121 (xmtn-automate-with-session (nil root)
122 (let* ((unknown-future (xmtn--unknown-files-future root))
123 (missing-future (xmtn--missing-files-future root))
124 (consistent-p-future (xmtn--tree-consistent-p-future root))
125 (heads (xmtn--heads root branch))
126 (inconsistent-p (not (funcall consistent-p-future)))
127 (revision (if inconsistent-p
128 nil
129 (xmtn--get-revision root `(local-tree ,root))))
130 (missing (funcall missing-future)))
131 (when inconsistent-p
132 (insert-line
133 "WARNING: Tree is not consistent.")
134 (insert-line "Commit will fail unless you fix this first.")
135 (insert-line))
136 (when missing
137 (insert-line "%s missing file(s):" (length missing))
138 (dolist (file missing) (insert-line "%s" file))
139 (insert-line)
140 (insert-line))
141 (insert-line "Committing on branch:")
142 (insert-line branch)
143 (insert-line)
144 (unless
145 (let* ((parents (xmtn--revision-old-revision-hash-ids revision))
146 (all-parents-are-heads-p
147 (subsetp parents heads :test #'equal))
148 (all-heads-are-parents-p
149 (subsetp heads parents :test #'equal)))
150 (cond ((and (not all-heads-are-parents-p)
151 (not all-parents-are-heads-p))
152 (insert-line "This commit will create divergence.")
153 (insert-line))
154 ((not all-heads-are-parents-p)
155 (insert-line (concat "Divergence will continue to exist"
156 " after this commit."))
157 (insert-line))
158 (t
159 (progn)))))
160 (case normalized-files
161 (all
162 (insert-line "All files selected for commit."))
163 (t
164 (insert-line "File(s) selected for commit:")
165 ;; Normalized file names are easier to read when coming
166 ;; from dired buffer, since otherwise, they would contain
167 ;; the entire path.
168 (dolist (file
169 ;; Sort in an attempt to match the order of
170 ;; "patch" lines, below.
171 (sort (copy-list normalized-files) #'string<))
172 (insert-line "%s" file))))
173 ;; Due to the possibility of race conditions, this check
174 ;; doesn't guarantee the operation will succeed.
175 (if inconsistent-p
176 ;; FIXME: Since automate get_revision can't deal with
177 ;; inconsistent workspaces, we should be using
178 ;; automate inventory instead.
179 (progn (insert-line)
180 (insert-line
181 (concat "Unable to compute modified files while"
182 " the tree is inconsistent.")))
183 (let ((committed-changes (list))
184 (other-changes (list)))
185 (flet ((collect (path message)
186 (if (or (eql normalized-files 'all)
187 (member path normalized-files))
188 (push message committed-changes)
189 (push message other-changes))))
190 (loop
191 for (path) in (xmtn--revision-delete revision)
192 do (collect path (format "delete %s" path)))
193 (loop
194 for (from to) in (xmtn--revision-rename revision)
195 ;; FIXME: collect from or collect to? Monotone
196 ;; doesn't specify how restrictions work for
197 ;; renamings.
198 do (collect to (format "rename %s to %s" from to)))
199 (loop
200 for (path) in (xmtn--revision-add-dir revision)
201 do (collect path (format "add_dir %s" path)))
202 (loop
203 for (path contents)
204 in (xmtn--revision-add-file revision)
205 do (collect path (format "add_file %s" path)))
206 (loop
207 for (path from-contents to-contents)
208 in (xmtn--revision-patch-file revision)
209 do (collect path (format "patch %s" path)))
210 (loop
211 for (path attr-name)
212 in (xmtn--revision-clear-attr revision)
213 do (collect path (format "clear %s %s"
214 path attr-name)))
215 (loop
216 for (path attr-name attr-value)
217 in (xmtn--revision-set-attr revision)
218 do (collect path (format "set %s %s %s"
219 path attr-name attr-value))))
220 (setq committed-changes (nreverse committed-changes))
221 (setq other-changes (nreverse other-changes))
222 (loop
223 for (lines heading-if heading-if-not) in
224 `((,committed-changes
225 ,(format "%s change(s) in selected files:"
226 (length committed-changes))
227 "No changes in selected files.")
228 (,other-changes
229 ,(format
230 "%s change(s) in files not selected for commit:"
231 (length other-changes))
232 "No changes in files not selected for commit."))
233 do
234 (insert-line)
235 (insert-line "%s" (if lines heading-if heading-if-not))
236 (dolist (line lines) (insert-line "%s" line)))))
237 (let ((unknown (funcall unknown-future)))
238 (insert-line)
239 (if (endp unknown)
240 (insert-line "No unknown files.")
241 (insert-line "%s unknown file(s):" (length unknown))
242 (dolist (file unknown) (insert-line "%s" file))))))))
243 (cond ((eql (point) (point-min))
244 ;; We take this as an indicator that there is no log message
245 ;; yet. So insert a blank line.
246 (insert "\n")
247 (goto-char (point-min)))
248 (t
249 ;; Moving up onto the last line of the log message seems to
250 ;; be better than having the cursor sit at the ## prefix of
251 ;; the first line of our hints.
252 (forward-line -1))))
253 nil)
254
255(add-to-list 'format-alist105(add-to-list 'format-alist
256 '(xmtn--log-file106 '(xmtn--log-file
257 "This format automatically removes xmtn's log edit hints from107 "This format automatically removes xmtn's log edit hints from
@@ -670,18 +520,6 @@
670 (setq xmtn-dvc-automate-version520 (setq xmtn-dvc-automate-version
671 (string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))521 (string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))
672522
673(defun xmtn--unknown-files-future (root)
674 (xmtn--command-output-lines-future root '("ls" "unknown")))
675
676(defun xmtn--missing-files-future (root)
677 (xmtn--command-output-lines-future root '("ls" "missing")))
678
679(defun xmtn--tree-consistent-p-future (root)
680 ;; FIXME: Should also check for file/dir mismatches.
681 (lexical-let ((missing-files-future (xmtn--missing-files-future root)))
682 (lambda ()
683 (null (funcall missing-files-future)))))
684
685(defun xmtn--changes-image (change)523(defun xmtn--changes-image (change)
686 (ecase change524 (ecase change
687 (content "content")525 (content "content")
@@ -1073,20 +911,6 @@
1073 (xmtn--run-command-sync root911 (xmtn--run-command-sync root
1074 `("add" "--" ,@file-names)))912 `("add" "--" ,@file-names)))
1075913
1076(defun xmtn--file-registered-p (root file-name)
1077 ;; FIXME: need a better way to implement this
1078 (let ((normalized-file-name (xmtn--normalize-file-name root file-name)))
1079 (block parse
1080 (xmtn--with-automate-command-output-basic-io-parser
1081 (parser root `("inventory"))
1082 (xmtn--parse-inventory parser
1083 (lambda (path status changes old-path new-path
1084 old-type new-type fs-type)
1085 (when (equal normalized-file-name path)
1086 (return-from parse
1087 t)))))
1088 nil)))
1089
1090;;;###autoload914;;;###autoload
1091(defun xmtn-dvc-add-files (&rest files)915(defun xmtn-dvc-add-files (&rest files)
1092 (xmtn--add-files (dvc-tree-root) files))916 (xmtn--add-files (dvc-tree-root) files))
@@ -1214,13 +1038,6 @@
1214 nil)1038 nil)
1215 nil)1039 nil)
12161040
1217(defun xmtn--do-disapprove-future (root revision-hash-id)
1218 ;; Returns a future so the calling code can block on its completion
1219 ;; if it wants to.
1220 (check-type root string)
1221 (check-type revision-hash-id xmtn--hash-id)
1222 (xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id)))
1223
1224(defun xmtn--do-update (root target-revision-hash-id post-update-p)1041(defun xmtn--do-update (root target-revision-hash-id post-update-p)
1225 (check-type root string)1042 (check-type root string)
1226 (check-type target-revision-hash-id xmtn--hash-id)1043 (check-type target-revision-hash-id xmtn--hash-id)
@@ -1264,23 +1081,22 @@
1264;;;###autoload1081;;;###autoload
1265(defun xmtn-dvc-update (&optional revision-id no-ding)1082(defun xmtn-dvc-update (&optional revision-id no-ding)
1266 (let ((root (dvc-tree-root)))1083 (let ((root (dvc-tree-root)))
1267 (xmtn-automate-with-session (nil root)1084 (if revision-id
1268 (if revision-id1085 (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
1269 (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)1086
12701087 (let* ((branch (xmtn--tree-default-branch root))
1271 (let* ((branch (xmtn--tree-default-branch root))1088 (heads (xmtn--heads root branch)))
1272 (heads (xmtn--heads root branch)))1089 (case (length heads)
1273 (case (length heads)1090 (0 (assert nil))
1274 (0 (assert nil))1091 (1
1275 (11092 (xmtn--update root (first heads) t no-ding))
1276 (xmtn--update root (first heads) t no-ding))1093
12771094 (t
1278 (t1095 ;; User can choose one head from a revlist, or merge them.
1279 ;; User can choose one head from a revlist, or merge them.1096 (error (substitute-command-keys
1280 (error (substitute-command-keys1097 (concat "Branch %s is unmerged (%s heads)."
1281 (concat "Branch %s is unmerged (%s heads)."1098 " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
1282 " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))1099 branch (length heads)))))))
1283 branch (length heads))))))))
1284 nil)1100 nil)
12851101
1286(defun xmtn-propagate-from (other &optional cached-branch)1102(defun xmtn-propagate-from (other &optional cached-branch)
@@ -1325,18 +1141,16 @@
13251141
1326(defun xmtn-dvc-merge-1 (root refresh-status)1142(defun xmtn-dvc-merge-1 (root refresh-status)
1327 (lexical-let ((refresh-status refresh-status))1143 (lexical-let ((refresh-status refresh-status))
1328 (xmtn-automate-with-session1144 (xmtn--run-command-async
1329 (nil root)1145 root
1330 (xmtn--run-command-async1146 (list
1331 root1147 "merge"
1332 (list1148 (if (file-exists-p (concat root "/_MTN/conflicts"))
1333 "merge"1149 "--resolve-conflicts-file=_MTN/conflicts")
1334 (if (file-exists-p (concat root "/_MTN/conflicts"))1150 (xmtn-dvc-log-message))
1335 "--resolve-conflicts-file=_MTN/conflicts")1151 :finished (lambda (output error status arguments)
1336 (xmtn-dvc-log-message))1152 (if refresh-status
1337 :finished (lambda (output error status arguments)1153 (xmtn--refresh-status-header (current-buffer)))))))
1338 (if refresh-status
1339 (xmtn--refresh-status-header (current-buffer))))))))
13401154
1341;;;###autoload1155;;;###autoload
1342(defun xmtn-dvc-merge (&optional other)1156(defun xmtn-dvc-merge (&optional other)
@@ -1410,74 +1224,70 @@
1410(defun xmtn--revision-get-file-helper (file backend-id)1224(defun xmtn--revision-get-file-helper (file backend-id)
1411 "Fill current buffer with the contents of FILE revision BACKEND-ID."1225 "Fill current buffer with the contents of FILE revision BACKEND-ID."
1412 (let ((root (dvc-tree-root)))1226 (let ((root (dvc-tree-root)))
1413 (xmtn-automate-with-session (nil root)1227 (let* ((normalized-file (xmtn--normalize-file-name root file))
1414 (let* ((normalized-file (xmtn--normalize-file-name root file))1228 (corresponding-file
1415 (corresponding-file1229 (xmtn--get-corresponding-path root normalized-file
1416 (xmtn--get-corresponding-path root normalized-file1230 `(local-tree ,root) backend-id)))
1417 `(local-tree ,root) backend-id)))1231 (if (null corresponding-file)
1418 (if (null corresponding-file)1232 ;; File doesn't exist. Since this function is (as far
1419 ;; File doesn't exist. Since this function is (as far1233 ;; as I know) only called from diff-like functions, a
1420 ;; as I know) only called from diff-like functions, a1234 ;; missing file is not an error but just means the diff
1421 ;; missing file is not an error but just means the diff1235 ;; should be computed against an empty file. So just
1422 ;; should be computed against an empty file. So just1236 ;; leave the buffer empty.
1423 ;; leave the buffer empty.1237 (progn)
1424 (progn)1238 (let ((temp-dir nil))
1425 (let ((temp-dir nil))1239 (unwind-protect
1426 (unwind-protect1240 (progn
1427 (progn1241 (setq temp-dir (make-temp-file
1428 (setq temp-dir (xmtn--make-temp-file1242 "xmtn--revision-get-file-" t))
1429 "xmtn--revision-get-file-" t))1243 ;; Going through a temporary file and using
1430 ;; Going through a temporary file and using1244 ;; `insert-file-contents' in conjunction with as
1431 ;; `insert-file-contents' in conjunction with as1245 ;; much of the original file name as possible seems
1432 ;; much of the original file name as possible seems1246 ;; to be the best way to make sure that Emacs'
1433 ;; to be the best way to make sure that Emacs'1247 ;; entire file coding system detection logic is
1434 ;; entire file coding system detection logic is1248 ;; applied. Functions like
1435 ;; applied. Functions like1249 ;; `find-operation-coding-system' and
1436 ;; `find-operation-coding-system' and1250 ;; `find-file-name-handler' are not a complete
1437 ;; `find-file-name-handler' are not a complete1251 ;; replacement since they don't look at the contents
1438 ;; replacement since they don't look at the contents1252 ;; at all.
1439 ;; at all.1253 (let ((temp-file (concat temp-dir "/" corresponding-file)))
1440 (let ((temp-file (concat temp-dir "/" corresponding-file)))1254 (make-directory (file-name-directory temp-file) t)
1441 (make-directory (file-name-directory temp-file) t)1255 (with-temp-file temp-file
1442 (with-temp-file temp-file1256 (set-buffer-multibyte nil)
1443 (xmtn--set-buffer-multibyte nil)1257 (setq buffer-file-coding-system 'binary)
1444 (setq buffer-file-coding-system 'binary)1258 (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
1445 (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))1259 (let ((output-buffer (current-buffer)))
1446 (let ((output-buffer (current-buffer)))1260 (with-temp-buffer
1447 (with-temp-buffer1261 (insert-file-contents temp-file)
1448 (insert-file-contents temp-file)1262 (let ((input-buffer (current-buffer)))
1449 (let ((input-buffer (current-buffer)))1263 (with-current-buffer output-buffer
1450 (with-current-buffer output-buffer1264 (insert-buffer-substring input-buffer)))))))
1451 (insert-buffer-substring input-buffer)))))))1265 (when temp-dir
1452 (when temp-dir1266 (dvc-delete-recursively temp-dir))))))))
1453 (dvc-delete-recursively temp-dir)))))))))
14541267
1455(defun xmtn--get-file-by-id (root file-id save-as)1268(defun xmtn--get-file-by-id (root file-id save-as)
1456 "Store contents of FILE-ID in file SAVE-AS."1269 "Store contents of FILE-ID in file SAVE-AS."
1457 (xmtn-automate-with-session1270 (with-temp-file save-as
1458 (nil root)1271 (set-buffer-multibyte nil)
1459 (with-temp-file save-as1272 (setq buffer-file-coding-system 'binary)
1460 (xmtn--set-buffer-multibyte nil)1273 (xmtn--insert-file-contents root file-id (current-buffer))))
1461 (setq buffer-file-coding-system 'binary)
1462 (xmtn--insert-file-contents root file-id (current-buffer)))))
14631274
1464(defun xmtn--revision-parents (root revision-hash-id)1275(defun xmtn--revision-parents (root revision-hash-id)
1465 (xmtn-automate-simple-command-output-lines root1276 (xmtn-automate-simple-command-output-lines root
1466 `("parents" ,revision-hash-id)))1277 `("parents" ,revision-hash-id)))
14671278
1468(defun xmtn--get-content-changed (root backend-id normalized-file)1279(defun xmtn--get-content-changed (root backend-id normalized-file)
1469 (xmtn-automate-with-session (nil root)1280 (xmtn-match (xmtn--resolve-backend-id root backend-id)
1470 (xmtn-match (xmtn--resolve-backend-id root backend-id)1281 ((local-tree $path) (error "Not implemented"))
1471 ((local-tree $path) (error "Not implemented"))1282 ((revision $revision-hash-id)
1472 ((revision $revision-hash-id)1283 (xmtn--with-automate-command-output-basic-io-parser
1473 (xmtn--with-automate-command-output-basic-io-parser1284 (parser root `("get_content_changed" ,revision-hash-id
1474 (parser root `("get_content_changed" ,revision-hash-id1285 ,normalized-file))
1475 ,normalized-file))1286 (loop for stanza = (funcall parser)
1476 (loop for stanza = (funcall parser)1287 while stanza
1477 while stanza1288 collect (xmtn-match stanza
1478 collect (xmtn-match stanza1289 ((("content_mark" (id $previous-id)))
1479 ((("content_mark" (id $previous-id)))1290 previous-id)))))))
1480 previous-id))))))))
14811291
1482(defun xmtn--limit-length (list n)1292(defun xmtn--limit-length (list n)
1483 (or (null n) (<= (length list) n)))1293 (or (null n) (<= (length list) n)))
@@ -1499,39 +1309,37 @@
1499 current-set))1309 current-set))
15001310
1501(defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n)1311(defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n)
1502 (xmtn-automate-with-session (nil root)1312 (lexical-let ((root root))
1503 (lexical-let ((root root))1313 (labels ((changed-self-or-ancestors (entry)
1504 (labels ((changed-self-or-ancestors (entry)1314 (destructuring-bind (hash-id file-name) entry
1505 (destructuring-bind (hash-id file-name) entry1315 (check-type file-name string)
1506 (check-type file-name string)1316 ;; get-content-changed can return one or two revisions
1507 ;; get-content-changed can return one or two revisions1317 (loop for next-change-id in (xmtn--get-content-changed
1508 (loop for next-change-id in (xmtn--get-content-changed1318 root `(revision ,hash-id)
1509 root `(revision ,hash-id)1319 file-name)
1510 file-name)1320 for corresponding-path =
1511 for corresponding-path =1321 (xmtn--get-corresponding-path-raw root file-name
1512 (xmtn--get-corresponding-path-raw root file-name1322 hash-id next-change-id)
1513 hash-id next-change-id)1323 when corresponding-path
1514 when corresponding-path1324 collect `(,next-change-id ,corresponding-path))))
1515 collect `(,next-change-id ,corresponding-path))))1325 (changed-proper-ancestors (entry)
1516 (changed-proper-ancestors (entry)1326 (destructuring-bind (hash-id file-name) entry
1517 (destructuring-bind (hash-id file-name) entry1327 (check-type file-name string)
1518 (check-type file-name string)1328 ;; revision-parents can return one or two revisions
1519 ;; revision-parents can return one or two revisions1329 (loop for parent-id in (xmtn--revision-parents root hash-id)
1520 (loop for parent-id in (xmtn--revision-parents root hash-id)1330 for path-in-parent =
1521 for path-in-parent =1331 (xmtn--get-corresponding-path-raw root file-name
1522 (xmtn--get-corresponding-path-raw root file-name1332 hash-id parent-id)
1523 hash-id parent-id)1333 when path-in-parent
1524 when path-in-parent1334 append (changed-self-or-ancestors
1525 append (changed-self-or-ancestors1335 `(,parent-id ,path-in-parent))))))
1526 `(,parent-id ,path-in-parent))))))1336 (xmtn--close-set
1527 (xmtn--close-set1337 #'changed-proper-ancestors
1528 #'changed-proper-ancestors1338 (xmtn-match (xmtn--resolve-backend-id root backend-id)
1529 (xmtn-match (xmtn--resolve-backend-id root backend-id)1339 ((local-tree $path) (error "Not implemented"))
1530 ((local-tree $path) (error "Not implemented"))1340 ((revision $id) (changed-self-or-ancestors
1531 ((revision $id) (changed-self-or-ancestors1341 `(,id ,normalized-file))))
1532 `(,id ,normalized-file))))1342 last-n))))
1533 last-n)))))
1534
15351343
1536(defun xmtn--get-corresponding-path-raw (root normalized-file-name1344(defun xmtn--get-corresponding-path-raw (root normalized-file-name
1537 source-revision-hash-id1345 source-revision-hash-id
@@ -1553,53 +1361,52 @@
1553 source-revision-backend-id1361 source-revision-backend-id
1554 target-revision-backend-id)1362 target-revision-backend-id)
1555 (block get-corresponding-path1363 (block get-corresponding-path
1556 (xmtn-automate-with-session (nil root)1364 (let (source-revision-hash-id
1557 (let (source-revision-hash-id1365 target-revision-hash-id
1558 target-revision-hash-id1366 (file-name-postprocessor #'identity))
1559 (file-name-postprocessor #'identity))1367 (let ((resolved-source-revision
1560 (let ((resolved-source-revision1368 (xmtn--resolve-backend-id root source-revision-backend-id))
1561 (xmtn--resolve-backend-id root source-revision-backend-id))1369 (resolved-target-revision
1562 (resolved-target-revision1370 (xmtn--resolve-backend-id root target-revision-backend-id)))
1563 (xmtn--resolve-backend-id root target-revision-backend-id)))1371 (xmtn-match resolved-source-revision
1564 (xmtn-match resolved-source-revision1372 ((revision $hash-id)
1565 ((revision $hash-id)1373 (setq source-revision-hash-id hash-id))
1566 (setq source-revision-hash-id hash-id))1374 ((local-tree $path)
1567 ((local-tree $path)1375 (assert (xmtn--same-tree-p root path))
1568 (assert (xmtn--same-tree-p root path))1376 (let ((base-revision-hash-id
1569 (let ((base-revision-hash-id1377 (xmtn--get-base-revision-hash-id-or-null path)))
1570 (xmtn--get-base-revision-hash-id-or-null path)))1378 (if (null base-revision-hash-id)
1571 (if (null base-revision-hash-id)1379 (xmtn-match resolved-target-revision
1572 (xmtn-match resolved-target-revision1380 ((revision $hash-id)
1573 ((revision $hash-id)1381 (return-from get-corresponding-path nil))
1574 (return-from get-corresponding-path nil))1382 ((local-tree $target-path)
1575 ((local-tree $target-path)1383 (assert (xmtn--same-tree-p path target-path))
1576 (assert (xmtn--same-tree-p path target-path))1384 (return-from get-corresponding-path normalized-file-name)))
1577 (return-from get-corresponding-path normalized-file-name)))1385 (setq normalized-file-name (xmtn--get-rename-in-workspace-to
1578 (setq normalized-file-name (xmtn--get-rename-in-workspace-to1386 path normalized-file-name))
1579 path normalized-file-name))1387 (setq source-revision-hash-id base-revision-hash-id)))))
1580 (setq source-revision-hash-id base-revision-hash-id)))))1388 (xmtn-match resolved-target-revision
1581 (xmtn-match resolved-target-revision1389 ((revision $hash-id)
1582 ((revision $hash-id)1390 (setq target-revision-hash-id hash-id))
1583 (setq target-revision-hash-id hash-id))1391 ((local-tree $path)
1584 ((local-tree $path)1392 (assert (xmtn--same-tree-p root path))
1585 (assert (xmtn--same-tree-p root path))1393 (let ((base-revision-hash-id
1586 (let ((base-revision-hash-id1394 (xmtn--get-base-revision-hash-id-or-null path)))
1587 (xmtn--get-base-revision-hash-id-or-null path)))1395 (if (null base-revision-hash-id)
1588 (if (null base-revision-hash-id)1396 (return-from get-corresponding-path nil)
1589 (return-from get-corresponding-path nil)1397 (setq target-revision-hash-id base-revision-hash-id
1590 (setq target-revision-hash-id base-revision-hash-id1398 file-name-postprocessor
1591 file-name-postprocessor1399 (lexical-let ((path path))
1592 (lexical-let ((path path))1400 (lambda (file-name)
1593 (lambda (file-name)1401 (xmtn--get-rename-in-workspace-from path
1594 (xmtn--get-rename-in-workspace-from path1402 file-name)))))))))
1595 file-name)))))))))1403 (let ((result
1596 (let ((result1404 (xmtn--get-corresponding-path-raw root normalized-file-name
1597 (xmtn--get-corresponding-path-raw root normalized-file-name1405 source-revision-hash-id
1598 source-revision-hash-id1406 target-revision-hash-id)))
1599 target-revision-hash-id)))1407 (if (null result)
1600 (if (null result)1408 nil
1601 nil1409 (funcall file-name-postprocessor result))))))
1602 (funcall file-name-postprocessor result)))))))
16031410
1604(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)1411(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)
1605 ;; FIXME: need a better way to implement this1412 ;; FIXME: need a better way to implement this
@@ -1632,25 +1439,6 @@
1632 old-path)))))1439 old-path)))))
1633 normalized-target-file-name))1440 normalized-target-file-name))
16341441
1635(defun xmtn--manifest-find-file (root manifest normalized-file-name)
1636 (let ((matches (remove* normalized-file-name
1637 (remove* 'file manifest :key #'first :test-not #'equal)
1638 :key #'second :test-not #'equal)))
1639 (xmtn--assert-optional (member (length matches) '(0 1)))
1640 (first matches)))
1641
1642(defun xmtn--revision-manifest-file-entry (root backend-id
1643 normalized-file-name)
1644 (let ((manifest (xmtn--get-manifest root backend-id)))
1645 (xmtn--manifest-find-file root manifest normalized-file-name)))
1646
1647(defun xmtn--revision-file-contents-hash (root backend-id normalized-file-name)
1648 (xmtn-match (xmtn--revision-manifest-file-entry root backend-id
1649 normalized-file-name)
1650 ((file $relative-path $file-contents-hash $attrs)
1651 (assert (equal relative-path normalized-file-name))
1652 file-contents-hash)))
1653
1654(defun xmtn--file-contents-as-string (root content-hash-id)1442(defun xmtn--file-contents-as-string (root content-hash-id)
1655 (check-type content-hash-id xmtn--hash-id)1443 (check-type content-hash-id xmtn--hash-id)
1656 (xmtn-automate-simple-command-output-string1444 (xmtn-automate-simple-command-output-string
@@ -1674,51 +1462,6 @@
1674(defun xmtn--same-tree-p (a b)1462(defun xmtn--same-tree-p (a b)
1675 (equal (file-truename a) (file-truename b)))1463 (equal (file-truename a) (file-truename b)))
16761464
1677(defun xmtn--get-manifest (root backend-id)
1678 (xmtn-automate-with-session (nil root)
1679 (let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
1680 (xmtn--with-automate-command-output-basic-io-parser
1681 (parser root `("get_manifest_of"
1682 ,@(xmtn-match resolved-id
1683 ((local-tree $path)
1684 ;; FIXME: I don't really know what to do if
1685 ;; PATH is not the same as ROOT. Maybe
1686 ;; revision id resolution needs to return
1687 ;; the proper root, too.
1688 (assert (xmtn--same-tree-p root path))
1689 (unless (funcall
1690 (xmtn--tree-consistent-p-future root))
1691 (error "Tree is inconsistent, unable to get manifest"))
1692 '())
1693 ((revision $hash-id)
1694 `(,hash-id)))))
1695 (assert (equal (funcall parser) '(("format_version" (string "1")))))
1696 (loop for stanza = (funcall parser)
1697 while stanza
1698 collect (xmtn-match stanza
1699 ((("dir" (string $normalized-path)))
1700 (let ((dir (decode-coding-string
1701 normalized-path
1702 'xmtn--monotone-normal-form)))
1703 (xmtn--assert-optional
1704 (or (equal dir "")
1705 (not (eql (aref dir (1- (length dir))) ?/))))
1706 `(dir ,dir)))
1707 ((("file" (string $normalized-path))
1708 ("content" (id $hash-id))
1709 . $attrs)
1710 `(file
1711 ,(decode-coding-string
1712 normalized-path 'xmtn--monotone-normal-form)
1713 ,hash-id
1714 ,(mapcar (lambda (attr-entry)
1715 (xmtn-match attr-entry
1716 (("attr"
1717 (string $attr-name)
1718 (string $attr-value))
1719 (list attr-name attr-value))))
1720 attrs)))))))))
1721
1722(defstruct (xmtn--revision (:constructor xmtn--make-revision))1465(defstruct (xmtn--revision (:constructor xmtn--make-revision))
1723 ;; matches data output by 'mtn diff'1466 ;; matches data output by 'mtn diff'
1724 new-manifest-hash-id1467 new-manifest-hash-id
@@ -1732,35 +1475,6 @@
1732 set-attr1475 set-attr
1733 )1476 )
17341477
1735
1736(defun xmtn--get-revision (root backend-id)
1737 (xmtn-automate-with-session (nil root)
1738 (let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
1739 (xmtn--with-automate-command-output-basic-io-parser
1740 (parser root `("get_revision"
1741 ,@(xmtn-match resolved-id
1742 ((local-tree $path)
1743 ;; FIXME: I don't really know what to do if
1744 ;; PATH is not the same as ROOT. Maybe
1745 ;; revision id resolution needs to return
1746 ;; the proper root, too.
1747 (assert (xmtn--same-tree-p root path))
1748 (unless (funcall
1749 (xmtn--tree-consistent-p-future root))
1750 (error (concat "Tree is inconsistent,"
1751 " unable to compute revision")))
1752 '())
1753 ((revision $hash-id)
1754 `(,hash-id)))))
1755 (assert (equal (funcall parser) '(("format_version" (string "1")))))
1756 (let ((new-manifest-hash-id (xmtn-match (funcall parser)
1757 ((("new_manifest" (id $hash-id)))
1758 hash-id))))
1759 (let ((proto-revision (xmtn--parse-partial-revision parser)))
1760 (setf (xmtn--revision-new-manifest-hash-id proto-revision)
1761 new-manifest-hash-id)
1762 proto-revision))))))
1763
1764(defun xmtn--parse-partial-revision (parser)1478(defun xmtn--parse-partial-revision (parser)
1765 "Parse basic_io output from get_revision, starting with the old_revision stanzas."1479 "Parse basic_io output from get_revision, starting with the old_revision stanzas."
1766 (let ((old-revision-hash-ids (list))1480 (let ((old-revision-hash-ids (list))
17671481
=== modified file 'lisp/xmtn-ids.el'
--- lisp/xmtn-ids.el 2009-10-03 12:39:58 +0000
+++ lisp/xmtn-ids.el 2010-02-25 22:31:14 +0000
@@ -217,21 +217,22 @@
217(defun xmtn--branches-of (hash-id)217(defun xmtn--branches-of (hash-id)
218 "Return list of branch names for HASH-ID. `default-directory'218 "Return list of branch names for HASH-ID. `default-directory'
219must be a workspace."219must be a workspace."
220 (let (result)220 (let* (result
221 (xmtn-automate-with-session (session default-directory)221 (session (xmtn-automate-cache-session default-directory))
222 (xmtn-automate-with-command (handle session `("certs" ,hash-id))222 (handle (xmtn-automate--new-command session `("certs" ,hash-id) nil)))
223 (xmtn-automate-command-wait-until-finished handle)223 (xmtn-automate-command-wait-until-finished handle)
224 (with-current-buffer (xmtn-automate-command-buffer handle)224 (with-current-buffer (xmtn-automate-command-buffer handle)
225 ;; now in buffer containing basic_io certs; find the branch certs225 ;; now in buffer containing basic_io certs; find the branch certs
226 (goto-char (point-min))226 (goto-char (point-min))
227 (while (not (xmtn-basic-io-eof))227 (while (not (xmtn-basic-io-eof))
228 (xmtn-basic-io-optional-line "name"228 (xmtn-basic-io-optional-line "name"
229 (if (and (eq 'string (caar value))229 (if (and (eq 'string (caar value))
230 (string= "branch" (cadar value)))230 (string= "branch" (cadar value)))
231 (xmtn-basic-io-parse-line231 (xmtn-basic-io-parse-line
232 (if (string= symbol "value")232 (if (string= symbol "value")
233 (add-to-list 'result (cadar value)))))233 (add-to-list 'result (cadar value)))))
234 )))))234 )))
235 (xmtn-automate--cleanup-command handle)
235 result))236 result))
236237
237(defun xmtn--get-base-revision-hash-id-or-null (root)238(defun xmtn--get-base-revision-hash-id-or-null (root)
238239
=== added file 'lisp/xmtn-multi-status.el'
--- lisp/xmtn-multi-status.el 1970-01-01 00:00:00 +0000
+++ lisp/xmtn-multi-status.el 2010-02-25 22:31:14 +0000
@@ -0,0 +1,450 @@
1;;; xmtn-status.el --- manage actions for multiple projects
2
3;; Copyright (C) 2009 Stephen Leake
4
5;; Author: Stephen Leake
6;; Keywords: tools
7
8;; This file is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation; either version 2 of the License, or
11;; (at your option) any later version.
12;;
13;; This file is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17;;
18;; You should have received a copy of the GNU General Public License
19;; along with this file; see the file COPYING. If not, write to
20;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
21;; Boston, MA 02110-1301 USA.
22
23(eval-and-compile
24 ;; these have macros we use
25 (require 'xmtn-ids))
26
27(eval-when-compile
28 ;; these have functions we use
29 (require 'xmtn-base)
30 (require 'xmtn-conflicts))
31
32(defvar xmtn-status-root ""
33 "Buffer-local variable holding root directory.")
34(make-variable-buffer-local 'xmtn-status-root)
35(put 'xmtn-status-root 'permanent-local t)
36
37(defvar xmtn-status-ewoc nil
38 "Buffer-local ewoc for displaying propagations.
39All xmtn-status functions operate on this ewoc.
40The elements must all be of class xmtn-status-data.")
41(make-variable-buffer-local 'xmtn-status-ewoc)
42(put 'xmtn-status-ewoc 'permanent-local t)
43
44(defstruct (xmtn-status-data (:copier nil))
45 work ; directory name relative to xmtn-status-root
46 branch ; branch name (assumed never changes)
47 need-refresh ; nil | t : if an async process was started that invalidates state data
48 head-rev ; nil | mtn rev string : current head revision, nil if multiple heads
49 conflicts-buffer ; *xmtn-conflicts* buffer for merge
50 heads ; 'need-scan | 'at-head | 'need-update | 'need-merge)
51 (local-changes
52 'need-scan) ; 'need-scan | 'need-commit | 'ok
53 (conflicts
54 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none
55 )
56
57(defun xmtn-status-work (data)
58 (concat xmtn-status-root (xmtn-status-data-work data)))
59
60(defun xmtn-status-need-refresh (elem data)
61 ;; The user has selected an action that will change the state of the
62 ;; workspace via mtn actions; set our data to reflect that. We
63 ;; assume the user will not be creating new files or editing
64 ;; existing ones.
65 (setf (xmtn-status-data-need-refresh data) t)
66 (setf (xmtn-status-data-heads data) 'need-scan)
67 (setf (xmtn-status-data-conflicts data) 'need-scan)
68 (ewoc-invalidate xmtn-status-ewoc elem))
69
70(defun xmtn-status-printer (data)
71 "Print an ewoc element."
72 (insert (dvc-face-add (format "%s\n" (xmtn-status-data-work data)) 'dvc-keyword))
73
74 (if (xmtn-status-data-need-refresh data)
75 (insert (dvc-face-add " need refresh\n" 'dvc-conflict))
76
77 (ecase (xmtn-status-data-local-changes data)
78 (need-scan (insert " from local changes unknown\n"))
79 (need-commit (insert (dvc-face-add " need dvc-status\n" 'dvc-header)))
80 (ok nil))
81
82 (ecase (xmtn-status-data-conflicts data)
83 (need-scan
84 (insert "conflicts need scan\n"))
85 (need-resolve
86 (insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict)))
87 (need-review-resolve-internal
88 (insert (dvc-face-add " need review resolve internal\n" 'dvc-header)))
89 (resolved
90 (insert " conflicts resolved\n"))
91 ((resolved none) nil))
92
93 (ecase (xmtn-status-data-heads data)
94 (at-head nil)
95 (need-update (insert (dvc-face-add " need update\n" 'dvc-conflict)))
96 (need-merge
97 (insert (dvc-face-add " need merge\n" 'dvc-conflict)))
98 )))
99
100(defun xmtn-status-kill-conflicts-buffer (data)
101 (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
102 (let ((buffer (xmtn-status-data-conflicts-buffer data)))
103 (with-current-buffer buffer (save-buffer))
104 (kill-buffer buffer))))
105
106(defun xmtn-status-save-conflicts-buffer (data)
107 (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
108 (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer))))
109
110(defun xmtn-status-clean ()
111 "Clean current workspace, delete from ewoc"
112 (interactive)
113 (let* ((elem (ewoc-locate xmtn-status-ewoc))
114 (data (ewoc-data elem))
115 (inhibit-read-only t))
116 (xmtn-status-kill-conflicts-buffer data)
117 (xmtn-conflicts-clean (xmtn-status-work data))
118 (ewoc-delete xmtn-status-ewoc elem)))
119
120(defun xmtn-status-cleanp ()
121 "Non-nil if clean & quit is appropriate for current workspace."
122 (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
123 ;; don't check need-refresh here; allow deleting after just doing
124 ;; final required action in another buffer.
125 (and (member (xmtn-status-data-local-changes data) '(need-scan ok))
126 (member (xmtn-status-data-heads data) '(need-scan at-head)))))
127
128(defun xmtn-status-do-refresh-one ()
129 (interactive)
130 (let* ((elem (ewoc-locate xmtn-status-ewoc))
131 (data (ewoc-data elem)))
132 (xmtn-status-refresh-one data current-prefix-arg)
133 (ewoc-invalidate xmtn-status-ewoc elem)))
134
135(defun xmtn-status-refreshp ()
136 "Non-nil if refresh is appropriate for current workspace."
137 (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
138 (or (xmtn-status-data-need-refresh data)
139 ;; everything's done, but the user just did mtn sync, and more
140 ;; stuff showed up
141 (eq 'ok (xmtn-status-data-local-changes data))
142 (eq 'at-head (xmtn-status-data-heads data)))))
143
144(defun xmtn-status-update ()
145 "Update current workspace."
146 (interactive)
147 (let* ((elem (ewoc-locate xmtn-status-ewoc))
148 (data (ewoc-data elem)))
149 (xmtn-status-need-refresh elem data)
150 (let ((default-directory (xmtn-status-work data)))
151 (xmtn-dvc-update))
152 (xmtn-status-refresh-one data nil)
153 (ewoc-invalidate xmtn-status-ewoc elem)))
154
155(defun xmtn-status-updatep ()
156 "Non-nil if update is appropriate for current workspace."
157 (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
158 (and (not (xmtn-status-data-need-refresh data))
159 (eq 'need-update (xmtn-status-data-heads data)))))
160
161(defun xmtn-status-resolve-conflicts ()
162 "Resolve conflicts for current workspace."
163 (interactive)
164 (let* ((elem (ewoc-locate xmtn-status-ewoc))
165 (data (ewoc-data elem)))
166 (xmtn-status-need-refresh elem data)
167 (setf (xmtn-status-data-conflicts data) 'resolved)
168 (pop-to-buffer (xmtn-status-data-conflicts-buffer data))))
169
170(defun xmtn-status-resolve-conflictsp ()
171 "Non-nil if resolve conflicts is appropriate for current workspace."
172 (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
173 (and (not (xmtn-status-data-need-refresh data))
174 (member (xmtn-status-data-conflicts data)
175 '(need-resolve need-review-resolve-internal)))))
176
177(defun xmtn-status-status ()
178 "Run xmtn-status on current workspace."
179 (interactive)
180 (let* ((elem (ewoc-locate xmtn-status-ewoc))
181 (data (ewoc-data elem)))
182 (xmtn-status-need-refresh elem data)
183 (setf (xmtn-status-data-local-changes data) 'ok)
184 (xmtn-status (xmtn-status-work data))))
185
186(defun xmtn-status-status-ok ()
187 "Ignore local changes in current workspace."
188 (interactive)
189 (let* ((elem (ewoc-locate xmtn-status-ewoc))
190 (data (ewoc-data elem)))
191 (setf (xmtn-status-data-local-changes data) 'ok)
192
193 (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
194 ;; creating the log-edit buffer requires a single status/diff/conflicts buffer
195 (kill-buffer (xmtn-status-data-conflicts-buffer data)))
196
197 (ewoc-invalidate xmtn-status-ewoc elem)))
198
199(defun xmtn-status-statusp ()
200 "Non-nil if xmtn-status is appropriate for current workspace."
201 (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
202 (and (not (xmtn-status-data-need-refresh data))
203 (member (xmtn-status-data-local-changes data)
204 '(need-scan need-commit)))))
205
206(defun xmtn-status-missing ()
207 "Run xmtn-missing on current workspace."
208 (interactive)
209 (let* ((elem (ewoc-locate xmtn-status-ewoc))
210 (data (ewoc-data elem)))
211 (xmtn-status-need-refresh elem data)
212 (xmtn-missing nil (xmtn-status-work data))))
213
214(defun xmtn-status-missingp ()
215 "Non-nil if xmtn-missing is appropriate for current workspace."
216 (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
217 (and (not (xmtn-status-data-need-refresh data))
218 (eq 'need-update (xmtn-status-data-heads data)))))
219
220(defun xmtn-status-merge ()
221 "Run dvc-merge on current workspace."
222 (interactive)
223 (let* ((elem (ewoc-locate xmtn-status-ewoc))
224 (data (ewoc-data elem))
225 (default-directory (xmtn-status-work data)))
226 (xmtn-status-need-refresh elem data)
227 (xmtn-status-save-conflicts-buffer data)
228 (xmtn-dvc-merge-1 default-directory nil)))
229
230(defun xmtn-status-heads ()
231 "Run xmtn-heads on current workspace."
232 (interactive)
233 (let* ((elem (ewoc-locate xmtn-status-ewoc))
234 (data (ewoc-data elem))
235 (default-directory (xmtn-status-work data)))
236 (xmtn-status-need-refresh elem data)
237 (xmtn-view-heads-revlist)))
238
239(defun xmtn-status-headsp ()
240 "Non-nil if xmtn-heads is appropriate for current workspace."
241 (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
242 (and (not (xmtn-status-data-need-refresh data))
243 (eq 'need-merge (xmtn-status-data-heads data)))))
244
245(defvar xmtn-status-actions-map
246 (let ((map (make-sparse-keymap "actions")))
247 (define-key map [?c] '(menu-item "c) clean/delete"
248 xmtn-status-clean
249 :visible (xmtn-status-cleanp)))
250 (define-key map [?g] '(menu-item "g) refresh"
251 xmtn-status-do-refresh-one
252 :visible (xmtn-status-refreshp)))
253 (define-key map [?i] '(menu-item "i) ignore local changes"
254 xmtn-status-status-ok
255 :visible (xmtn-status-statusp)))
256 (define-key map [?5] '(menu-item "5) update"
257 xmtn-status-update
258 :visible (xmtn-status-updatep)))
259 (define-key map [?4] '(menu-item "4) xmtn-merge"
260 xmtn-status-merge
261 :visible (xmtn-status-headsp)))
262 (define-key map [?3] '(menu-item "3) xmtn-heads"
263 xmtn-status-heads
264 :visible (xmtn-status-headsp)))
265 (define-key map [?2] '(menu-item "2) resolve conflicts"
266 xmtn-status-resolve-conflicts
267 :visible (xmtn-status-resolve-conflictsp)))
268 (define-key map [?1] '(menu-item "1) dvc-missing"
269 xmtn-status-missing
270 :visible (xmtn-status-missingp)))
271 (define-key map [?0] '(menu-item "0) status"
272 xmtn-status-status
273 :visible (xmtn-status-statusp)))
274 map)
275 "Keyboard menu keymap used in multiple-status mode.")
276
277(dvc-make-ewoc-next xmtn-status-next xmtn-status-ewoc)
278(dvc-make-ewoc-prev xmtn-status-prev xmtn-status-ewoc)
279
280(defvar xmtn-multiple-status-mode-map
281 (let ((map (make-sparse-keymap)))
282 (define-key map "\M-d" xmtn-status-actions-map)
283 (define-key map [?g] 'xmtn-status-refresh)
284 (define-key map [?n] 'xmtn-status-next)
285 (define-key map [?p] 'xmtn-status-prev)
286 (define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer))))
287 map)
288 "Keymap used in `xmtn-multiple-status-mode'.")
289
290(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status"
291 "Major mode to show status of multiple workspaces."
292 (setq dvc-buffer-current-active-dvc 'xmtn)
293 (setq buffer-read-only nil)
294
295 ;; don't do normal clean up stuff
296 (set (make-local-variable 'before-save-hook) nil)
297 (set (make-local-variable 'write-file-functions) nil)
298
299 (dvc-install-buffer-menu)
300 (setq buffer-read-only t)
301 (buffer-disable-undo)
302
303 (set-buffer-modified-p nil))
304
305(defun xmtn-status-conflicts (data)
306 "Return value for xmtn-status-data-conflicts for DATA."
307 ;; Can't check for "current heads", since there could be more than
308 ;; 2, so just recreate conflicts
309 (let* ((work (xmtn-status-work data))
310 (default-directory work))
311
312 (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
313 (kill-buffer (xmtn-status-data-conflicts-buffer data)))
314
315 ;; create conflicts file
316 (xmtn-conflicts-clean work)
317 (xmtn-conflicts-save-opts work work (xmtn-status-data-branch data) (xmtn-status-data-branch data))
318 (dvc-run-dvc-sync
319 'xmtn
320 (list "conflicts" "store")
321 :error (lambda (output error status arguments)
322 (pop-to-buffer error)))
323
324 ;; create conflicts buffer
325 (setf (xmtn-status-data-conflicts-buffer data)
326 (save-excursion
327 (let ((dvc-switch-to-buffer-first nil))
328 (xmtn-conflicts-review work)
329 (current-buffer))))
330
331 (with-current-buffer (xmtn-status-data-conflicts-buffer data)
332 (case xmtn-conflicts-total-count
333 (0 'none)
334 (t
335 (if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-internal-count)
336 'need-review-resolve-internal
337 'need-resolve))))))
338
339(defun xmtn-status-refresh-one (data refresh-local-changes)
340 "Refresh DATA."
341 (let ((work (xmtn-status-work data)))
342
343 (message "checking heads for %s " work)
344
345 (let ((heads (xmtn--heads work (xmtn-status-data-branch data)))
346 (base-rev (xmtn--get-base-revision-hash-id-or-null work)))
347 (case (length heads)
348 (1
349 (setf (xmtn-status-data-head-rev data) (nth 0 heads))
350 (setf (xmtn-status-data-conflicts data) 'none)
351 (if (string= (xmtn-status-data-head-rev data) base-rev)
352 (setf (xmtn-status-data-heads data) 'at-head)
353 (setf (xmtn-status-data-heads data) 'need-update)))
354 (t
355 (setf (xmtn-status-data-head-rev data) nil)
356 (setf (xmtn-status-data-heads data) 'need-merge)
357 (case (xmtn-status-data-conflicts data)
358 (resolved
359 ;; Assume the resolution was just completed, so don't erase it!
360 nil)
361 (t
362 (setf (xmtn-status-data-conflicts data) 'need-scan))))))
363
364 (message "")
365
366 (if refresh-local-changes
367 (setf (xmtn-status-data-local-changes data) 'need-scan))
368
369 (case (xmtn-status-data-local-changes data)
370 (need-scan
371 (setf (xmtn-status-data-local-changes data) (xmtn-automate-local-changes work)))
372 (t nil))
373
374 (case (xmtn-status-data-conflicts data)
375 (need-scan
376 (setf (xmtn-status-data-conflicts data)
377 (xmtn-status-conflicts data)))
378 (t nil))
379
380 (setf (xmtn-status-data-need-refresh data) nil))
381
382 ;; return non-nil to refresh display as we go along
383 t)
384
385(defun xmtn-status-refresh ()
386 "Refresh status of each ewoc element. With prefix arg, reset local changes status to `unknown'."
387 (interactive)
388 (ewoc-map 'xmtn-status-refresh-one xmtn-status-ewoc current-prefix-arg)
389 (message "done"))
390
391;;;###autoload
392(defun xmtn-update-multiple (dir &optional workspaces)
393 "Update all projects under DIR."
394 (interactive "DUpdate all in (root directory): ")
395 (let ((root (file-name-as-directory (substitute-in-file-name dir))))
396
397 (if (not workspaces) (setq workspaces (xmtn--filter-non-dir root)))
398
399 (dolist (workspace workspaces)
400 (let ((default-directory (concat root workspace)))
401 (xmtn-dvc-update nil t)))
402 (message "Update %s done" root)))
403
404;;;###autoload
405(defun xmtn-status-multiple (dir &optional workspaces skip-initial-scan)
406 "Show actions to update all projects under DIR."
407 (interactive "DStatus for all (root directory): \ni\nP")
408 (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
409 (setq default-directory (file-name-as-directory (substitute-in-file-name dir)))
410 (if (not workspaces) (setq workspaces (xmtn--filter-non-dir default-directory)))
411 (setq xmtn-status-root (file-name-as-directory default-directory))
412 (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
413 (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
414 (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
415 (dolist (workspace workspaces)
416 (ewoc-enter-last xmtn-status-ewoc
417 (make-xmtn-status-data
418 :work workspace
419 :branch (xmtn--tree-default-branch (concat xmtn-status-root workspace))
420 :need-refresh t
421 :heads 'need-scan)))
422 (xmtn-multiple-status-mode)
423 (when (not skip-initial-scan)
424 (progn
425 (xmtn-status-refresh)
426 (xmtn-status-next))))
427
428;;;###autoload
429(defun xmtn-status-one (work)
430 "Show actions to update WORK."
431 (interactive "DStatus for (workspace): ")
432 (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
433 (setq default-directory work)
434 (setq xmtn-status-root (expand-file-name (concat (file-name-as-directory work) "../")))
435 (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
436 (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
437 (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
438 (ewoc-enter-last xmtn-status-ewoc
439 (make-xmtn-status-data
440 :work (file-name-nondirectory (directory-file-name work))
441 :branch (xmtn--tree-default-branch default-directory)
442 :need-refresh t
443 :heads 'need-scan))
444 (xmtn-multiple-status-mode)
445 (xmtn-status-refresh)
446 (xmtn-status-next))
447
448(provide 'xmtn-multi-status)
449
450;; end of file
0451
=== modified file 'lisp/xmtn-propagate.el'
--- lisp/xmtn-propagate.el 2009-10-03 12:39:58 +0000
+++ lisp/xmtn-propagate.el 2010-02-25 22:31:14 +0000
@@ -149,17 +149,21 @@
149 (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))149 (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
150150
151 (if (eq 'at-head (xmtn-propagate-data-to-heads data))151 (if (eq 'at-head (xmtn-propagate-data-to-heads data))
152 (insert " need clean\n"))152 (insert (dvc-face-add " need clean\n" 'dvc-conflict)))
153 ))153 ))
154 ;; ewoc ought to do this, but it doesn't154 ;; ewoc ought to do this, but it doesn't
155 (redisplay))155 (redisplay))
156156
157(defun xmtn-kill-conflicts-buffer (data)157(defun xmtn-propagate-kill-conflicts-buffer (data)
158 (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))158 (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
159 (let ((buffer (xmtn-propagate-data-conflicts-buffer data)))159 (let ((buffer (xmtn-propagate-data-conflicts-buffer data)))
160 (with-current-buffer buffer (save-buffer))160 (with-current-buffer buffer (save-buffer))
161 (kill-buffer buffer))))161 (kill-buffer buffer))))
162162
163(defun xmtn-propagate-save-conflicts-buffer (data)
164 (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
165 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer))))
166
163(defun xmtn-propagate-clean ()167(defun xmtn-propagate-clean ()
164 "Clean current workspace, delete from ewoc"168 "Clean current workspace, delete from ewoc"
165 (interactive)169 (interactive)
@@ -167,8 +171,8 @@
167 (data (ewoc-data elem)))171 (data (ewoc-data elem)))
168172
169 ;; only one conflicts file and buffer173 ;; only one conflicts file and buffer
174 (xmtn-propagate-kill-conflicts-buffer data)
170 (xmtn-conflicts-clean (xmtn-propagate-to-work data))175 (xmtn-conflicts-clean (xmtn-propagate-to-work data))
171 (xmtn-kill-conflicts-buffer data)
172176
173 (let ((inhibit-read-only t))177 (let ((inhibit-read-only t))
174 (ewoc-delete xmtn-propagate-ewoc elem))))178 (ewoc-delete xmtn-propagate-ewoc elem))))
@@ -229,6 +233,12 @@
229 (let* ((elem (ewoc-locate xmtn-propagate-ewoc))233 (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
230 (data (ewoc-data elem)))234 (data (ewoc-data elem)))
231 (xmtn-propagate-need-refresh elem data)235 (xmtn-propagate-need-refresh elem data)
236
237 (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
238 ;; user deleted conflicts buffer after resolving conflicts; get it back
239 (setf (xmtn-propagate-data-conflicts-buffer data)
240 (xmtn-propagate-conflicts-buffer data)))
241
232 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)242 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
233 (let ((xmtn-confirm-operation nil))243 (let ((xmtn-confirm-operation nil))
234 (xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data))))244 (xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data))))
@@ -274,7 +284,7 @@
274 ;; can't create log-edit buffer with both conflicts and status284 ;; can't create log-edit buffer with both conflicts and status
275 ;; buffer open, and we'll be killing this as part of the refresh285 ;; buffer open, and we'll be killing this as part of the refresh
276 ;; anyway.286 ;; anyway.
277 (xmtn-kill-conflicts-buffer data)287 (xmtn-propagate-kill-conflicts-buffer data)
278288
279 (setf (xmtn-propagate-data-to-local-changes data) 'ok)289 (setf (xmtn-propagate-data-to-local-changes data) 'ok)
280 (xmtn-status (xmtn-propagate-to-work data))))290 (xmtn-status (xmtn-propagate-to-work data))))
@@ -452,49 +462,6 @@
452 (xmtn-propagate-refresh)462 (xmtn-propagate-refresh)
453 (xmtn-propagate-next nil t))463 (xmtn-propagate-next nil t))
454464
455(defun xmtn-propagate-local-changes (work)
456 "Value for xmtn-propagate-data-local-changes for WORK."
457 (message "checking %s for local changes" work)
458 (let ((default-directory work)
459 result)
460
461 (dvc-run-dvc-sync
462 'xmtn
463 (list "status")
464 :finished (lambda (output error status arguments)
465 ;; we don't get an error status for not up-to-date,
466 ;; so parse the output.
467 ;; FIXME: add option to automate inventory to just return status; can return on first change
468 ;; FIXME: 'patch' may be internationalized.
469
470 (message "") ; clear minibuffer
471 (set-buffer output)
472 (goto-char (point-min))
473 (if (search-forward "patch" (point-max) t)
474 (setq result 'need-commit)
475 (setq result 'ok)))
476
477 :error (lambda (output error status arguments)
478 (pop-to-buffer error)))
479
480 (if (eq result 'ok)
481 ;; check for unknown
482 (dvc-run-dvc-sync
483 'xmtn
484 (list "ls" "unknown")
485 :finished (lambda (output error status arguments)
486 (message "") ; clear minibuffer
487 (set-buffer output)
488 (if (not (= (point-min) (point-max)))
489 (setq result 'need-commit)
490 (setq result 'ok)))
491
492 :error (lambda (output error status arguments)
493 (pop-to-buffer error))))
494
495 result)
496 )
497
498(defun xmtn-propagate-needed (data)465(defun xmtn-propagate-needed (data)
499 "t if DATA needs propagate."466 "t if DATA needs propagate."
500 (let ((result t)467 (let ((result t)
@@ -558,18 +525,24 @@
558525
559(defun xmtn-propagate-conflicts (data)526(defun xmtn-propagate-conflicts (data)
560 "Return value for xmtn-propagate-data-conflicts for DATA."527 "Return value for xmtn-propagate-data-conflicts for DATA."
561 ;; if conflicts-buffer is nil, this does the right thing.528
529 (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
530 ;; user may have deleted conflicts buffer after resolving
531 ;; conflicts; don't throw that away.
532 (setf (xmtn-propagate-data-conflicts-buffer data)
533 (xmtn-propagate-conflicts-buffer data)))
534
562 (let ((revs-current535 (let ((revs-current
563 (and (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))536 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
564 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)537 (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)
565 (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)538 (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))
566 (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision))))))
567 (if revs-current539 (if revs-current
568 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)540 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
569 (xmtn-conflicts-update-counts))541 (xmtn-conflicts-update-counts)
542 (save-buffer))
570543
571 ;; recreate conflicts544 ;; else recreate conflicts
572 (xmtn-kill-conflicts-buffer data)545 (xmtn-propagate-kill-conflicts-buffer data)
573546
574 (xmtn-conflicts-clean (xmtn-propagate-to-work data))547 (xmtn-conflicts-clean (xmtn-propagate-to-work data))
575548
@@ -629,19 +602,25 @@
629 (progn602 (progn
630 (ecase (xmtn-propagate-data-from-local-changes data)603 (ecase (xmtn-propagate-data-from-local-changes data)
631 ((need-scan need-commit)604 ((need-scan need-commit)
632 (setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work)))605 (setf (xmtn-propagate-data-from-local-changes data) (xmtn-automate-local-changes from-work)))
633 (ok nil))606 (ok nil))
634607
635 (ecase (xmtn-propagate-data-to-local-changes data)608 (ecase (xmtn-propagate-data-to-local-changes data)
636 ((need-scan need-commit)609 ((need-scan need-commit)
637 (setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work)))610 (setf (xmtn-propagate-data-to-local-changes data) (xmtn-automate-local-changes to-work)))
638 (ok nil))))611 (ok nil))))
639612
640 (if (xmtn-propagate-data-propagate-needed data)613 (if (xmtn-propagate-data-propagate-needed data)
641 ;; can't compute conflicts if propagate not needed614 (progn
642 (setf (xmtn-propagate-data-conflicts data)615 (if refresh-local-changes
643 (xmtn-propagate-conflicts data))616 (progn
644617 (xmtn-propagate-kill-conflicts-buffer data)
618 (xmtn-conflicts-clean (xmtn-propagate-to-work data))))
619
620 (setf (xmtn-propagate-data-conflicts data)
621 (xmtn-propagate-conflicts data)))
622
623 ;; can't compute conflicts if propagate not needed
645 (setf (xmtn-propagate-data-conflicts data) 'need-scan))624 (setf (xmtn-propagate-data-conflicts data) 'need-scan))
646625
647 (setf (xmtn-propagate-data-need-refresh data) nil))626 (setf (xmtn-propagate-data-need-refresh data) nil))
@@ -725,6 +704,8 @@
725 (from-session (xmtn-automate-cache-session from-work))704 (from-session (xmtn-automate-cache-session from-work))
726 (to-session (xmtn-automate-cache-session to-work)))705 (to-session (xmtn-automate-cache-session to-work)))
727 (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))706 (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
707 ;; default-directory is wrong if buffer is reused
708 (setq default-directory to-work)
728 (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))709 (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))
729 (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))710 (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
730 (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))711 (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
731712
=== modified file 'lisp/xmtn-revlist.el'
--- lisp/xmtn-revlist.el 2009-10-03 12:39:58 +0000
+++ lisp/xmtn-revlist.el 2010-02-25 22:31:14 +0000
@@ -148,78 +148,77 @@
148 (assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids))148 (assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids))
149 (ewoc-set-hf ewoc header footer)149 (ewoc-set-hf ewoc header footer)
150 (ewoc-filter ewoc (lambda (x) nil)) ; Clear it.150 (ewoc-filter ewoc (lambda (x) nil)) ; Clear it.
151 (xmtn-automate-with-session (session root)151 (setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
152 (setq revision-hash-ids (xmtn--toposort root revision-hash-ids))152 (if last-n
153 (if last-n153 (let ((len (length revision-hash-ids)))
154 (let ((len (length revision-hash-ids)))154 (if (> len last-n)
155 (if (> len last-n)155 (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))
156 (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))156 (setq revision-hash-ids (coerce revision-hash-ids 'vector))
157 (setq revision-hash-ids (coerce revision-hash-ids 'vector))157 (dotimes-with-progress-reporter (i (length revision-hash-ids))
158 (xmtn--dotimes-with-progress-reporter (i (length revision-hash-ids))158 (case (length revision-hash-ids)
159 (case (length revision-hash-ids)159 (1 "Setting up revlist buffer (1 revision)...")
160 (1 "Setting up revlist buffer (1 revision)...")160 (t (format "Setting up revlist buffer (%s revisions)..."
161 (t (format "Setting up revlist buffer (%s revisions)..."161 (length revision-hash-ids))))
162 (length revision-hash-ids))))162 ;; Maybe also show parents and children? (Could add toggle
163 ;; Maybe also show parents and children? (Could add toggle163 ;; commands to show/hide these.)
164 ;; commands to show/hide these.)164 (lexical-let ((rev (aref revision-hash-ids i))
165 (lexical-let ((rev (aref revision-hash-ids i))165 (branches (list))
166 (branches (list))166 (authors (list))
167 (authors (list))167 (dates (list))
168 (dates (list))168 (changelogs (list))
169 (changelogs (list))169 (tags (list)))
170 (tags (list)))170 (xmtn--map-parsed-certs
171 (xmtn--map-parsed-certs171 root rev
172 root rev172 (lambda (key signature name value trusted)
173 (lambda (key signature name value trusted)173 (declare (ignore key))
174 (declare (ignore key))174 (unless (not trusted)
175 (unless (not trusted)175 (cond ((equal name "author")
176 (cond ((equal name "author")176 (push value authors))
177 (push value authors))177 ((equal name "date")
178 ((equal name "date")178 (push value dates))
179 (push value dates))179 ((equal name "changelog")
180 ((equal name "changelog")180 (push value changelogs))
181 (push value changelogs))181 ((equal name "branch")
182 ((equal name "branch")182 (push value branches))
183 (push value branches))183 ((equal name "tag")
184 ((equal name "tag")184 (push value tags))
185 (push value tags))185 (t
186 (t186 (progn))))))
187 (progn))))))187 (setq authors (nreverse authors)
188 (setq authors (nreverse authors)188 dates (nreverse dates)
189 dates (nreverse dates)189 changelogs (nreverse changelogs)
190 changelogs (nreverse changelogs)190 branches (nreverse branches)
191 branches (nreverse branches)191 tags (nreverse tags))
192 tags (nreverse tags))192 (let ((parent-hash-ids
193 (let ((parent-hash-ids193 (xmtn-automate-simple-command-output-lines root `("parents"
194 (xmtn-automate-simple-command-output-lines root `("parents"194 ,rev)))
195 ,rev)))195 (child-hash-ids
196 (child-hash-ids196 (xmtn-automate-simple-command-output-lines root `("children"
197 (xmtn-automate-simple-command-output-lines root `("children"197 ,rev))))
198 ,rev))))198 (xmtn--assert-optional (every #'stringp authors))
199 (xmtn--assert-optional (every #'stringp authors))199 (xmtn--assert-optional (every #'stringp dates))
200 (xmtn--assert-optional (every #'stringp dates))200 (xmtn--assert-optional (every #'stringp changelogs))
201 (xmtn--assert-optional (every #'stringp changelogs))201 (xmtn--assert-optional (every #'stringp branches))
202 (xmtn--assert-optional (every #'stringp branches))202 (xmtn--assert-optional (every #'stringp tags))
203 (xmtn--assert-optional (every #'stringp tags))203 (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))
204 (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))204 (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))
205 (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))205 (ewoc-enter-last ewoc
206 (ewoc-enter-last ewoc206 ;; Creating a list `(entry-patch
207 ;; Creating a list `(entry-patch207 ;; ,instance-of-dvc-revlist-entry-patch) seems
208 ;; ,instance-of-dvc-revlist-entry-patch) seems208 ;; to be part of DVC's API.
209 ;; to be part of DVC's API.209 `(entry-patch
210 `(entry-patch210 ,(make-dvc-revlist-entry-patch
211 ,(make-dvc-revlist-entry-patch211 :dvc 'xmtn
212 :dvc 'xmtn212 :rev-id `(xmtn (revision ,rev))
213 :rev-id `(xmtn (revision ,rev))213 :struct (xmtn--make-revlist-entry
214 :struct (xmtn--make-revlist-entry214 :revision-hash-id rev
215 :revision-hash-id rev215 :branches branches
216 :branches branches216 :authors authors
217 :authors authors217 :dates dates
218 :dates dates218 :changelogs changelogs
219 :changelogs changelogs219 :tags tags
220 :tags tags220 :parent-hash-ids parent-hash-ids
221 :parent-hash-ids parent-hash-ids221 :child-hash-ids child-hash-ids)))))))
222 :child-hash-ids child-hash-ids))))))))
223 nil)222 nil)
224223
225(defun xmtn-revision-st-message (entry)224(defun xmtn-revision-st-message (entry)
@@ -257,14 +256,14 @@
257(defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n)256(defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n)
258 ;; Adapted from `dvc-build-revision-list'.257 ;; Adapted from `dvc-build-revision-list'.
259 ;; info-generator-fn must return a list of back-end revision ids (strings)258 ;; info-generator-fn must return a list of back-end revision ids (strings)
260 (xmtn-automate-with-session (nil root)259 (xmtn-automate-cache-session root)
261 (let ((dvc-temp-current-active-dvc 'xmtn)260 (let ((dvc-temp-current-active-dvc 'xmtn)
262 (buffer (dvc-revlist-create-buffer261 (buffer (dvc-revlist-create-buffer
263 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))262 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))
264 (with-current-buffer buffer263 (with-current-buffer buffer
265 (setq xmtn--revlist-*info-generator-fn* info-generator-fn)264 (setq xmtn--revlist-*info-generator-fn* info-generator-fn)
266 (xmtn--revlist-refresh))265 (xmtn--revlist-refresh))
267 (xmtn--display-buffer-maybe buffer nil)))266 (xmtn--display-buffer-maybe buffer nil))
268 nil)267 nil)
269268
270;;;###autoload269;;;###autoload
@@ -293,57 +292,54 @@
293 (xmtn--setup-revlist292 (xmtn--setup-revlist
294 root293 root
295 (lambda (root)294 (lambda (root)
296 (xmtn-automate-with-session295 (let ((branch (xmtn--tree-default-branch root)))
297 (nil root)296 (list branch
298 (let ((branch (xmtn--tree-default-branch root)))297 (list
299 (list branch298 (if dvc-revlist-last-n
300 (list299 (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)
301 (if dvc-revlist-last-n300 (format "Log for branch %s (all entries):" branch)))
302 (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)301 '()
303 (format "Log for branch %s (all entries):" branch)))302 (xmtn--expand-selector
304 '()303 root
305 (xmtn--expand-selector304 ;; This restriction to current branch is completely
306 root305 ;; arbitrary.
307 ;; This restriction to current branch is completely306 (concat
308 ;; arbitrary.307 "b:" ;; returns all revs for current branch
309 (concat308 (xmtn--escape-branch-name-for-selector
310 "b:" ;; returns all revs for current branch309 branch))))))
311 (xmtn--escape-branch-name-for-selector
312 branch)))))))
313 first-line-only-p310 first-line-only-p
314 last-n)))311 last-n)))
315312
316(defun xmtn--revlist--missing-get-info (root)313(defun xmtn--revlist--missing-get-info (root)
317 (xmtn-automate-with-session (nil root)314 (let* ((branch (xmtn--tree-default-branch root))
318 (let* ((branch (xmtn--tree-default-branch root))315 (heads (xmtn--heads root branch))
319 (heads (xmtn--heads root branch))316 (base-revision-hash-id (xmtn--get-base-revision-hash-id root))
320 (base-revision-hash-id (xmtn--get-base-revision-hash-id root))317 (difference
321 (difference318 (delete-duplicates
322 (delete-duplicates319 (mapcan
323 (mapcan320 (lambda (head)
324 (lambda (head)321 (xmtn-automate-simple-command-output-lines
325 (xmtn-automate-simple-command-output-lines322 root
326 root323 `("ancestry_difference"
327 `("ancestry_difference"324 ,head ,base-revision-hash-id)))
328 ,head ,base-revision-hash-id)))325 heads))))
329 heads))))326 (list
330 (list327 branch
331 branch328 `(,(format "Tree %s" root)
332 `(,(format "Tree %s" root)329 ,(format "Branch %s" branch)
333 ,(format "Branch %s" branch)330 ,(format "Base %s" base-revision-hash-id)
334 ,(format "Base %s" base-revision-hash-id)331 ,(case (length heads)
335 ,(case (length heads)332 (1 "branch is merged")
336 (1 "branch is merged")333 (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
337 (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))334 nil
338 nil335 ,(case (length difference)
339 ,(case (length difference)336 (0 "No revisions that are not in base revision")
340 (0 "No revisions that are not in base revision")337 (1 "1 revision that is not in base revision:")
341 (1 "1 revision that is not in base revision:")338 (t (format
342 (t (format339 "%s revisions that are not in base revision:"
343 "%s revisions that are not in base revision:"340 (length difference)))))
344 (length difference)))))341 '()
345 '()342 difference)))
346 difference))))
347343
348(defun xmtn-revlist-show-conflicts ()344(defun xmtn-revlist-show-conflicts ()
349 "If point is on a revision that has two parents, show conflicts345 "If point is on a revision that has two parents, show conflicts
@@ -459,20 +455,19 @@
459 (xmtn--setup-revlist455 (xmtn--setup-revlist
460 root456 root
461 (lambda (root)457 (lambda (root)
462 (xmtn-automate-with-session (nil root)458 (let* ((branch (xmtn--tree-default-branch root))
463 (let* ((branch (xmtn--tree-default-branch root))459 (head-revision-hash-ids (xmtn--heads root branch))
464 (head-revision-hash-ids (xmtn--heads root branch))460 (head-count (length head-revision-hash-ids)))
465 (head-count (length head-revision-hash-ids)))461 (list
466 (list462 branch
467 branch463 (list (format "Tree %s" root)
468 (list (format "Tree %s" root)464 (format "Branch %s" branch)
469 (format "Branch %s" branch)465 (case head-count
470 (case head-count466 (0 "No head revisions (branch empty (or circular ;))")
471 (0 "No head revisions (branch empty (or circular ;))")467 (1 "1 head revision:")
472 (1 "1 head revision:")468 (t (format "%s head revisions: " head-count))))
473 (t (format "%s head revisions: " head-count))))469 '()
474 '()470 head-revision-hash-ids)))
475 head-revision-hash-ids))))
476 ;; Passing nil as first-line-only-p, last-n is arbitrary here.471 ;; Passing nil as first-line-only-p, last-n is arbitrary here.
477 nil nil))472 nil nil))
478 nil)473 nil)
@@ -498,20 +493,19 @@
498 (xmtn--setup-revlist493 (xmtn--setup-revlist
499 root494 root
500 (lambda (root)495 (lambda (root)
501 (xmtn-automate-with-session (nil root)496 (let ((branch (xmtn--tree-default-branch root))
502 (let ((branch (xmtn--tree-default-branch root))497 (revision-hash-ids
503 (revision-hash-ids498 (mapcar #'first
504 (mapcar #'first499 (xmtn--get-content-changed-closure
505 (xmtn--get-content-changed-closure500 root last-backend-id normalized-file dvc-revlist-last-n))))
506 root last-backend-id normalized-file dvc-revlist-last-n))))501 (list
507 (list502 branch
508 branch503 (list
509 (list504 (if dvc-revlist-last-n
510 (if dvc-revlist-last-n505 (format "Log for %s (last %d entries)" file dvc-revlist-last-n)
511 (format "Log for %s (last %d entries)" file dvc-revlist-last-n)506 (format "Log for %s" file)))
512 (format "Log for %s" file)))507 '()
513 '()508 revision-hash-ids)))
514 revision-hash-ids))))
515 first-line-only-p509 first-line-only-p
516 last-n))))510 last-n))))
517511
@@ -530,25 +524,24 @@
530 (xmtn--setup-revlist524 (xmtn--setup-revlist
531 root525 root
532 (lambda (root)526 (lambda (root)
533 (xmtn-automate-with-session (nil root)527 (let* ((branch (xmtn--tree-default-branch root))
534 (let* ((branch (xmtn--tree-default-branch root))528 (revision-hash-ids (xmtn--expand-selector root selector))
535 (revision-hash-ids (xmtn--expand-selector root selector))529 (count (length revision-hash-ids)))
536 (count (length revision-hash-ids)))530 (list
537 (list531 branch
538 branch532 (list (format "Tree %s" root)
539 (list (format "Tree %s" root)533 (format "Default branch %s" branch)
540 (format "Default branch %s" branch)534 (if (with-syntax-table (standard-syntax-table)
541 (if (with-syntax-table (standard-syntax-table)535 (string-match "\\`\\s *\\'" selector))
542 (string-match "\\`\\s *\\'" selector))536 "Blank selector"
543 "Blank selector"537 (format "Selector %s" selector))
544 (format "Selector %s" selector))538 (case count
545 (case count539 (0 "No revisions matching selector")
546 (0 "No revisions matching selector")540 (1 "1 revision matching selector:")
547 (1 "1 revision matching selector:")541 (t (format "%s revisions matching selector: "
548 (t (format "%s revisions matching selector: "542 count))))
549 count))))543 '()
550 '()544 revision-hash-ids)))
551 revision-hash-ids))))
552 ;; Passing nil as first-line-only-p is arbitrary here.545 ;; Passing nil as first-line-only-p is arbitrary here.
553 nil546 nil
554 ;; FIXME: it might be useful to specify last-n here547 ;; FIXME: it might be useful to specify last-n here
@@ -560,28 +553,26 @@
560;;;###autoload553;;;###autoload
561(defun xmtn-dvc-revlog-get-revision (revision-id)554(defun xmtn-dvc-revlog-get-revision (revision-id)
562 (let ((root (dvc-tree-root)))555 (let ((root (dvc-tree-root)))
563 (xmtn-automate-with-session (nil root)556 (let ((backend-id (xmtn--resolve-revision-id root revision-id)))
564 (let ((backend-id (xmtn--resolve-revision-id root revision-id)))557 (xmtn-match backend-id
565 (xmtn-match backend-id558 ((local-tree $path) (error "Not implemented"))
566 ((local-tree $path) (error "Not implemented"))559 ((revision $revision-hash-id)
567 ((revision $revision-hash-id)560 (with-output-to-string
568 (with-output-to-string561 (flet ((write-line (format &rest args)
569 (flet ((write-line (format &rest args)562 (princ (apply #'format format args))
570 (princ (apply #'format format args))563 (terpri)))
571 (terpri)))564 (write-line "Revision %s" revision-hash-id)
572 (write-line "Revision %s" revision-hash-id)565 ;; FIXME: It would be good to sort the standard certs
573 ;; FIXME: It would be good to sort the standard certs566 ;; like author, date, branch, tag and changelog into
574 ;; like author, date, branch, tag and changelog into567 ;; some canonical order and format changelog specially
575 ;; some canonical order and format changelog specially568 ;; since it usually spans multiple lines.
576 ;; since it usually spans multiple lines.569 (xmtn--map-parsed-certs
577 (xmtn--map-parsed-certs570 root revision-hash-id
578 root revision-hash-id571 (lambda (key signature name value trusted)
579 (lambda (key signature name value trusted)572 (declare (ignore key))
580 (declare (ignore key))573 (if (not trusted)
581 (if (not trusted)574 (write-line "Untrusted cert, name=%s" name)
582 (write-line "Untrusted cert, name=%s" name)575 (write-line "%s: %s" name value)))))))))))
583 (write-line "%s: %s" name value))))))))))))
584
585576
586(defun xmtn-revlist-explicit-merge ()577(defun xmtn-revlist-explicit-merge ()
587 "Run mtn explicit_merge on the two marked revisions.578 "Run mtn explicit_merge on the two marked revisions.
@@ -618,29 +609,6 @@
618 (target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))609 (target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))
619 (xmtn--update root target-hash-id nil nil)))610 (xmtn--update root target-hash-id nil nil)))
620611
621;; Being able to conveniently disapprove whole batches of revisions
622;; is going to be a lot of fun.
623(defun xmtn-revlist-disapprove ()
624 "Disapprove the marked revisions, or the revision at point if none marked.
625
626To be invoked from an xmtn revlist buffer."
627 (interactive)
628 (let* ((root (dvc-tree-root))
629 (entries (or (dvc-revision-marked-revisions)
630 (list (dvc-revlist-current-patch-struct))))
631 (hash-ids (map 'vector #'xmtn--revlist-entry-revision-hash-id entries))
632 (description (case (length hash-ids)
633 (0 (xmtn--assert-nil))
634 (1 (format "revision %s" (elt hash-ids 0)))
635 (t (format "%s revisions" (length hash-ids))))))
636 (assert (every #'xmtn--hash-id-p hash-ids))
637 (unless (yes-or-no-p (format "Disapprove %s? " description))
638 (error "Aborted disapprove"))
639 (xmtn--dotimes-with-progress-reporter (i (length hash-ids))
640 (format "Disapproving %s..." description)
641 (let ((hash-id (aref hash-ids i)))
642 (funcall (xmtn--do-disapprove-future root hash-id))))))
643
644(provide 'xmtn-revlist)612(provide 'xmtn-revlist)
645613
646;;; xmtn-revlist.el ends here614;;; xmtn-revlist.el ends here
647615
=== modified file 'lisp/xmtn-run.el'
--- lisp/xmtn-run.el 2009-08-12 00:15:41 +0000
+++ lisp/xmtn-run.el 2010-02-25 22:31:14 +0000
@@ -43,31 +43,18 @@
4343
44(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)44(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)
4545
46(defun xmtn--call-with-environment-for-subprocess (xmtn--thunk)
47 (let ((process-environment (list* "LC_ALL="
48 "LC_CTYPE=en_US.UTF-8"
49 "LC_MESSAGES=C"
50 process-environment)))
51 (funcall xmtn--thunk)))
52
53(defmacro* xmtn--with-environment-for-subprocess (() &body body)
54 (declare (indent 1) (debug (sexp body)))
55 `(xmtn--call-with-environment-for-subprocess (lambda () ,@body)))
56
57(defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key)46(defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key)
58 (xmtn--check-cached-command-version)47 (xmtn--check-cached-command-version)
59 (let ((default-directory (file-truename (or root default-directory))))48 (let ((default-directory (file-truename (or root default-directory))))
60 (let ((coding-system-for-write 'xmtn--monotone-normal-form))49 (dvc-run-dvc-sync
61 (xmtn--with-environment-for-subprocess ()50 'xmtn
62 (apply #'dvc-run-dvc-sync51 `(,@xmtn-additional-arguments
63 'xmtn52 ;; We don't pass the --root argument here; it is not
64 `(,@xmtn-additional-arguments53 ;; necessary since default-directory is set, and it
65 ;; We don't pass the --root argument here; it is not54 ;; confuses the Cygwin version of mtn when run with a
66 ;; necessary since default-directory is set, and it55 ;; non-Cygwin Emacs.
67 ;; confuses the Cygwin version of mtn when run with a56 ,@arguments)
68 ;; non-Cygwin Emacs.57 dvc-run-keys)))
69 ,@arguments)
70 dvc-run-keys)))))
7158
72;;; The `dvc-run-dvc-*' functions use `call-process', which, for some59;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
73;;; reason, spawns the subprocess with a working directory with all60;;; reason, spawns the subprocess with a working directory with all
@@ -80,141 +67,36 @@
80(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key)67(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key)
81 (xmtn--check-cached-command-version)68 (xmtn--check-cached-command-version)
82 (let ((default-directory (file-truename (or root default-directory))))69 (let ((default-directory (file-truename (or root default-directory))))
83 (let ((coding-system-for-write 'xmtn--monotone-normal-form))70 (apply #'dvc-run-dvc-async
84 (xmtn--with-environment-for-subprocess ()71 'xmtn
85 (apply #'dvc-run-dvc-async72 `(,@xmtn-additional-arguments
86 'xmtn73 ;; We don't pass the --root argument here; it is not
87 `(,@xmtn-additional-arguments74 ;; necessary since default-directory is set, and it
88 ;; We don't pass the --root argument here; it is not75 ;; confuses the Cygwin version of mtn when run with a
89 ;; necessary since default-directory is set, and it76 ;; non-Cygwin Emacs.
90 ;; confuses the Cygwin version of mtn when run with a77 ,@arguments)
91 ;; non-Cygwin Emacs.78 dvc-run-keys)))
92 ,@arguments)
93 dvc-run-keys)))))
94
95(defun* xmtn--command-append-to-buffer-async (buffer root arguments
96 &rest dvc-run-keys
97 &key finished)
98 (xmtn--check-cached-command-version)
99 (let ((default-directory (file-truename (or root default-directory))))
100 (let ((coding-system-for-write 'xmtn--monotone-normal-form))
101 (xmtn--with-environment-for-subprocess ()
102 (apply #'dvc-run-dvc-async
103 'xmtn
104 `(,@xmtn-additional-arguments
105 ,@(if root `(,(concat "--root=" (file-truename root))))
106 ,@arguments)
107 :finished (lexical-let ((buffer buffer)
108 (finished finished))
109 (lambda (output error status arguments)
110 (with-current-buffer buffer
111 (save-excursion
112 (goto-char (point-max))
113 (let ((inhibit-read-only t))
114 (insert-buffer-substring output))))
115 (funcall (or finished #'dvc-default-finish-function)
116 output error status arguments)))
117 :related-buffer buffer
118 dvc-run-keys)))))
119
120(defun* xmtn--command-lines-future (root which-buffer arguments)
121 (xmtn--check-cached-command-version)
122 (lexical-let ((got-output-p nil)
123 lines)
124 (lexical-let
125 ((process
126 (let ((default-directory (file-truename (or root
127 default-directory))))
128 (let ((coding-system-for-write 'xmtn--monotone-normal-form))
129 (xmtn--with-environment-for-subprocess ()
130 (dvc-run-dvc-async
131 'xmtn
132 `(,@xmtn-additional-arguments
133 ,@(if root `(,(concat "--root=" (file-truename root))))
134 ,@arguments)
135 :finished
136 (lexical-let ((which-buffer which-buffer))
137 (lambda (output error status arguments)
138 (with-current-buffer (ecase which-buffer
139 (output output)
140 (error error))
141 (save-excursion
142 (goto-char (point-min))
143 (setq lines
144 (loop until (eobp)
145 collect
146 (buffer-substring-no-properties
147 (point)
148 (progn (end-of-line) (point)))
149 do (forward-line 1)))
150 (setq got-output-p t)))
151 nil))))))))
152 (lambda ()
153 (assert (member (process-status process) '(run exit signal)) t)
154 (while (and (eql (process-status process) 'run)
155 (accept-process-output process)))
156 (assert (member (process-status process) '(exit signal)) t)
157 ;; This (including discarding input) is needed to allow the
158 ;; sentinel to run, at least on GNU Emacs 21.4.2 and on GNU
159 ;; Emacs 22.0.50.1 of 2006-06-13. Sentinels are supposed to
160 ;; be run when `accept-process-output' is called, but they
161 ;; apparently aren't reliably. I haven't investigated this
162 ;; further.
163 ;;
164 ;; Problems with the sentinel not running mostly seem to be
165 ;; reproducible (after commenting out the code below) by
166 ;; pressing C-x V c immediately followed by a few other keys,
167 ;; or by pressing C-x V c not followed by any further input,
168 ;; or by editing a file in the tree without saving it, then
169 ;; pressing C-x V c, waiting for the "Save buffer?" prompt and
170 ;; then pressing y immediately followed by a few other keys.
171 ;;
172 ;; I hate having to discard the input because it interferes
173 ;; with typing ahead while Emacs is still busy. But hanging
174 ;; indefinitely waiting for `got-output-p' from a sentinel
175 ;; that never runs is even worse.
176 (while (and (eql (process-status process) 'exit)
177 (eql (process-exit-status process) 0)
178 (not got-output-p))
179 (discard-input)
180 (sit-for .01))
181 (unless got-output-p
182 (assert (not (and (eql (process-status process) 'exit)
183 (eql (process-exit-status process) 0))))
184 (error "Process %s terminated abnormally, status=%s, exit code=%s"
185 (process-name process)
186 (process-status process)
187 (process-exit-status process)))
188 lines))))
189
190(defun* xmtn--command-output-lines-future (root arguments)
191 (xmtn--command-lines-future root 'output arguments))
192
193(defun* xmtn--command-error-output-lines-future (root arguments)
194 (xmtn--command-lines-future root 'error arguments))
19579
196(defun xmtn--command-output-lines (root arguments)80(defun xmtn--command-output-lines (root arguments)
197 "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings."81 "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings."
198 (xmtn--check-cached-command-version)82 (xmtn--check-cached-command-version)
199 (let ((accu (list)))83 (let ((accu (list)))
200 (let ((default-directory (file-truename (or root default-directory))))84 (let ((default-directory (file-truename (or root default-directory))))
201 (let ((coding-system-for-write 'xmtn--monotone-normal-form))85 (dvc-run-dvc-sync
202 (xmtn--with-environment-for-subprocess ()86 'xmtn
203 (dvc-run-dvc-sync87 `(,@xmtn-additional-arguments
204 'xmtn88 ,@(if root `(,(concat "--root=" (file-truename root))))
205 `(,@xmtn-additional-arguments89 ,@arguments)
206 ,@(if root `(,(concat "--root=" (file-truename root))))90 :finished (lambda (output error status arguments)
207 ,@arguments)91 (with-current-buffer output
208 :finished (lambda (output error status arguments)92 (save-excursion
209 (with-current-buffer output93 (goto-char (point-min))
210 (save-excursion94 (while (not (eobp))
211 (goto-char (point-min))95 (push (buffer-substring-no-properties
212 (while (not (eobp))96 (point)
213 (push (buffer-substring-no-properties97 (progn (end-of-line) (point)))
214 (point)98 accu)
215 (progn (end-of-line) (point)))99 (forward-line 1)))))))
216 accu)
217 (forward-line 1)))))))))
218 (setq accu (nreverse accu))100 (setq accu (nreverse accu))
219 accu))101 accu))
220102

Subscribers

People subscribed via source and target branches