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
1=== modified file 'debian/changelog'
2--- debian/changelog 2008-09-02 18:05:50 +0000
3+++ debian/changelog 2010-02-25 22:31:14 +0000
4@@ -1,6 +1,7 @@
5-dvc (0r20080829-1) unstable; urgency=low
6+dvc (0r20091206-1) unstable; urgency=low
7
8 * New snapshot.
9+ * Add dvc.texinfo license to debian/copyright.
10 * Julien Danjou is the sponsor for DVC (Closes: #496930).
11
12- -- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Fri, 29 Aug 2008 19:27:14 +0200
13+ -- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Sun, 06 Dec 2009 11:54:58 +0100
14
15=== modified file 'debian/compat'
16--- debian/compat 2006-06-07 20:27:26 +0000
17+++ debian/compat 2010-02-25 22:31:14 +0000
18@@ -1,1 +1,1 @@
19-4
20+7
21
22=== modified file 'debian/control'
23--- debian/control 2008-08-29 17:10:10 +0000
24+++ debian/control 2010-02-25 22:31:14 +0000
25@@ -2,15 +2,15 @@
26 Section: devel
27 Priority: optional
28 Maintainer: Daniel Dehennin <daniel.dehennin@baby-gnu.org>
29-Build-Depends: cdbs (>= 0.4.50), debhelper
30+Build-Depends: cdbs (>= 0.4.50), debhelper (>= 7)
31 Build-Depends-Indep: autoconf, emacs22 | emacs21 | xemacs21 | emacsen, texinfo
32-Standards-Version: 3.8.0.1
33+Standards-Version: 3.8.3
34 Vcs-Bzr: http://bzr.xsteve.at/dvc/
35 Homepage: http://download.gna.org/dvc/
36
37 Package: dvc
38 Architecture: all
39-Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot
40+Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot, dpkg (>= 1.15.4) | install-info, ${misc:Depends}
41 Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone
42 Description: Emacs front-end to distributed version control systems
43 DVC is an attempt to build a common infrastructure for various
44
45=== modified file 'debian/copyright'
46--- debian/copyright 2008-10-26 15:24:41 +0000
47+++ debian/copyright 2010-02-25 22:31:14 +0000
48@@ -37,7 +37,8 @@
49
50 This package is free software; you can redistribute it and/or modify
51 it under the terms of the GNU General Public License as published by
52- the Free Software Foundation; version 2 dated June, 1991.
53+ the Free Software Foundation; version 2 dated June, 1991, or
54+ (at your option) any later version.
55
56 This package is distributed in the hope that it will be useful,
57 but WITHOUT ANY WARRANTY; without even the implied warranty of
58
59=== modified file 'lisp/dvc-bookmarks.el'
60--- lisp/dvc-bookmarks.el 2009-05-01 05:10:03 +0000
61+++ lisp/dvc-bookmarks.el 2010-02-25 22:31:14 +0000
62@@ -167,7 +167,8 @@
63 (define-key map "\C-y" 'dvc-bookmarks-yank)
64 (define-key map "\C-k" 'dvc-bookmarks-kill)
65 (define-key map "D" 'dvc-bookmarks-delete)
66- (define-key map "H" 'dvc-bookmarks-show-or-hide-subtree)
67+ (define-key map "Hs" 'dvc-bookmarks-show-or-hide-subtree)
68+ (define-key map "Ha" 'dvc-bookmarks-show-or-hide-all-subtrees)
69 (define-key map "S" 'dvc-bookmarks-set-tree-properties)
70 (define-key map "s" 'dvc-bookmarks-status)
71 (define-key map "d" 'dvc-bookmarks-diff)
72@@ -1163,23 +1164,38 @@
73 (defvar dvc-bookmarks-hidden-subtree nil
74 "List of all hidden subtrees")
75
76-(defun dvc-bookmarks-show-or-hide-subtree (&optional show)
77- "Hide subtree when called with no argument
78-show subtree when called with prefix argument (C-u)"
79- (interactive "P")
80+(defun dvc-bookmarks-show-or-hide-subtree ()
81+ "Toggle subtree visibility."
82+ (interactive)
83 (let ((current-tree (aref (dvc-bookmarks-current-bookmark) 1))
84- (parent))
85- (when (member (assoc current-tree dvc-bookmark-alist) dvc-bookmark-alist) ;check if we are really on a tree
86- (if current-prefix-arg
87+ (pos (point))
88+ parent)
89+ (when (member (assoc current-tree dvc-bookmark-alist)
90+ dvc-bookmark-alist) ; Check if we are really on a tree.
91+ (if (member current-tree dvc-bookmarks-hidden-subtree)
92 (progn
93- (setq dvc-bookmarks-hidden-subtree (remove current-tree dvc-bookmarks-hidden-subtree))
94- (dvc-bookmarks))
95- (add-to-list 'dvc-bookmarks-hidden-subtree current-tree))
96- (ewoc-filter dvc-bookmarks-cookie #'(lambda (x)
97- (setq parent (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist))
98- (if (not (member parent dvc-bookmarks-hidden-subtree))
99- t
100- nil))))))
101+ (setq dvc-bookmarks-hidden-subtree
102+ (remove current-tree dvc-bookmarks-hidden-subtree))
103+ (dvc-bookmarks))
104+ (add-to-list 'dvc-bookmarks-hidden-subtree current-tree))
105+ (ewoc-filter dvc-bookmarks-cookie
106+ #'(lambda (x)
107+ (setq parent
108+ (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist))
109+ (if (not (member parent dvc-bookmarks-hidden-subtree)) t nil))))
110+ (goto-char pos)))
111+
112+(defun dvc-bookmarks-show-or-hide-all-subtrees ()
113+ "Toggle visibility of all subtrees."
114+ (interactive)
115+ (with-current-buffer "*dvc-bookmarks*"
116+ (goto-char (point-min))
117+ (save-excursion
118+ (while (re-search-forward "^[^ ].+" nil t)
119+ (dvc-bookmarks-show-or-hide-subtree)
120+ (end-of-line)))
121+ (forward-line 1)))
122+
123
124 (defvar dvc-bookmarks-tmp-yank-item '("hg" (local-tree "~/work/hg/hg")))
125
126
127=== modified file 'lisp/dvc-core.el'
128--- lisp/dvc-core.el 2009-08-12 00:15:41 +0000
129+++ lisp/dvc-core.el 2010-02-25 22:31:14 +0000
130@@ -649,6 +649,7 @@
131 (let* ((output-buf (or (and output-buffer
132 (get-buffer-create output-buffer))
133 (dvc-new-process-buffer nil dvc)))
134+ (output-file (dvc-make-temp-name "dvc-output"))
135 (error-buf (or (and error-buffer (get-buffer-create error-buffer))
136 (dvc-new-error-buffer nil dvc)))
137 (error-file (dvc-make-temp-name "dvc-errors"))
138@@ -672,11 +673,20 @@
139 ;; we use a shell to redirect stderr before Emacs sees
140 ;; it. Note that this means we require "sh" even on
141 ;; MS Windows.
142+ ;;
143+ ;; An added twist is that start-process creates an
144+ ;; environment in which isatty() returns true. This has
145+ ;; unpleasant consequences if anything tries to pipe
146+ ;; through `less', because with TERM=dumb it will show a
147+ ;; warning and then wait for RET to be pressed, which
148+ ;; never happens, breaking our output processing. For
149+ ;; this reason, we redirect the output to a file as
150+ ;; well.
151 (start-process
152 (dvc-variable dvc "executable") output-buf
153 dvc-sh-executable "-c"
154- (format "%s 2> %s"
155- command error-file))))
156+ (format "%s > %s 2> %s"
157+ command output-file error-file))))
158 (process-event
159 (list process
160 (dvc-log-event output-buf
161@@ -697,41 +707,44 @@
162 (set-process-sentinel
163 process
164 (dvc-capturing-lambda (process event)
165- (let ((default-directory (capture default-directory)))
166- (dvc-log-event (capture output-buf) (capture error-buf)
167- (capture command)
168- (capture default-directory)
169- (dvc-strip-final-newline event))
170- (setq dvc-process-running
171- (delq (capture process-event) dvc-process-running))
172- (when (file-exists-p (capture error-file))
173- (with-current-buffer (capture error-buf)
174- (insert-file-contents (capture error-file)))
175- (delete-file (capture error-file)))
176- (let ((state (process-status process))
177- (status (process-exit-status process))
178- (dvc-temp-current-active-dvc (capture dvc)))
179- (unwind-protect
180- (cond ((and (eq state 'exit) (= status 0))
181- (funcall (or (capture finished)
182- 'dvc-default-finish-function)
183- (capture output-buf) (capture error-buf)
184- status (capture arguments)))
185- ((eq state 'signal)
186- (funcall (or (capture killed)
187- 'dvc-default-killed-function)
188- (capture output-buf) (capture error-buf)
189- status (capture arguments)))
190- ((eq state 'exit) ;; status != 0
191- (funcall (or (capture error)
192- 'dvc-default-error-function)
193- (capture output-buf) (capture error-buf)
194- status (capture arguments)))))
195- ;; Schedule any buffers we created for killing
196- (unless (capture output-buffer)
197- (dvc-kill-process-buffer (capture output-buf)))
198- (unless (capture error-buffer)
199- (dvc-kill-process-buffer (capture error-buf)))))))
200+ (labels ((slurp-file (file buffer)
201+ (when (file-exists-p file)
202+ (with-current-buffer buffer
203+ (insert-file-contents file))
204+ (delete-file file))))
205+ (let ((default-directory (capture default-directory)))
206+ (dvc-log-event (capture output-buf) (capture error-buf)
207+ (capture command)
208+ (capture default-directory)
209+ (dvc-strip-final-newline event))
210+ (setq dvc-process-running
211+ (delq (capture process-event) dvc-process-running))
212+ (slurp-file (capture output-file) (capture output-buf))
213+ (slurp-file (capture error-file) (capture error-buf))
214+ (let ((state (process-status process))
215+ (status (process-exit-status process))
216+ (dvc-temp-current-active-dvc (capture dvc)))
217+ (unwind-protect
218+ (cond ((and (eq state 'exit) (= status 0))
219+ (funcall (or (capture finished)
220+ 'dvc-default-finish-function)
221+ (capture output-buf) (capture error-buf)
222+ status (capture arguments)))
223+ ((eq state 'signal)
224+ (funcall (or (capture killed)
225+ 'dvc-default-killed-function)
226+ (capture output-buf) (capture error-buf)
227+ status (capture arguments)))
228+ ((eq state 'exit) ;; status != 0
229+ (funcall (or (capture error)
230+ 'dvc-default-error-function)
231+ (capture output-buf) (capture error-buf)
232+ status (capture arguments)))))
233+ ;; Schedule any buffers we created for killing
234+ (unless (capture output-buffer)
235+ (dvc-kill-process-buffer (capture output-buf)))
236+ (unless (capture error-buffer)
237+ (dvc-kill-process-buffer (capture error-buf))))))))
238 process))))
239
240 (defun dvc-run-dvc-sync (dvc arguments &rest keys)
241
242=== modified file 'lisp/xhg.el'
243--- lisp/xhg.el 2009-08-31 11:43:24 +0000
244+++ lisp/xhg.el 2010-02-25 22:31:14 +0000
245@@ -1043,9 +1043,9 @@
246 (dvc-default-finish-function output error status arguments)
247 (message "hg %s complete for %s" opt-string default-directory)))))
248
249-(defun xhg-convert (source target)
250+(defun xhg-convert (source target &optional revnum)
251 "Convert a foreign SCM repository to a Mercurial one.
252-
253+With prefix arg prompt for REVNUM.
254 Accepted source formats [identifiers]:(Mercurial-1.1.2)
255 - Mercurial [hg]
256 - CVS [cvs]
257@@ -1063,14 +1063,17 @@
258 Read also: hg help convert.
259 "
260 (interactive "DSource: \nsTarget: ")
261- (message "Started hg conversion of [%s] to [%s] ..." source target)
262- (dvc-run-dvc-async 'xhg (list "convert"
263- (expand-file-name source)
264- (expand-file-name target))
265- :finished (dvc-capturing-lambda (output error status arguments)
266- (let ((default-directory (capture target)))
267- (xhg-update))
268- (message "hg: [%s] successfully converted to [%s]" (capture source) (capture target)))))
269+ (let* ((src (expand-file-name source))
270+ (tget (expand-file-name target))
271+ (rev (if current-prefix-arg (read-string "Revision: ") revnum))
272+ (arg-list (if rev (list "convert" src tget "-r" rev) (list "convert" src tget))))
273+ (message "HG conversion of `%s' to `%s' ..." source target)
274+ (dvc-run-dvc-async 'xhg arg-list
275+ :finished (dvc-capturing-lambda (output error status arguments)
276+ (let ((default-directory (capture target)))
277+ (xhg-update))
278+ (message "HG conversion of `%s' to `%s' ... done."
279+ (capture source) (capture target))))))
280
281 ;; --------------------------------------------------------------------------------
282 ;; hg serve functionality
283
284=== modified file 'lisp/xmtn-automate.el'
285--- lisp/xmtn-automate.el 2009-10-03 12:39:58 +0000
286+++ lisp/xmtn-automate.el 2010-02-25 22:31:14 +0000
287@@ -26,98 +26,39 @@
288 ;; This library provides access to monotone's "automate" interface
289 ;; from Emacs Lisp.
290 ;;
291-;; I found monotone's automate stdio mode (see
292-;; http://www.venge.net/monotone/docs/Automation.html for details)
293-;; rather intriguing, so I tried to make full use of it. I don't know
294-;; whether it is really significantly more efficient than spawning a
295-;; new subprocess for each command. But, in theory, feeding multiple
296-;; commands to one process allows that process to do all kinds of
297-;; smart caching, so it could make very large differences, even
298-;; differences in orders of magnitude. I don't know whether monotone
299-;; currently does any caching, but at least this means we have an
300-;; excuse for not doing any caching in Emacs. (If it becomes clear
301-;; that caching would be a good idea, it can be implemented in
302-;; monotone instead of Emacs; this way, other front-ends to monotone
303-;; can also benefit from it.)
304+;; see http://www.monotone.ca/docs/Automation.html#Automation for
305+;; details of the monotone automate command.
306+;;
307+;; mtn automate allows sending several commands to a single mtn
308+;; process, and provides the results in a form that is easy to
309+;; parse. It does some caching between command, and will do more in
310+;; the future, so this is a significant speed-up over spawning a new
311+;; subprocess for each command.
312 ;;
313 ;; To allow xmtn-automate to track how long an automate stdio process
314-;; needs to be kept around, we introduce the concept of a session. To
315-;; the programmer using this library, a session is an opaque object
316-;; that is needed to run automate commands. Each session is
317-;; associated with a monotone workspace ("root") that the commands
318-;; will operate on. (Using xmtn-auomate to run commands with no
319-;; workspace is not currently part of the design.) A session can be
320-;; obtained using `xmtn-automate-with-session' and has dynamic extent.
321-;; Note that `xmtn-automate-with-session' doesn't necessarily start a
322-;; fresh monotone process; xmtn-automate may reuse existing session
323-;; objects and processes, or launch the process only when the first
324-;; command is sent to the session. There is also no guarantee about
325-;; how long xmtn-automate will keep the process running after
326-;; `xmtn-automate-with-session' exits. (The function
327-;; `xmtn-automate-terminate-processes-in-root' can be used to tell
328-;; xmtn-automate to terminate all processes in a given root as soon as
329-;; possible, and wait until they terminate. I imagine this could be
330-;; necessary to free locks, but whether mtn automate stdio does any
331-;; locking doesn't seem to be specified in monotone's manual.) To put
332-;; it another way, the mapping between `xmtn-automate-with-session'
333-;; forms and monotone processes is not necessarily one-to-one.
334-;;
335-;; `xmtn-automate-with-session' forms can safely be nested.
336+;; needs to be kept around, and to store meta data, we introduce the
337+;; concept of a session. To the programmer using this library, a
338+;; session is an opaque object that is needed to run automate
339+;; commands. Each session is associated with a monotone workspace
340+;; ("root") that the commands will operate on. A session can be
341+;; obtained using `xmtn-automate-cache-session'. Note that
342+;; `xmtn-automate-cache-session' doesn't necessarily start a fresh
343+;; monotone process, if a session with that root already exists. The
344+;; process must be killed with `xmtn-automate-kill-session'.
345 ;;
346 ;; Once you have a session object, you can use
347-;; `xmtn-automate-with-command' forms to send commands to monotone.
348-;; Each such form gets you a so-called command-handle. Again, this is
349-;; an opaque object with dynamic extent. You can use this handle to
350-;; check the error code of the command and obtain its output. Your
351-;; Emacs Lisp code can also do other computation while the monotone
352-;; command runs. Allowing this kind of parallelism and incremental
353-;; processing of command output is the main reason for introducing
354-;; command handles.
355-;;
356-;; The following operations are defined on command handles.
357-;;
358-;; * xmtn-automate-command-error-code (command-handle) --> 0, 1 or 2
359-;;
360-;; Returns the error code of the command. See monotone
361-;; documentation. This operation blocks until the monotone process
362-;; has sent the error code.
363-;;
364-;; * xmtn-automate-command-wait-until-finished (command-handle) -->
365-;; nil
366-;;
367-;; Blocks until the command has finished (successfully or not).
368-;; After this operation returns, `xmtn-automate-command-finished-p'
369-;; will return true for this command.
370-;;
371-;; * xmtn-automate-command-buffer (command-handle) --> buffer
372-;;
373-;; Returns the so-called command buffer associated with the command
374-;; handle. This is a buffer with the output that the command has
375-;; generated so far. The buffer contents will be updated as new
376-;; output arrives. The buffer has the same extent as the command
377-;; handle. This operation does not block.
378-;;
379-;; * xmtn-automate-command-write-marker-position (command-handle)
380-;; --> position
381-;;
382-;; The position in the output buffer after the last character of
383-;; output the command has generated so far. This is also where new
384-;; output will be inserted. This operation does not block.
385-;;
386-;; * xmtn-automate-command-finished-p (command-handle) --> boolean
387-;;
388-;; Returns nil if the command is still running, non-nil if it has
389-;; finished (successfully or not). If this function returns non-nil,
390-;; the full output of the command is available in the command buffer.
391-;; This operation does not block.
392-;;
393-;; * xmtn-automate-command-accept-output (command-handle) -->
394-;; output-received-p
395-;;
396-;; Allows Emacs to process more output from the command (and
397-;; possibly from other processes). Blocks until more output has
398-;; been received from the command or the command has finished.
399-;; Returns non-nil if more output has been received.
400+;; `xmtn-automate-new-command' to send commands to monotone.
401+;;
402+;; A COMMAND is a list of strings (the command and its arguments), or
403+;; a cons of lists of strings. If car COMMAND is a list, car COMMAND is
404+;; options (without leading "--"), cdr is the command and arguments.
405+;;
406+;; `xmtn-automate-new-command' returns a command handle. You use this
407+;; handle to check the error code of the command and obtain its
408+;; output. Your Emacs Lisp code can also do other computation while
409+;; the monotone command runs. Allowing this kind of parallelism and
410+;; incremental processing of command output is the main reason for
411+;; introducing command handles.
412 ;;
413 ;; The intention behind this protocol is to allow Emacs Lisp code to
414 ;; process command output incrementally as it arrives instead of
415@@ -127,88 +68,15 @@
416 ;; hard to tune it, either. So I'm not sure whether incremental
417 ;; processing is useful.
418 ;;
419-;; In the output buffer, the "chunking" (the <command number>:<err
420-;; code>:<last?>:<size>:<output> thing) that monotone automate stdio does
421-;; has already been decoded and removed. However, no other processing or
422-;; parsing has been done. The output buffer contains raw 8-bit data.
423-;;
424-;; Different automate commands generate data in different formats: For
425-;; example, get_manifest generates basic_io; select generates a list
426-;; of lines with one ID each, graph generates a list of lines with one
427-;; or more IDs each; inventory and the packet_* commands generate
428-;; different custom line-based formats; and get_file generates binary
429-;; output. Parsing these formats is not part of xmtn-automate.
430-;;
431-;; You shouldn't manually kill the output buffer; xmtn-automate will take
432-;; care of it when the `xmtn-automate-with-command' form exits.
433-;;
434-;; Example:
435-;;
436-;; (xmtn-automate-with-session (session "/path/to/workspace")
437-;; ;; The variable `session' now holds a session object associated
438-;; ;; with the workspace.
439-;; (xmtn-automate-with-command (handle session '("get_base_revision_id"))
440-;; ;; The variable `handle' now holds a command handle.
441-;; ;; Check that the command was successful (not described above);
442-;; ;; generate a default error message otherwise and abort.
443-;; (xmtn-automate-command-check-for-and-report-error handle)
444-;; ;; Wait until the entire output of the command has arrived.
445-;; (xmtn-automate-command-wait-until-finished handle)
446-;; ;; Process output (in command buffer).
447-;; (message "Base revision id is %s"
448-;; (with-current-buffer (xmtn-automate-command-buffer handle)
449-;; (buffer-substring (point-min)
450-;; ;; Ignore final newline.
451-;; (1- (point-max)))))))
452-;;
453-;; There are some utility functions built on top of this general
454-;; interface that help express common uses more concisely; for
455-;; example,
456-;;
457-;; (message "Base revision id is %s"
458-;; (xmtn-automate-simple-command-output-line
459-;; "/path/to/workspace" '("get_base_revision_id")))
460-;;
461-;; does the same thing as the above code.
462-;;
463-;; If multiple "simple" automate commands are run in succession on the
464-;; same workspace, it's a good idea to wrap an
465-;; `xmtn-automate-with-session' form around them so xmtn knows that it
466-;; should reuse the same process.
467-;;
468-;; (xmtn-automate-with-session (nil "/path/to/workspace")
469-;; (message "Base revision id is %s, current revision is %s"
470-;; (xmtn-automate-simple-command-output-line
471-;; "/path/to/workspace" '("get_base_revision_id"))
472-;; (xmtn-automate-simple-command-output-line
473-;; "/path/to/workspace" '("get_current_revision_id")))
474-;;
475-;; Here, the session object is not explicitly passed to the functions
476-;; that actually feed commands to monotone. But, since the containing
477-;; session is still open after the first command, xmtn knows that it
478-;; should keep the process alive, and it is smart enough to reuse the
479-;; process for the second command.
480-;;
481-;; The fact that `xmtn-automate-with-command' always forces commands
482-;; to either happen in sequence or properly nested can be a
483-;; limitation. For example, it's not possible to write a
484-;; (non-recursive) loop that runs N automate commands and processes
485-;; their output, always launching the (k+1)th automate command ahead
486-;; of time to run in parallel with the kth iteration. (Some of the
487-;; revlist and cert-parsing code really wants to do this, I think.)
488-;; (But maybe writing this recursively wouldn't be all that bad... It
489-;; is asymptotically less (stack-!)space-efficient but makes it
490-;; impossible to get the cleanup wrong.) Providing the two halves of
491-;; `xmtn-automate-with-command' as two functions
492-;; `xmtn-automate-open-command' and `xmtn-automate-close-command' that
493-;; always need to be called in pairs would be more flexible. (Common
494-;; Lisp also has with-open-file but also open and close.)
495+;; In the output buffer, the mtn stdio output header (<command
496+;; number>:<err code>:<last?>:<size>:<data>) has been processed;
497+;; only the data is present.
498+
499+;; There are some notes on the design of xmtn in
500+;; docs/xmtn-readme.txt.
501
502 ;;; Code:
503
504-;;; There are some notes on the design of xmtn in
505-;;; docs/xmtn-readme.txt.
506-
507 (eval-and-compile
508 (require 'cl)
509 (require 'parse-time) ;for parse-integer
510@@ -255,92 +123,36 @@
511 (xmtn-automate-command-finished-p handle))))
512 nil)
513
514-(defvar xmtn-automate--*sessions* '())
515+(defvar xmtn-automate--*sessions* '()
516+ "Assoc list of sessions, indexed by uniquified root directory.")
517
518 (defun xmtn-automate-cache-session (root)
519- "Create a mtn automate session for workspace ROOT, store it in
520-session cache, return it (for later kill)."
521- (let* ((default-directory (file-name-as-directory root))
522- (key (file-truename default-directory))
523- (session (xmtn-automate--make-session root key)))
524- (setq xmtn-automate--*sessions*
525- (acons key session xmtn-automate--*sessions*))
526- session))
527+ "If necessary, create a mtn automate session for workspace
528+ROOT, store it in session cache. Return session."
529+ ;; we require an explicit root argument here, rather than relying on
530+ ;; default-directory, because one application is to create several
531+ ;; sessions for several workspaces, and operate on them as a group
532+ ;; (see xmtn-multi-status.el, for example).
533+ (let* ((default-directory (dvc-uniquify-file-name root))
534+ (session (xmtn-automate-get-cached-session default-directory)))
535+ (or session
536+ (progn
537+ (setq session (xmtn-automate--make-session default-directory default-directory))
538+ (setq xmtn-automate--*sessions*
539+ (acons default-directory session xmtn-automate--*sessions*))
540+ session))))
541
542 (defun xmtn-automate-get-cached-session (key)
543- "Return a session from the cache, or nil."
544- ;; separate function so we can debug it
545+ "Return a session from the cache, or nil. KEY is uniquified
546+workspace root."
547 (cdr (assoc key xmtn-automate--*sessions*)))
548
549-(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key)
550- &body body)
551- "Call BODY, after ensuring an automate session for ROOT-FORM is active."
552- (declare (indent 1) (debug (sexp body)))
553- ;; I would prefer to factor out a function
554- ;; `xmtn-automate--call-with-session' here, but that would make
555- ;; profiler output unreadable, since every function would only
556- ;; appear to call `xmtn-automate--call-with-session', and that
557- ;; function would appear to do all computation.
558- ;;
559- ;; mtn automate stdio requires a valid database, so we require a
560- ;; root directory here.
561- (let ((session (gensym))
562- (session-var (or session-var-or-null (gensym)))
563- (root (gensym))
564- (key (gensym))
565- (thunk (gensym)))
566- `(let* ((,root (file-name-as-directory ,root-form))
567- (,key (file-truename ,root))
568- (,session (xmtn-automate-get-cached-session ,key))
569- (,thunk (lambda ()
570- (let ((,session-var ,session))
571- ,@body))))
572- (if ,session
573- (funcall ,thunk)
574- (unwind-protect
575- (progn
576- (setq ,session (xmtn-automate--make-session ,root ,key))
577- (let ((xmtn-automate--*sessions*
578- ;; note the let-binding here; these sessions are _not_
579- ;; available for later commands. use
580- ;; xmtn-automate-cache-session to get a persistent
581- ;; session.
582- (acons ,key ,session xmtn-automate--*sessions*)))
583- (funcall ,thunk)))
584- (when ,session (xmtn-automate--close-session ,session)))))))
585-
586-(defmacro* xmtn-automate-with-command ((handle-var session-form command-form
587- &key ((:may-kill-p
588- may-kill-p-form)))
589- &body body)
590- "Send COMMAND_FORM (a list of strings, or cons of lists of
591-strings) to session SESSION_FORM (current if nil). If car
592-COMMAND_FORM is a list, car COMMAND_FORM is options, cdr is command.
593-Then execute BODY."
594- (declare (indent 1) (debug (sexp body)))
595- (let ((session (gensym))
596- (command (gensym))
597- (may-kill-p (gensym))
598- (handle (gensym)))
599- `(let ((,session ,session-form)
600- (,command ,command-form)
601- (,may-kill-p ,may-kill-p-form)
602- (,handle nil))
603- (unwind-protect
604- (progn
605- (setq ,handle (xmtn-automate--new-command ,session
606- ,command
607- ,may-kill-p))
608- (xmtn--assert-optional (xmtn-automate--command-handle-p ,handle))
609- (let ((,handle-var ,handle))
610- ,@body))
611- (when ,handle
612- (xmtn-automate--cleanup-command ,handle))))))
613-
614 (defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle)
615 (xmtn-automate-command-wait-until-finished handle)
616 (with-current-buffer (xmtn-automate-command-buffer handle)
617- (buffer-substring-no-properties (point-min) (point-max))))
618+ (prog1
619+ (buffer-substring-no-properties (point-min) (point-max))
620+ (xmtn-automate--cleanup-command handle))))
621
622 (defun xmtn-automate-command-check-for-and-report-error (handle)
623 (unless (eql (xmtn-automate-command-error-code handle) 0)
624@@ -351,30 +163,27 @@
625 nil)
626
627 (defun xmtn-automate-simple-command-output-string (root command)
628- "Send COMMAND (a list of strings, or cons of lists of strings)
629-to current session. If car COMMAND is a list, car COMMAND is
630-options, cdr is command. Return result as a string."
631- (xmtn-automate-with-session (session root)
632- (xmtn-automate-with-command (handle session command)
633- (xmtn-automate-command-check-for-and-report-error handle)
634- (xmtn-automate--command-output-as-string-ignoring-exit-code handle))))
635+ "Send COMMAND to session for ROOT. Return result as a string."
636+ (let* ((session (xmtn-automate-cache-session root))
637+ (command-handle (xmtn-automate--new-command session command nil)))
638+ (xmtn-automate-command-check-for-and-report-error command-handle)
639+ (xmtn-automate--command-output-as-string-ignoring-exit-code command-handle)))
640
641 (defun xmtn-automate-simple-command-output-insert-into-buffer
642 (root buffer command)
643- "Send COMMAND (a list of strings, or cons of lists of strings)
644-to current session. If car COMMAND is a list, car COMMAND is
645-options, cdr is command. Insert result into BUFFER."
646- (xmtn-automate-with-session (session root)
647- (xmtn-automate-with-command (handle session command)
648- (xmtn-automate-command-check-for-and-report-error handle)
649- (xmtn-automate-command-wait-until-finished handle)
650- (with-current-buffer buffer
651- (xmtn--insert-buffer-substring-no-properties
652- (xmtn-automate-command-buffer handle))))))
653+ "Send COMMAND to session for ROOT, insert result into BUFFER."
654+ (let* ((session (xmtn-automate-cache-session root))
655+ (command-handle (xmtn-automate--new-command session command nil)))
656+ (xmtn-automate-command-check-for-and-report-error command-handle)
657+ (xmtn-automate-command-wait-until-finished command-handle)
658+ (with-current-buffer buffer
659+ (insert-buffer-substring-no-properties
660+ (xmtn-automate-command-buffer command-handle)))
661+ (xmtn-automate--cleanup-command command-handle)))
662
663 (defun xmtn-automate-command-output-lines (handle)
664- ;; Return list of lines of output; first line output is first in
665- ;; list.
666+ "Return list of lines of output in HANDLE; first line output is
667+first in list."
668 (xmtn-automate-command-check-for-and-report-error handle)
669 (xmtn-automate-command-wait-until-finished handle)
670 (save-excursion
671@@ -387,16 +196,16 @@
672 (progn (end-of-line) (point)))
673 result))
674 (forward-line 1))
675+ (xmtn-automate--cleanup-command handle)
676 (nreverse result))))
677
678 (defun xmtn-automate-simple-command-output-lines (root command)
679- "Return list of strings containing output of COMMAND, one line per string."
680- (xmtn-automate-with-session (session root)
681- (xmtn-automate-with-command (handle session command)
682- (xmtn-automate-command-output-lines handle))))
683+ "Return list of strings containing output of COMMAND, one line per
684+string."
685+ (let* ((session (xmtn-automate-cache-session root))
686+ (command-handle (xmtn-automate--new-command session command nil)))
687+ (xmtn-automate-command-output-lines command-handle)))
688
689-;; This one is used twice. I think the error checking it provides is
690-;; a reasonable simplification for its callers.
691 (defun xmtn-automate-simple-command-output-line (root command)
692 "Return the one line output from mtn automate as a string.
693
694@@ -409,19 +218,11 @@
695 command))
696 (first lines)))
697
698-
699 (defun xmtn-automate--set-process-session (process session)
700- (xmtn--assert-optional (typep session 'xmtn-automate--session) t)
701- (xmtn--process-put process 'xmtn-automate--session session))
702+ (process-put process 'xmtn-automate--session session))
703
704 (defun xmtn-automate--process-session (process)
705- (xmtn--assert-optional (processp process) t)
706- (let ((session (xmtn--process-get process 'xmtn-automate--session)))
707- ;; This seems to fail sometimes with session being nil. Not sure
708- ;; why. The problem seems to be reproducible by calling
709- ;; (dvc-dvc-revision-nth-ancestor `(xmtn (local-tree ,(dvc-tree-root))) 10).
710- (xmtn--assert-optional (typep session 'xmtn-automate--session) t)
711- session))
712+ (process-get process 'xmtn-automate--session))
713
714 (defstruct (xmtn-automate--decoder-state
715 (:constructor xmtn-automate--%make-raw-decoder-state))
716@@ -437,8 +238,7 @@
717 (buffer nil)
718 (process nil)
719 (decoder-state)
720- (next-mtn-command-number)
721- (next-session-command-number 0)
722+ (next-command-number 0)
723 (must-not-kill-counter)
724 (remaining-command-handles)
725 (sent-kill-p)
726@@ -492,6 +292,7 @@
727 nil)
728
729 (defun xmtn-automate--close-session (session)
730+ "Kill session process, buffer."
731 (setf (xmtn-automate--session-closed-p session) t)
732 (let ((process (xmtn-automate--session-process session)))
733 (cond
734@@ -537,9 +338,8 @@
735 (let ((process-connection-type nil)
736 (default-directory root))
737 (let ((process
738- (xmtn--with-environment-for-subprocess ()
739- (apply #'start-process name buffer xmtn-executable
740- "automate" "stdio" xmtn-additional-arguments))))
741+ (apply 'start-process name buffer xmtn-executable
742+ "automate" "stdio" xmtn-additional-arguments)))
743 (xmtn-automate--set-process-session process session)
744 (set-process-filter process 'xmtn-automate--process-filter)
745 (set-process-sentinel process 'xmtn-automate--process-sentinel)
746@@ -555,13 +355,13 @@
747 (xmtn--assert-optional (eql (point-min) (point)) t)
748 (set-marker (make-marker)
749 (point-min)))))
750- (setf (xmtn-automate--session-next-mtn-command-number session) 0)
751 (setf (xmtn-automate--session-must-not-kill-counter session) 0)
752 (setf (xmtn-automate--session-remaining-command-handles session) (list))
753 (setf (xmtn-automate--session-sent-kill-p session) nil)
754 process))))
755
756 (defun xmtn-automate--ensure-process (session)
757+ "Ensure SESSION has an active process; restart it if it died."
758 (let ((process (xmtn-automate--session-process session)))
759 (when (or (null process)
760 (ecase (process-status process)
761@@ -575,33 +375,16 @@
762 process))
763
764 (defun xmtn-automate--new-buffer (session)
765- (let* ((buffer-base-name (format "*%s: session*"
766+ (let* ((buffer-base-name (format " *%s: session*"
767 (xmtn-automate--session-name session)))
768 (buffer (generate-new-buffer buffer-base-name)))
769 (with-current-buffer buffer
770 (buffer-disable-undo)
771- (xmtn--set-buffer-multibyte nil)
772+ (set-buffer-multibyte nil)
773 (setq buffer-read-only t))
774 (setf (xmtn-automate--session-buffer session) buffer)
775 buffer))
776
777-(defun xmtn-automate-terminate-processes-in-root (root)
778- (xmtn-automate-with-session (session root)
779- (xmtn-automate--close-session session)
780- (let ((process (xmtn-automate--session-process session)))
781- (when process
782- (while (ecase (process-status process)
783- (run t)
784- (exit nil)
785- (signal nil))
786- (accept-process-output process))
787- (dvc-trace "Process in root %s terminated" root)
788- ))
789- (xmtn-automate--initialize-session
790- session
791- :root (xmtn-automate--session-root session)
792- :name (xmtn-automate--session-name session))))
793-
794 (defun xmtn-automate--append-encoded-strings (strings)
795 "Encode STRINGS (a list of strings or nil) in automate stdio format,
796 insert into current buffer. Assumes that point is at the end of
797@@ -616,12 +399,10 @@
798 (goto-char (point-max)))))
799 nil)
800
801-(defun xmtn-automate--send-command-string (session command option-plist
802- mtn-number session-number)
803+(defun xmtn-automate--send-command-string (session command option-plist session-number)
804 "Send COMMAND and OPTION-PLIST to SESSION."
805- (let* ((buffer-name (format "*%s: input for command %s(%s)*"
806+ (let* ((buffer-name (format "*%s: input for command %s*"
807 (xmtn-automate--session-name session)
808- mtn-number
809 session-number))
810 (buffer nil))
811 (unwind-protect
812@@ -635,7 +416,7 @@
813 (setq buffer (get-buffer-create buffer-name))
814 (with-current-buffer buffer
815 (buffer-disable-undo)
816- (xmtn--set-buffer-multibyte t)
817+ (set-buffer-multibyte t)
818 (setq buffer-read-only t)
819 (let ((inhibit-read-only t))
820 (when option-plist
821@@ -655,22 +436,14 @@
822 (kill-buffer buffer))))))
823
824 (defun xmtn-automate--new-command (session command may-kill-p)
825- "Send COMMAND (a list of strings, or cons of lists of strings)
826-to the current automate stdio session. If car COMMAND is a list,
827-car COMMAND is options, cdr is command."
828- ;; For debugging.
829- ;;(xmtn-automate-terminate-processes-in-root
830- ;; (xmtn-automate--session-root session))
831+ "Send COMMAND to SESSION."
832 (xmtn-automate--ensure-process session)
833- (let* ((mtn-number (1- (incf (xmtn-automate--session-next-mtn-command-number
834- session))))
835- (session-number
836- (1- (incf (xmtn-automate--session-next-session-command-number
837+ (let* ((command-number
838+ (1- (incf (xmtn-automate--session-next-command-number
839 session))))
840- (buffer-name (format "*%s: output for command %s(%s)*"
841+ (buffer-name (format " *%s: output for command %s*"
842 (xmtn-automate--session-name session)
843- mtn-number
844- session-number))
845+ command-number))
846 (buffer
847 (progn (when (get-buffer buffer-name)
848 ;; Make sure no local variables or mode changes
849@@ -681,21 +454,18 @@
850 (fundamental-mode)))
851 (get-buffer-create buffer-name))))
852 (if (not (listp (car command)))
853- (xmtn-automate--send-command-string session command '()
854- mtn-number session-number)
855- (xmtn-automate--send-command-string session (cdr command) (car command)
856- mtn-number session-number))
857+ (xmtn-automate--send-command-string session command '() command-number)
858+ (xmtn-automate--send-command-string session (cdr command) (car command) command-number))
859 (with-current-buffer buffer
860 (buffer-disable-undo)
861- (xmtn--set-buffer-multibyte nil)
862+ (set-buffer-multibyte nil)
863 (setq buffer-read-only t)
864 (xmtn--assert-optional (and (eql (point) (point-min))
865 (eql (point) (point-max))))
866 (let ((handle (xmtn-automate--%make-raw-command-handle
867 :session session
868 :arguments command
869- :mtn-command-number mtn-number
870- :session-command-number session-number
871+ :session-command-number command-number
872 :may-kill-p may-kill-p
873 :buffer buffer
874 :write-marker (set-marker (make-marker) (point)))))
875@@ -742,9 +512,9 @@
876 (goto-char write-marker)
877 (let ((inhibit-read-only t)
878 deactivate-mark)
879- (xmtn--insert-buffer-substring-no-properties session-buffer
880- read-marker
881- end))
882+ (insert-buffer-substring-no-properties session-buffer
883+ read-marker
884+ end))
885 (set-marker write-marker (point))))
886 ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil)
887 )
888@@ -802,8 +572,9 @@
889 (xmtn-automate--decoder-state-last-p state))
890 (xmtn--assert-optional command)
891 (setf (xmtn-automate--command-handle-finished-p command) t)
892- (xmtn--with-no-warnings
893- (pop (xmtn-automate--session-remaining-command-handles session)))
894+ (with-no-warnings
895+ ;; discard result
896+ (pop (xmtn-automate--session-remaining-command-handles session)))
897 (setq tag 'check-for-more)
898 (when (not (xmtn-automate--command-handle-may-kill-p command))
899 (when (zerop (decf (xmtn-automate--session-must-not-kill-counter
900@@ -919,7 +690,7 @@
901 (message "Process %s died due to signal" (process-name process))
902 (when (not (zerop (xmtn-automate--session-must-not-kill-counter
903 session)))
904- (xmtn--lwarn
905+ (lwarn
906 'xmtn ':error
907 "Process %s died due to signal during a critical operation"
908 (process-name process))))))))))
909@@ -1007,6 +778,18 @@
910 (defun xmtn--tree-default-branch (root)
911 (xmtn-automate-simple-command-output-line root `("get_option" "branch")))
912
913+(defun xmtn-automate-local-changes (work)
914+ "Summary of status for WORK; 'ok if no changes, 'need-commit if changes."
915+ (message "checking %s for local changes" work)
916+ (let ((default-directory work))
917+
918+ (let ((result (xmtn-automate-simple-command-output-string
919+ default-directory
920+ (list (list "no-unchanged" "no-ignored")
921+ "inventory"))))
922+ (if (> (length result) 0)
923+ 'need-commit
924+ 'ok))))
925
926 (provide 'xmtn-automate)
927
928
929=== modified file 'lisp/xmtn-compat.el'
930--- lisp/xmtn-compat.el 2009-10-03 12:39:58 +0000
931+++ lisp/xmtn-compat.el 2010-02-25 22:31:14 +0000
932@@ -1,6 +1,6 @@
933 ;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions
934
935-;; Copyright (C) 2008 Stephen Leake
936+;; Copyright (C) 2008, 2009 Stephen Leake
937 ;; Copyright (C) 2006, 2007 Christian M. Ohler
938
939 ;; Author: Christian M. Ohler
940@@ -34,36 +34,6 @@
941 (eval-and-compile
942 (require 'cl))
943
944-(defun xmtn--temp-directory ()
945- (if (fboundp 'temp-directory)
946- (temp-directory)
947- temporary-file-directory))
948-
949-(defun xmtn--make-temp-file (prefix &optional dirp suffix)
950- ;; Do this in a temp buffer to ensure we use the default file output
951- ;; encoding. Emacs 21's `make-temp-file' uses the current buffer's
952- ;; output format function while writing the file with `write-region'
953- ;; with a string as its first argument, but coding conversion errors
954- ;; when `write-region' is called in this way.
955- (with-temp-buffer
956- ;; XEmacs' `make-temp-file' doesn't automatically use temp
957- ;; directory.
958- (setq prefix (expand-file-name prefix (xmtn--temp-directory)))
959- ;; FIXME: Ignoring suffix for now since Emacs 21 doesn't support it.
960- (make-temp-file prefix dirp)))
961-
962-(defvar xmtn--*process-plists* (make-hash-table :weakness 'key))
963-
964-;;; These should probably use `process-get' and `process-put' if
965-;;; available, but that's not important.
966-(defun xmtn--process-put (process propname value)
967- (setf (getf (gethash process xmtn--*process-plists*) propname) value)
968- ;; Mimic the return value that `process-put' would yield.
969- (gethash process xmtn--*process-plists*))
970-
971-(defsubst xmtn--process-get (process propname)
972- (getf (gethash process xmtn--*process-plists*) propname nil))
973-
974 (defmacro xmtn--set-process-query-on-exit-flag (process value)
975 (if (fboundp 'set-process-query-on-exit-flag)
976 ;; emacs 22.2 and greater
977@@ -73,54 +43,6 @@
978 (process-kill-without-query ,process ,value)
979 ,value)))
980
981-(defmacro xmtn--insert-buffer-substring-no-properties (from-buffer
982- &optional start end)
983- (if (fboundp 'insert-buffer-substring-no-properties)
984- `(insert-buffer-substring-no-properties ,from-buffer ,start ,end)
985- `(progn
986- (insert (with-current-buffer ,from-buffer
987- (buffer-substring-no-properties (or ,start (point-min))
988- (or ,end (point-max)))))
989- nil)))
990-
991-(defun xmtn--lwarn (tag level message &rest args)
992- (if (fboundp 'lwarn)
993- (apply #'lwarn tag level message args)
994- (apply #'message message args))
995- ;; The return value of `lwarn' seems to be pretty much undefined, so
996- ;; we don't try to replicate it here.
997- nil)
998-
999-(defmacro* xmtn--with-no-warnings (&body body)
1000- (if (fboundp 'with-no-warnings)
1001- `(with-no-warnings ,@body)
1002- `(progn ,@body)))
1003-
1004-(defmacro* xmtn--with-temp-message (message &body body)
1005- (declare (indent 1) (debug (form body)))
1006- (if (fboundp 'with-temp-message)
1007- `(with-temp-message ,message ,@body)
1008- `(progn ,@body)))
1009-
1010-(defmacro* xmtn--dotimes-with-progress-reporter ((i n-form &optional res-form)
1011- message-form
1012- &body body)
1013- (declare (indent 2) (debug (sexp form body)))
1014- (if (fboundp 'dotimes-with-progress-reporter)
1015- `(dotimes-with-progress-reporter (,i ,n-form ,res-form)
1016- ,message-form ,@body)
1017- (let ((message (gensym)))
1018- `(let ((,message ,message-form))
1019- (prog1
1020- (xmtn--with-temp-message ,message
1021- (dotimes (,i ,n-form ,res-form)
1022- ,@body))
1023- (message "%sdone" ,message))))))
1024-
1025-(defmacro xmtn--set-buffer-multibyte (flag)
1026- (when (fboundp 'set-buffer-multibyte)
1027- `(set-buffer-multibyte ,flag)))
1028-
1029 (provide 'xmtn-compat)
1030
1031 ;;; xmtn-compat.el ends here
1032
1033=== modified file 'lisp/xmtn-conflicts.el'
1034--- lisp/xmtn-conflicts.el 2009-10-03 12:41:39 +0000
1035+++ lisp/xmtn-conflicts.el 2010-02-25 22:31:14 +0000
1036@@ -1079,12 +1079,16 @@
1037 "Perform propagate on revisions in current conflict buffer."
1038 (interactive)
1039 (save-some-buffers t); log buffer
1040+ ;; save-some-buffers does not save the conflicts buffer, which is the current buffer
1041+ (save-buffer)
1042 (xmtn-propagate-from xmtn-conflicts-left-branch cached-branch))
1043
1044 (defun xmtn-conflicts-do-merge ()
1045 "Perform merge on revisions in current conflict buffer."
1046 (interactive)
1047 (save-some-buffers t); log buffer
1048+ ;; save-some-buffers does not save the conflicts buffer, which is the current buffer
1049+ (save-buffer)
1050 (xmtn-dvc-merge-1 default-directory nil))
1051
1052 (defun xmtn-conflicts-ediff-resolution-ws ()
1053
1054=== modified file 'lisp/xmtn-dvc.el'
1055--- lisp/xmtn-dvc.el 2009-10-03 12:41:39 +0000
1056+++ lisp/xmtn-dvc.el 2010-02-25 22:31:14 +0000
1057@@ -83,16 +83,14 @@
1058 `(let ((,root ,root-form)
1059 (,command ,command-form)
1060 (,may-kill-p ,may-kill-p-form))
1061- (xmtn-automate-with-session (,session ,root)
1062- (xmtn-automate-with-command (,handle
1063- ,session ,command
1064- :may-kill-p ,may-kill-p)
1065- (xmtn-automate-command-check-for-and-report-error ,handle)
1066- (xmtn-automate-command-wait-until-finished ,handle)
1067- (xmtn-basic-io-with-stanza-parser (,parser
1068- (xmtn-automate-command-buffer
1069- ,handle))
1070- ,@body))))))
1071+ (let* ((,session (xmtn-automate-cache-session ,root))
1072+ (,handle (xmtn-automate--new-command ,session ,command ,may-kill-p)))
1073+ (xmtn-automate-command-check-for-and-report-error ,handle)
1074+ (xmtn-automate-command-wait-until-finished ,handle)
1075+ (xmtn-basic-io-with-stanza-parser (,parser
1076+ (xmtn-automate-command-buffer
1077+ ,handle))
1078+ ,@body)))))
1079
1080 ;;;###autoload
1081 (defun xmtn-dvc-log-edit-file-name-func (&optional root)
1082@@ -104,154 +102,6 @@
1083 `("toposort"
1084 ,@revision-hash-ids)))
1085
1086-(defun xmtn--insert-log-edit-hints (root branch buffer prefix normalized-files)
1087- (with-current-buffer buffer
1088- (flet ((insert-line (&optional format-string-or-null &rest format-args)
1089- (if format-string-or-null
1090- (let ((line (apply #'format
1091- format-string-or-null format-args)))
1092- (assert (not (position ?\n line)))
1093- (insert prefix line ?\n))
1094- (assert (endp format-args))
1095- (insert prefix ?\n))))
1096- (save-excursion
1097- ;; Launching these mtn processes in parallel is a noticeable
1098- ;; speedup (~14% on some informal benchmarks). At least it
1099- ;; was with the version that I benchmarked, etc.
1100- (xmtn-automate-with-session (nil root)
1101- (let* ((unknown-future (xmtn--unknown-files-future root))
1102- (missing-future (xmtn--missing-files-future root))
1103- (consistent-p-future (xmtn--tree-consistent-p-future root))
1104- (heads (xmtn--heads root branch))
1105- (inconsistent-p (not (funcall consistent-p-future)))
1106- (revision (if inconsistent-p
1107- nil
1108- (xmtn--get-revision root `(local-tree ,root))))
1109- (missing (funcall missing-future)))
1110- (when inconsistent-p
1111- (insert-line
1112- "WARNING: Tree is not consistent.")
1113- (insert-line "Commit will fail unless you fix this first.")
1114- (insert-line))
1115- (when missing
1116- (insert-line "%s missing file(s):" (length missing))
1117- (dolist (file missing) (insert-line "%s" file))
1118- (insert-line)
1119- (insert-line))
1120- (insert-line "Committing on branch:")
1121- (insert-line branch)
1122- (insert-line)
1123- (unless
1124- (let* ((parents (xmtn--revision-old-revision-hash-ids revision))
1125- (all-parents-are-heads-p
1126- (subsetp parents heads :test #'equal))
1127- (all-heads-are-parents-p
1128- (subsetp heads parents :test #'equal)))
1129- (cond ((and (not all-heads-are-parents-p)
1130- (not all-parents-are-heads-p))
1131- (insert-line "This commit will create divergence.")
1132- (insert-line))
1133- ((not all-heads-are-parents-p)
1134- (insert-line (concat "Divergence will continue to exist"
1135- " after this commit."))
1136- (insert-line))
1137- (t
1138- (progn)))))
1139- (case normalized-files
1140- (all
1141- (insert-line "All files selected for commit."))
1142- (t
1143- (insert-line "File(s) selected for commit:")
1144- ;; Normalized file names are easier to read when coming
1145- ;; from dired buffer, since otherwise, they would contain
1146- ;; the entire path.
1147- (dolist (file
1148- ;; Sort in an attempt to match the order of
1149- ;; "patch" lines, below.
1150- (sort (copy-list normalized-files) #'string<))
1151- (insert-line "%s" file))))
1152- ;; Due to the possibility of race conditions, this check
1153- ;; doesn't guarantee the operation will succeed.
1154- (if inconsistent-p
1155- ;; FIXME: Since automate get_revision can't deal with
1156- ;; inconsistent workspaces, we should be using
1157- ;; automate inventory instead.
1158- (progn (insert-line)
1159- (insert-line
1160- (concat "Unable to compute modified files while"
1161- " the tree is inconsistent.")))
1162- (let ((committed-changes (list))
1163- (other-changes (list)))
1164- (flet ((collect (path message)
1165- (if (or (eql normalized-files 'all)
1166- (member path normalized-files))
1167- (push message committed-changes)
1168- (push message other-changes))))
1169- (loop
1170- for (path) in (xmtn--revision-delete revision)
1171- do (collect path (format "delete %s" path)))
1172- (loop
1173- for (from to) in (xmtn--revision-rename revision)
1174- ;; FIXME: collect from or collect to? Monotone
1175- ;; doesn't specify how restrictions work for
1176- ;; renamings.
1177- do (collect to (format "rename %s to %s" from to)))
1178- (loop
1179- for (path) in (xmtn--revision-add-dir revision)
1180- do (collect path (format "add_dir %s" path)))
1181- (loop
1182- for (path contents)
1183- in (xmtn--revision-add-file revision)
1184- do (collect path (format "add_file %s" path)))
1185- (loop
1186- for (path from-contents to-contents)
1187- in (xmtn--revision-patch-file revision)
1188- do (collect path (format "patch %s" path)))
1189- (loop
1190- for (path attr-name)
1191- in (xmtn--revision-clear-attr revision)
1192- do (collect path (format "clear %s %s"
1193- path attr-name)))
1194- (loop
1195- for (path attr-name attr-value)
1196- in (xmtn--revision-set-attr revision)
1197- do (collect path (format "set %s %s %s"
1198- path attr-name attr-value))))
1199- (setq committed-changes (nreverse committed-changes))
1200- (setq other-changes (nreverse other-changes))
1201- (loop
1202- for (lines heading-if heading-if-not) in
1203- `((,committed-changes
1204- ,(format "%s change(s) in selected files:"
1205- (length committed-changes))
1206- "No changes in selected files.")
1207- (,other-changes
1208- ,(format
1209- "%s change(s) in files not selected for commit:"
1210- (length other-changes))
1211- "No changes in files not selected for commit."))
1212- do
1213- (insert-line)
1214- (insert-line "%s" (if lines heading-if heading-if-not))
1215- (dolist (line lines) (insert-line "%s" line)))))
1216- (let ((unknown (funcall unknown-future)))
1217- (insert-line)
1218- (if (endp unknown)
1219- (insert-line "No unknown files.")
1220- (insert-line "%s unknown file(s):" (length unknown))
1221- (dolist (file unknown) (insert-line "%s" file))))))))
1222- (cond ((eql (point) (point-min))
1223- ;; We take this as an indicator that there is no log message
1224- ;; yet. So insert a blank line.
1225- (insert "\n")
1226- (goto-char (point-min)))
1227- (t
1228- ;; Moving up onto the last line of the log message seems to
1229- ;; be better than having the cursor sit at the ## prefix of
1230- ;; the first line of our hints.
1231- (forward-line -1))))
1232- nil)
1233-
1234 (add-to-list 'format-alist
1235 '(xmtn--log-file
1236 "This format automatically removes xmtn's log edit hints from
1237@@ -670,18 +520,6 @@
1238 (setq xmtn-dvc-automate-version
1239 (string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))
1240
1241-(defun xmtn--unknown-files-future (root)
1242- (xmtn--command-output-lines-future root '("ls" "unknown")))
1243-
1244-(defun xmtn--missing-files-future (root)
1245- (xmtn--command-output-lines-future root '("ls" "missing")))
1246-
1247-(defun xmtn--tree-consistent-p-future (root)
1248- ;; FIXME: Should also check for file/dir mismatches.
1249- (lexical-let ((missing-files-future (xmtn--missing-files-future root)))
1250- (lambda ()
1251- (null (funcall missing-files-future)))))
1252-
1253 (defun xmtn--changes-image (change)
1254 (ecase change
1255 (content "content")
1256@@ -1073,20 +911,6 @@
1257 (xmtn--run-command-sync root
1258 `("add" "--" ,@file-names)))
1259
1260-(defun xmtn--file-registered-p (root file-name)
1261- ;; FIXME: need a better way to implement this
1262- (let ((normalized-file-name (xmtn--normalize-file-name root file-name)))
1263- (block parse
1264- (xmtn--with-automate-command-output-basic-io-parser
1265- (parser root `("inventory"))
1266- (xmtn--parse-inventory parser
1267- (lambda (path status changes old-path new-path
1268- old-type new-type fs-type)
1269- (when (equal normalized-file-name path)
1270- (return-from parse
1271- t)))))
1272- nil)))
1273-
1274 ;;;###autoload
1275 (defun xmtn-dvc-add-files (&rest files)
1276 (xmtn--add-files (dvc-tree-root) files))
1277@@ -1214,13 +1038,6 @@
1278 nil)
1279 nil)
1280
1281-(defun xmtn--do-disapprove-future (root revision-hash-id)
1282- ;; Returns a future so the calling code can block on its completion
1283- ;; if it wants to.
1284- (check-type root string)
1285- (check-type revision-hash-id xmtn--hash-id)
1286- (xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id)))
1287-
1288 (defun xmtn--do-update (root target-revision-hash-id post-update-p)
1289 (check-type root string)
1290 (check-type target-revision-hash-id xmtn--hash-id)
1291@@ -1264,23 +1081,22 @@
1292 ;;;###autoload
1293 (defun xmtn-dvc-update (&optional revision-id no-ding)
1294 (let ((root (dvc-tree-root)))
1295- (xmtn-automate-with-session (nil root)
1296- (if revision-id
1297- (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
1298-
1299- (let* ((branch (xmtn--tree-default-branch root))
1300- (heads (xmtn--heads root branch)))
1301- (case (length heads)
1302- (0 (assert nil))
1303- (1
1304- (xmtn--update root (first heads) t no-ding))
1305-
1306- (t
1307- ;; User can choose one head from a revlist, or merge them.
1308- (error (substitute-command-keys
1309- (concat "Branch %s is unmerged (%s heads)."
1310- " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
1311- branch (length heads))))))))
1312+ (if revision-id
1313+ (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
1314+
1315+ (let* ((branch (xmtn--tree-default-branch root))
1316+ (heads (xmtn--heads root branch)))
1317+ (case (length heads)
1318+ (0 (assert nil))
1319+ (1
1320+ (xmtn--update root (first heads) t no-ding))
1321+
1322+ (t
1323+ ;; User can choose one head from a revlist, or merge them.
1324+ (error (substitute-command-keys
1325+ (concat "Branch %s is unmerged (%s heads)."
1326+ " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
1327+ branch (length heads)))))))
1328 nil)
1329
1330 (defun xmtn-propagate-from (other &optional cached-branch)
1331@@ -1325,18 +1141,16 @@
1332
1333 (defun xmtn-dvc-merge-1 (root refresh-status)
1334 (lexical-let ((refresh-status refresh-status))
1335- (xmtn-automate-with-session
1336- (nil root)
1337- (xmtn--run-command-async
1338- root
1339- (list
1340- "merge"
1341- (if (file-exists-p (concat root "/_MTN/conflicts"))
1342- "--resolve-conflicts-file=_MTN/conflicts")
1343- (xmtn-dvc-log-message))
1344- :finished (lambda (output error status arguments)
1345- (if refresh-status
1346- (xmtn--refresh-status-header (current-buffer))))))))
1347+ (xmtn--run-command-async
1348+ root
1349+ (list
1350+ "merge"
1351+ (if (file-exists-p (concat root "/_MTN/conflicts"))
1352+ "--resolve-conflicts-file=_MTN/conflicts")
1353+ (xmtn-dvc-log-message))
1354+ :finished (lambda (output error status arguments)
1355+ (if refresh-status
1356+ (xmtn--refresh-status-header (current-buffer)))))))
1357
1358 ;;;###autoload
1359 (defun xmtn-dvc-merge (&optional other)
1360@@ -1410,74 +1224,70 @@
1361 (defun xmtn--revision-get-file-helper (file backend-id)
1362 "Fill current buffer with the contents of FILE revision BACKEND-ID."
1363 (let ((root (dvc-tree-root)))
1364- (xmtn-automate-with-session (nil root)
1365- (let* ((normalized-file (xmtn--normalize-file-name root file))
1366- (corresponding-file
1367- (xmtn--get-corresponding-path root normalized-file
1368- `(local-tree ,root) backend-id)))
1369- (if (null corresponding-file)
1370- ;; File doesn't exist. Since this function is (as far
1371- ;; as I know) only called from diff-like functions, a
1372- ;; missing file is not an error but just means the diff
1373- ;; should be computed against an empty file. So just
1374- ;; leave the buffer empty.
1375- (progn)
1376- (let ((temp-dir nil))
1377- (unwind-protect
1378- (progn
1379- (setq temp-dir (xmtn--make-temp-file
1380- "xmtn--revision-get-file-" t))
1381- ;; Going through a temporary file and using
1382- ;; `insert-file-contents' in conjunction with as
1383- ;; much of the original file name as possible seems
1384- ;; to be the best way to make sure that Emacs'
1385- ;; entire file coding system detection logic is
1386- ;; applied. Functions like
1387- ;; `find-operation-coding-system' and
1388- ;; `find-file-name-handler' are not a complete
1389- ;; replacement since they don't look at the contents
1390- ;; at all.
1391- (let ((temp-file (concat temp-dir "/" corresponding-file)))
1392- (make-directory (file-name-directory temp-file) t)
1393- (with-temp-file temp-file
1394- (xmtn--set-buffer-multibyte nil)
1395- (setq buffer-file-coding-system 'binary)
1396- (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
1397- (let ((output-buffer (current-buffer)))
1398- (with-temp-buffer
1399- (insert-file-contents temp-file)
1400- (let ((input-buffer (current-buffer)))
1401- (with-current-buffer output-buffer
1402- (insert-buffer-substring input-buffer)))))))
1403- (when temp-dir
1404- (dvc-delete-recursively temp-dir)))))))))
1405+ (let* ((normalized-file (xmtn--normalize-file-name root file))
1406+ (corresponding-file
1407+ (xmtn--get-corresponding-path root normalized-file
1408+ `(local-tree ,root) backend-id)))
1409+ (if (null corresponding-file)
1410+ ;; File doesn't exist. Since this function is (as far
1411+ ;; as I know) only called from diff-like functions, a
1412+ ;; missing file is not an error but just means the diff
1413+ ;; should be computed against an empty file. So just
1414+ ;; leave the buffer empty.
1415+ (progn)
1416+ (let ((temp-dir nil))
1417+ (unwind-protect
1418+ (progn
1419+ (setq temp-dir (make-temp-file
1420+ "xmtn--revision-get-file-" t))
1421+ ;; Going through a temporary file and using
1422+ ;; `insert-file-contents' in conjunction with as
1423+ ;; much of the original file name as possible seems
1424+ ;; to be the best way to make sure that Emacs'
1425+ ;; entire file coding system detection logic is
1426+ ;; applied. Functions like
1427+ ;; `find-operation-coding-system' and
1428+ ;; `find-file-name-handler' are not a complete
1429+ ;; replacement since they don't look at the contents
1430+ ;; at all.
1431+ (let ((temp-file (concat temp-dir "/" corresponding-file)))
1432+ (make-directory (file-name-directory temp-file) t)
1433+ (with-temp-file temp-file
1434+ (set-buffer-multibyte nil)
1435+ (setq buffer-file-coding-system 'binary)
1436+ (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
1437+ (let ((output-buffer (current-buffer)))
1438+ (with-temp-buffer
1439+ (insert-file-contents temp-file)
1440+ (let ((input-buffer (current-buffer)))
1441+ (with-current-buffer output-buffer
1442+ (insert-buffer-substring input-buffer)))))))
1443+ (when temp-dir
1444+ (dvc-delete-recursively temp-dir))))))))
1445
1446 (defun xmtn--get-file-by-id (root file-id save-as)
1447 "Store contents of FILE-ID in file SAVE-AS."
1448- (xmtn-automate-with-session
1449- (nil root)
1450- (with-temp-file save-as
1451- (xmtn--set-buffer-multibyte nil)
1452- (setq buffer-file-coding-system 'binary)
1453- (xmtn--insert-file-contents root file-id (current-buffer)))))
1454+ (with-temp-file save-as
1455+ (set-buffer-multibyte nil)
1456+ (setq buffer-file-coding-system 'binary)
1457+ (xmtn--insert-file-contents root file-id (current-buffer))))
1458
1459 (defun xmtn--revision-parents (root revision-hash-id)
1460 (xmtn-automate-simple-command-output-lines root
1461 `("parents" ,revision-hash-id)))
1462
1463 (defun xmtn--get-content-changed (root backend-id normalized-file)
1464- (xmtn-automate-with-session (nil root)
1465- (xmtn-match (xmtn--resolve-backend-id root backend-id)
1466- ((local-tree $path) (error "Not implemented"))
1467- ((revision $revision-hash-id)
1468- (xmtn--with-automate-command-output-basic-io-parser
1469- (parser root `("get_content_changed" ,revision-hash-id
1470- ,normalized-file))
1471- (loop for stanza = (funcall parser)
1472- while stanza
1473- collect (xmtn-match stanza
1474- ((("content_mark" (id $previous-id)))
1475- previous-id))))))))
1476+ (xmtn-match (xmtn--resolve-backend-id root backend-id)
1477+ ((local-tree $path) (error "Not implemented"))
1478+ ((revision $revision-hash-id)
1479+ (xmtn--with-automate-command-output-basic-io-parser
1480+ (parser root `("get_content_changed" ,revision-hash-id
1481+ ,normalized-file))
1482+ (loop for stanza = (funcall parser)
1483+ while stanza
1484+ collect (xmtn-match stanza
1485+ ((("content_mark" (id $previous-id)))
1486+ previous-id)))))))
1487
1488 (defun xmtn--limit-length (list n)
1489 (or (null n) (<= (length list) n)))
1490@@ -1499,39 +1309,37 @@
1491 current-set))
1492
1493 (defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n)
1494- (xmtn-automate-with-session (nil root)
1495- (lexical-let ((root root))
1496- (labels ((changed-self-or-ancestors (entry)
1497- (destructuring-bind (hash-id file-name) entry
1498- (check-type file-name string)
1499- ;; get-content-changed can return one or two revisions
1500- (loop for next-change-id in (xmtn--get-content-changed
1501- root `(revision ,hash-id)
1502- file-name)
1503- for corresponding-path =
1504- (xmtn--get-corresponding-path-raw root file-name
1505- hash-id next-change-id)
1506- when corresponding-path
1507- collect `(,next-change-id ,corresponding-path))))
1508- (changed-proper-ancestors (entry)
1509- (destructuring-bind (hash-id file-name) entry
1510- (check-type file-name string)
1511- ;; revision-parents can return one or two revisions
1512- (loop for parent-id in (xmtn--revision-parents root hash-id)
1513- for path-in-parent =
1514- (xmtn--get-corresponding-path-raw root file-name
1515- hash-id parent-id)
1516- when path-in-parent
1517- append (changed-self-or-ancestors
1518- `(,parent-id ,path-in-parent))))))
1519- (xmtn--close-set
1520- #'changed-proper-ancestors
1521- (xmtn-match (xmtn--resolve-backend-id root backend-id)
1522- ((local-tree $path) (error "Not implemented"))
1523- ((revision $id) (changed-self-or-ancestors
1524- `(,id ,normalized-file))))
1525- last-n)))))
1526-
1527+ (lexical-let ((root root))
1528+ (labels ((changed-self-or-ancestors (entry)
1529+ (destructuring-bind (hash-id file-name) entry
1530+ (check-type file-name string)
1531+ ;; get-content-changed can return one or two revisions
1532+ (loop for next-change-id in (xmtn--get-content-changed
1533+ root `(revision ,hash-id)
1534+ file-name)
1535+ for corresponding-path =
1536+ (xmtn--get-corresponding-path-raw root file-name
1537+ hash-id next-change-id)
1538+ when corresponding-path
1539+ collect `(,next-change-id ,corresponding-path))))
1540+ (changed-proper-ancestors (entry)
1541+ (destructuring-bind (hash-id file-name) entry
1542+ (check-type file-name string)
1543+ ;; revision-parents can return one or two revisions
1544+ (loop for parent-id in (xmtn--revision-parents root hash-id)
1545+ for path-in-parent =
1546+ (xmtn--get-corresponding-path-raw root file-name
1547+ hash-id parent-id)
1548+ when path-in-parent
1549+ append (changed-self-or-ancestors
1550+ `(,parent-id ,path-in-parent))))))
1551+ (xmtn--close-set
1552+ #'changed-proper-ancestors
1553+ (xmtn-match (xmtn--resolve-backend-id root backend-id)
1554+ ((local-tree $path) (error "Not implemented"))
1555+ ((revision $id) (changed-self-or-ancestors
1556+ `(,id ,normalized-file))))
1557+ last-n))))
1558
1559 (defun xmtn--get-corresponding-path-raw (root normalized-file-name
1560 source-revision-hash-id
1561@@ -1553,53 +1361,52 @@
1562 source-revision-backend-id
1563 target-revision-backend-id)
1564 (block get-corresponding-path
1565- (xmtn-automate-with-session (nil root)
1566- (let (source-revision-hash-id
1567- target-revision-hash-id
1568- (file-name-postprocessor #'identity))
1569- (let ((resolved-source-revision
1570- (xmtn--resolve-backend-id root source-revision-backend-id))
1571- (resolved-target-revision
1572- (xmtn--resolve-backend-id root target-revision-backend-id)))
1573- (xmtn-match resolved-source-revision
1574- ((revision $hash-id)
1575- (setq source-revision-hash-id hash-id))
1576- ((local-tree $path)
1577- (assert (xmtn--same-tree-p root path))
1578- (let ((base-revision-hash-id
1579- (xmtn--get-base-revision-hash-id-or-null path)))
1580- (if (null base-revision-hash-id)
1581- (xmtn-match resolved-target-revision
1582- ((revision $hash-id)
1583- (return-from get-corresponding-path nil))
1584- ((local-tree $target-path)
1585- (assert (xmtn--same-tree-p path target-path))
1586- (return-from get-corresponding-path normalized-file-name)))
1587- (setq normalized-file-name (xmtn--get-rename-in-workspace-to
1588- path normalized-file-name))
1589- (setq source-revision-hash-id base-revision-hash-id)))))
1590- (xmtn-match resolved-target-revision
1591- ((revision $hash-id)
1592- (setq target-revision-hash-id hash-id))
1593- ((local-tree $path)
1594- (assert (xmtn--same-tree-p root path))
1595- (let ((base-revision-hash-id
1596- (xmtn--get-base-revision-hash-id-or-null path)))
1597- (if (null base-revision-hash-id)
1598- (return-from get-corresponding-path nil)
1599- (setq target-revision-hash-id base-revision-hash-id
1600- file-name-postprocessor
1601- (lexical-let ((path path))
1602- (lambda (file-name)
1603- (xmtn--get-rename-in-workspace-from path
1604- file-name)))))))))
1605- (let ((result
1606- (xmtn--get-corresponding-path-raw root normalized-file-name
1607- source-revision-hash-id
1608- target-revision-hash-id)))
1609- (if (null result)
1610- nil
1611- (funcall file-name-postprocessor result)))))))
1612+ (let (source-revision-hash-id
1613+ target-revision-hash-id
1614+ (file-name-postprocessor #'identity))
1615+ (let ((resolved-source-revision
1616+ (xmtn--resolve-backend-id root source-revision-backend-id))
1617+ (resolved-target-revision
1618+ (xmtn--resolve-backend-id root target-revision-backend-id)))
1619+ (xmtn-match resolved-source-revision
1620+ ((revision $hash-id)
1621+ (setq source-revision-hash-id hash-id))
1622+ ((local-tree $path)
1623+ (assert (xmtn--same-tree-p root path))
1624+ (let ((base-revision-hash-id
1625+ (xmtn--get-base-revision-hash-id-or-null path)))
1626+ (if (null base-revision-hash-id)
1627+ (xmtn-match resolved-target-revision
1628+ ((revision $hash-id)
1629+ (return-from get-corresponding-path nil))
1630+ ((local-tree $target-path)
1631+ (assert (xmtn--same-tree-p path target-path))
1632+ (return-from get-corresponding-path normalized-file-name)))
1633+ (setq normalized-file-name (xmtn--get-rename-in-workspace-to
1634+ path normalized-file-name))
1635+ (setq source-revision-hash-id base-revision-hash-id)))))
1636+ (xmtn-match resolved-target-revision
1637+ ((revision $hash-id)
1638+ (setq target-revision-hash-id hash-id))
1639+ ((local-tree $path)
1640+ (assert (xmtn--same-tree-p root path))
1641+ (let ((base-revision-hash-id
1642+ (xmtn--get-base-revision-hash-id-or-null path)))
1643+ (if (null base-revision-hash-id)
1644+ (return-from get-corresponding-path nil)
1645+ (setq target-revision-hash-id base-revision-hash-id
1646+ file-name-postprocessor
1647+ (lexical-let ((path path))
1648+ (lambda (file-name)
1649+ (xmtn--get-rename-in-workspace-from path
1650+ file-name)))))))))
1651+ (let ((result
1652+ (xmtn--get-corresponding-path-raw root normalized-file-name
1653+ source-revision-hash-id
1654+ target-revision-hash-id)))
1655+ (if (null result)
1656+ nil
1657+ (funcall file-name-postprocessor result))))))
1658
1659 (defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)
1660 ;; FIXME: need a better way to implement this
1661@@ -1632,25 +1439,6 @@
1662 old-path)))))
1663 normalized-target-file-name))
1664
1665-(defun xmtn--manifest-find-file (root manifest normalized-file-name)
1666- (let ((matches (remove* normalized-file-name
1667- (remove* 'file manifest :key #'first :test-not #'equal)
1668- :key #'second :test-not #'equal)))
1669- (xmtn--assert-optional (member (length matches) '(0 1)))
1670- (first matches)))
1671-
1672-(defun xmtn--revision-manifest-file-entry (root backend-id
1673- normalized-file-name)
1674- (let ((manifest (xmtn--get-manifest root backend-id)))
1675- (xmtn--manifest-find-file root manifest normalized-file-name)))
1676-
1677-(defun xmtn--revision-file-contents-hash (root backend-id normalized-file-name)
1678- (xmtn-match (xmtn--revision-manifest-file-entry root backend-id
1679- normalized-file-name)
1680- ((file $relative-path $file-contents-hash $attrs)
1681- (assert (equal relative-path normalized-file-name))
1682- file-contents-hash)))
1683-
1684 (defun xmtn--file-contents-as-string (root content-hash-id)
1685 (check-type content-hash-id xmtn--hash-id)
1686 (xmtn-automate-simple-command-output-string
1687@@ -1674,51 +1462,6 @@
1688 (defun xmtn--same-tree-p (a b)
1689 (equal (file-truename a) (file-truename b)))
1690
1691-(defun xmtn--get-manifest (root backend-id)
1692- (xmtn-automate-with-session (nil root)
1693- (let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
1694- (xmtn--with-automate-command-output-basic-io-parser
1695- (parser root `("get_manifest_of"
1696- ,@(xmtn-match resolved-id
1697- ((local-tree $path)
1698- ;; FIXME: I don't really know what to do if
1699- ;; PATH is not the same as ROOT. Maybe
1700- ;; revision id resolution needs to return
1701- ;; the proper root, too.
1702- (assert (xmtn--same-tree-p root path))
1703- (unless (funcall
1704- (xmtn--tree-consistent-p-future root))
1705- (error "Tree is inconsistent, unable to get manifest"))
1706- '())
1707- ((revision $hash-id)
1708- `(,hash-id)))))
1709- (assert (equal (funcall parser) '(("format_version" (string "1")))))
1710- (loop for stanza = (funcall parser)
1711- while stanza
1712- collect (xmtn-match stanza
1713- ((("dir" (string $normalized-path)))
1714- (let ((dir (decode-coding-string
1715- normalized-path
1716- 'xmtn--monotone-normal-form)))
1717- (xmtn--assert-optional
1718- (or (equal dir "")
1719- (not (eql (aref dir (1- (length dir))) ?/))))
1720- `(dir ,dir)))
1721- ((("file" (string $normalized-path))
1722- ("content" (id $hash-id))
1723- . $attrs)
1724- `(file
1725- ,(decode-coding-string
1726- normalized-path 'xmtn--monotone-normal-form)
1727- ,hash-id
1728- ,(mapcar (lambda (attr-entry)
1729- (xmtn-match attr-entry
1730- (("attr"
1731- (string $attr-name)
1732- (string $attr-value))
1733- (list attr-name attr-value))))
1734- attrs)))))))))
1735-
1736 (defstruct (xmtn--revision (:constructor xmtn--make-revision))
1737 ;; matches data output by 'mtn diff'
1738 new-manifest-hash-id
1739@@ -1732,35 +1475,6 @@
1740 set-attr
1741 )
1742
1743-
1744-(defun xmtn--get-revision (root backend-id)
1745- (xmtn-automate-with-session (nil root)
1746- (let ((resolved-id (xmtn--resolve-backend-id root backend-id)))
1747- (xmtn--with-automate-command-output-basic-io-parser
1748- (parser root `("get_revision"
1749- ,@(xmtn-match resolved-id
1750- ((local-tree $path)
1751- ;; FIXME: I don't really know what to do if
1752- ;; PATH is not the same as ROOT. Maybe
1753- ;; revision id resolution needs to return
1754- ;; the proper root, too.
1755- (assert (xmtn--same-tree-p root path))
1756- (unless (funcall
1757- (xmtn--tree-consistent-p-future root))
1758- (error (concat "Tree is inconsistent,"
1759- " unable to compute revision")))
1760- '())
1761- ((revision $hash-id)
1762- `(,hash-id)))))
1763- (assert (equal (funcall parser) '(("format_version" (string "1")))))
1764- (let ((new-manifest-hash-id (xmtn-match (funcall parser)
1765- ((("new_manifest" (id $hash-id)))
1766- hash-id))))
1767- (let ((proto-revision (xmtn--parse-partial-revision parser)))
1768- (setf (xmtn--revision-new-manifest-hash-id proto-revision)
1769- new-manifest-hash-id)
1770- proto-revision))))))
1771-
1772 (defun xmtn--parse-partial-revision (parser)
1773 "Parse basic_io output from get_revision, starting with the old_revision stanzas."
1774 (let ((old-revision-hash-ids (list))
1775
1776=== modified file 'lisp/xmtn-ids.el'
1777--- lisp/xmtn-ids.el 2009-10-03 12:39:58 +0000
1778+++ lisp/xmtn-ids.el 2010-02-25 22:31:14 +0000
1779@@ -217,21 +217,22 @@
1780 (defun xmtn--branches-of (hash-id)
1781 "Return list of branch names for HASH-ID. `default-directory'
1782 must be a workspace."
1783- (let (result)
1784- (xmtn-automate-with-session (session default-directory)
1785- (xmtn-automate-with-command (handle session `("certs" ,hash-id))
1786- (xmtn-automate-command-wait-until-finished handle)
1787- (with-current-buffer (xmtn-automate-command-buffer handle)
1788- ;; now in buffer containing basic_io certs; find the branch certs
1789- (goto-char (point-min))
1790- (while (not (xmtn-basic-io-eof))
1791- (xmtn-basic-io-optional-line "name"
1792- (if (and (eq 'string (caar value))
1793- (string= "branch" (cadar value)))
1794- (xmtn-basic-io-parse-line
1795- (if (string= symbol "value")
1796- (add-to-list 'result (cadar value)))))
1797- )))))
1798+ (let* (result
1799+ (session (xmtn-automate-cache-session default-directory))
1800+ (handle (xmtn-automate--new-command session `("certs" ,hash-id) nil)))
1801+ (xmtn-automate-command-wait-until-finished handle)
1802+ (with-current-buffer (xmtn-automate-command-buffer handle)
1803+ ;; now in buffer containing basic_io certs; find the branch certs
1804+ (goto-char (point-min))
1805+ (while (not (xmtn-basic-io-eof))
1806+ (xmtn-basic-io-optional-line "name"
1807+ (if (and (eq 'string (caar value))
1808+ (string= "branch" (cadar value)))
1809+ (xmtn-basic-io-parse-line
1810+ (if (string= symbol "value")
1811+ (add-to-list 'result (cadar value)))))
1812+ )))
1813+ (xmtn-automate--cleanup-command handle)
1814 result))
1815
1816 (defun xmtn--get-base-revision-hash-id-or-null (root)
1817
1818=== added file 'lisp/xmtn-multi-status.el'
1819--- lisp/xmtn-multi-status.el 1970-01-01 00:00:00 +0000
1820+++ lisp/xmtn-multi-status.el 2010-02-25 22:31:14 +0000
1821@@ -0,0 +1,450 @@
1822+;;; xmtn-status.el --- manage actions for multiple projects
1823+
1824+;; Copyright (C) 2009 Stephen Leake
1825+
1826+;; Author: Stephen Leake
1827+;; Keywords: tools
1828+
1829+;; This file is free software; you can redistribute it and/or modify
1830+;; it under the terms of the GNU General Public License as published by
1831+;; the Free Software Foundation; either version 2 of the License, or
1832+;; (at your option) any later version.
1833+;;
1834+;; This file is distributed in the hope that it will be useful,
1835+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
1836+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1837+;; GNU General Public License for more details.
1838+;;
1839+;; You should have received a copy of the GNU General Public License
1840+;; along with this file; see the file COPYING. If not, write to
1841+;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
1842+;; Boston, MA 02110-1301 USA.
1843+
1844+(eval-and-compile
1845+ ;; these have macros we use
1846+ (require 'xmtn-ids))
1847+
1848+(eval-when-compile
1849+ ;; these have functions we use
1850+ (require 'xmtn-base)
1851+ (require 'xmtn-conflicts))
1852+
1853+(defvar xmtn-status-root ""
1854+ "Buffer-local variable holding root directory.")
1855+(make-variable-buffer-local 'xmtn-status-root)
1856+(put 'xmtn-status-root 'permanent-local t)
1857+
1858+(defvar xmtn-status-ewoc nil
1859+ "Buffer-local ewoc for displaying propagations.
1860+All xmtn-status functions operate on this ewoc.
1861+The elements must all be of class xmtn-status-data.")
1862+(make-variable-buffer-local 'xmtn-status-ewoc)
1863+(put 'xmtn-status-ewoc 'permanent-local t)
1864+
1865+(defstruct (xmtn-status-data (:copier nil))
1866+ work ; directory name relative to xmtn-status-root
1867+ branch ; branch name (assumed never changes)
1868+ need-refresh ; nil | t : if an async process was started that invalidates state data
1869+ head-rev ; nil | mtn rev string : current head revision, nil if multiple heads
1870+ conflicts-buffer ; *xmtn-conflicts* buffer for merge
1871+ heads ; 'need-scan | 'at-head | 'need-update | 'need-merge)
1872+ (local-changes
1873+ 'need-scan) ; 'need-scan | 'need-commit | 'ok
1874+ (conflicts
1875+ 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none
1876+ )
1877+
1878+(defun xmtn-status-work (data)
1879+ (concat xmtn-status-root (xmtn-status-data-work data)))
1880+
1881+(defun xmtn-status-need-refresh (elem data)
1882+ ;; The user has selected an action that will change the state of the
1883+ ;; workspace via mtn actions; set our data to reflect that. We
1884+ ;; assume the user will not be creating new files or editing
1885+ ;; existing ones.
1886+ (setf (xmtn-status-data-need-refresh data) t)
1887+ (setf (xmtn-status-data-heads data) 'need-scan)
1888+ (setf (xmtn-status-data-conflicts data) 'need-scan)
1889+ (ewoc-invalidate xmtn-status-ewoc elem))
1890+
1891+(defun xmtn-status-printer (data)
1892+ "Print an ewoc element."
1893+ (insert (dvc-face-add (format "%s\n" (xmtn-status-data-work data)) 'dvc-keyword))
1894+
1895+ (if (xmtn-status-data-need-refresh data)
1896+ (insert (dvc-face-add " need refresh\n" 'dvc-conflict))
1897+
1898+ (ecase (xmtn-status-data-local-changes data)
1899+ (need-scan (insert " from local changes unknown\n"))
1900+ (need-commit (insert (dvc-face-add " need dvc-status\n" 'dvc-header)))
1901+ (ok nil))
1902+
1903+ (ecase (xmtn-status-data-conflicts data)
1904+ (need-scan
1905+ (insert "conflicts need scan\n"))
1906+ (need-resolve
1907+ (insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict)))
1908+ (need-review-resolve-internal
1909+ (insert (dvc-face-add " need review resolve internal\n" 'dvc-header)))
1910+ (resolved
1911+ (insert " conflicts resolved\n"))
1912+ ((resolved none) nil))
1913+
1914+ (ecase (xmtn-status-data-heads data)
1915+ (at-head nil)
1916+ (need-update (insert (dvc-face-add " need update\n" 'dvc-conflict)))
1917+ (need-merge
1918+ (insert (dvc-face-add " need merge\n" 'dvc-conflict)))
1919+ )))
1920+
1921+(defun xmtn-status-kill-conflicts-buffer (data)
1922+ (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
1923+ (let ((buffer (xmtn-status-data-conflicts-buffer data)))
1924+ (with-current-buffer buffer (save-buffer))
1925+ (kill-buffer buffer))))
1926+
1927+(defun xmtn-status-save-conflicts-buffer (data)
1928+ (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
1929+ (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer))))
1930+
1931+(defun xmtn-status-clean ()
1932+ "Clean current workspace, delete from ewoc"
1933+ (interactive)
1934+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
1935+ (data (ewoc-data elem))
1936+ (inhibit-read-only t))
1937+ (xmtn-status-kill-conflicts-buffer data)
1938+ (xmtn-conflicts-clean (xmtn-status-work data))
1939+ (ewoc-delete xmtn-status-ewoc elem)))
1940+
1941+(defun xmtn-status-cleanp ()
1942+ "Non-nil if clean & quit is appropriate for current workspace."
1943+ (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
1944+ ;; don't check need-refresh here; allow deleting after just doing
1945+ ;; final required action in another buffer.
1946+ (and (member (xmtn-status-data-local-changes data) '(need-scan ok))
1947+ (member (xmtn-status-data-heads data) '(need-scan at-head)))))
1948+
1949+(defun xmtn-status-do-refresh-one ()
1950+ (interactive)
1951+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
1952+ (data (ewoc-data elem)))
1953+ (xmtn-status-refresh-one data current-prefix-arg)
1954+ (ewoc-invalidate xmtn-status-ewoc elem)))
1955+
1956+(defun xmtn-status-refreshp ()
1957+ "Non-nil if refresh is appropriate for current workspace."
1958+ (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
1959+ (or (xmtn-status-data-need-refresh data)
1960+ ;; everything's done, but the user just did mtn sync, and more
1961+ ;; stuff showed up
1962+ (eq 'ok (xmtn-status-data-local-changes data))
1963+ (eq 'at-head (xmtn-status-data-heads data)))))
1964+
1965+(defun xmtn-status-update ()
1966+ "Update current workspace."
1967+ (interactive)
1968+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
1969+ (data (ewoc-data elem)))
1970+ (xmtn-status-need-refresh elem data)
1971+ (let ((default-directory (xmtn-status-work data)))
1972+ (xmtn-dvc-update))
1973+ (xmtn-status-refresh-one data nil)
1974+ (ewoc-invalidate xmtn-status-ewoc elem)))
1975+
1976+(defun xmtn-status-updatep ()
1977+ "Non-nil if update is appropriate for current workspace."
1978+ (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
1979+ (and (not (xmtn-status-data-need-refresh data))
1980+ (eq 'need-update (xmtn-status-data-heads data)))))
1981+
1982+(defun xmtn-status-resolve-conflicts ()
1983+ "Resolve conflicts for current workspace."
1984+ (interactive)
1985+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
1986+ (data (ewoc-data elem)))
1987+ (xmtn-status-need-refresh elem data)
1988+ (setf (xmtn-status-data-conflicts data) 'resolved)
1989+ (pop-to-buffer (xmtn-status-data-conflicts-buffer data))))
1990+
1991+(defun xmtn-status-resolve-conflictsp ()
1992+ "Non-nil if resolve conflicts is appropriate for current workspace."
1993+ (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
1994+ (and (not (xmtn-status-data-need-refresh data))
1995+ (member (xmtn-status-data-conflicts data)
1996+ '(need-resolve need-review-resolve-internal)))))
1997+
1998+(defun xmtn-status-status ()
1999+ "Run xmtn-status on current workspace."
2000+ (interactive)
2001+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
2002+ (data (ewoc-data elem)))
2003+ (xmtn-status-need-refresh elem data)
2004+ (setf (xmtn-status-data-local-changes data) 'ok)
2005+ (xmtn-status (xmtn-status-work data))))
2006+
2007+(defun xmtn-status-status-ok ()
2008+ "Ignore local changes in current workspace."
2009+ (interactive)
2010+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
2011+ (data (ewoc-data elem)))
2012+ (setf (xmtn-status-data-local-changes data) 'ok)
2013+
2014+ (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
2015+ ;; creating the log-edit buffer requires a single status/diff/conflicts buffer
2016+ (kill-buffer (xmtn-status-data-conflicts-buffer data)))
2017+
2018+ (ewoc-invalidate xmtn-status-ewoc elem)))
2019+
2020+(defun xmtn-status-statusp ()
2021+ "Non-nil if xmtn-status is appropriate for current workspace."
2022+ (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
2023+ (and (not (xmtn-status-data-need-refresh data))
2024+ (member (xmtn-status-data-local-changes data)
2025+ '(need-scan need-commit)))))
2026+
2027+(defun xmtn-status-missing ()
2028+ "Run xmtn-missing on current workspace."
2029+ (interactive)
2030+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
2031+ (data (ewoc-data elem)))
2032+ (xmtn-status-need-refresh elem data)
2033+ (xmtn-missing nil (xmtn-status-work data))))
2034+
2035+(defun xmtn-status-missingp ()
2036+ "Non-nil if xmtn-missing is appropriate for current workspace."
2037+ (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
2038+ (and (not (xmtn-status-data-need-refresh data))
2039+ (eq 'need-update (xmtn-status-data-heads data)))))
2040+
2041+(defun xmtn-status-merge ()
2042+ "Run dvc-merge on current workspace."
2043+ (interactive)
2044+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
2045+ (data (ewoc-data elem))
2046+ (default-directory (xmtn-status-work data)))
2047+ (xmtn-status-need-refresh elem data)
2048+ (xmtn-status-save-conflicts-buffer data)
2049+ (xmtn-dvc-merge-1 default-directory nil)))
2050+
2051+(defun xmtn-status-heads ()
2052+ "Run xmtn-heads on current workspace."
2053+ (interactive)
2054+ (let* ((elem (ewoc-locate xmtn-status-ewoc))
2055+ (data (ewoc-data elem))
2056+ (default-directory (xmtn-status-work data)))
2057+ (xmtn-status-need-refresh elem data)
2058+ (xmtn-view-heads-revlist)))
2059+
2060+(defun xmtn-status-headsp ()
2061+ "Non-nil if xmtn-heads is appropriate for current workspace."
2062+ (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
2063+ (and (not (xmtn-status-data-need-refresh data))
2064+ (eq 'need-merge (xmtn-status-data-heads data)))))
2065+
2066+(defvar xmtn-status-actions-map
2067+ (let ((map (make-sparse-keymap "actions")))
2068+ (define-key map [?c] '(menu-item "c) clean/delete"
2069+ xmtn-status-clean
2070+ :visible (xmtn-status-cleanp)))
2071+ (define-key map [?g] '(menu-item "g) refresh"
2072+ xmtn-status-do-refresh-one
2073+ :visible (xmtn-status-refreshp)))
2074+ (define-key map [?i] '(menu-item "i) ignore local changes"
2075+ xmtn-status-status-ok
2076+ :visible (xmtn-status-statusp)))
2077+ (define-key map [?5] '(menu-item "5) update"
2078+ xmtn-status-update
2079+ :visible (xmtn-status-updatep)))
2080+ (define-key map [?4] '(menu-item "4) xmtn-merge"
2081+ xmtn-status-merge
2082+ :visible (xmtn-status-headsp)))
2083+ (define-key map [?3] '(menu-item "3) xmtn-heads"
2084+ xmtn-status-heads
2085+ :visible (xmtn-status-headsp)))
2086+ (define-key map [?2] '(menu-item "2) resolve conflicts"
2087+ xmtn-status-resolve-conflicts
2088+ :visible (xmtn-status-resolve-conflictsp)))
2089+ (define-key map [?1] '(menu-item "1) dvc-missing"
2090+ xmtn-status-missing
2091+ :visible (xmtn-status-missingp)))
2092+ (define-key map [?0] '(menu-item "0) status"
2093+ xmtn-status-status
2094+ :visible (xmtn-status-statusp)))
2095+ map)
2096+ "Keyboard menu keymap used in multiple-status mode.")
2097+
2098+(dvc-make-ewoc-next xmtn-status-next xmtn-status-ewoc)
2099+(dvc-make-ewoc-prev xmtn-status-prev xmtn-status-ewoc)
2100+
2101+(defvar xmtn-multiple-status-mode-map
2102+ (let ((map (make-sparse-keymap)))
2103+ (define-key map "\M-d" xmtn-status-actions-map)
2104+ (define-key map [?g] 'xmtn-status-refresh)
2105+ (define-key map [?n] 'xmtn-status-next)
2106+ (define-key map [?p] 'xmtn-status-prev)
2107+ (define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer))))
2108+ map)
2109+ "Keymap used in `xmtn-multiple-status-mode'.")
2110+
2111+(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status"
2112+ "Major mode to show status of multiple workspaces."
2113+ (setq dvc-buffer-current-active-dvc 'xmtn)
2114+ (setq buffer-read-only nil)
2115+
2116+ ;; don't do normal clean up stuff
2117+ (set (make-local-variable 'before-save-hook) nil)
2118+ (set (make-local-variable 'write-file-functions) nil)
2119+
2120+ (dvc-install-buffer-menu)
2121+ (setq buffer-read-only t)
2122+ (buffer-disable-undo)
2123+
2124+ (set-buffer-modified-p nil))
2125+
2126+(defun xmtn-status-conflicts (data)
2127+ "Return value for xmtn-status-data-conflicts for DATA."
2128+ ;; Can't check for "current heads", since there could be more than
2129+ ;; 2, so just recreate conflicts
2130+ (let* ((work (xmtn-status-work data))
2131+ (default-directory work))
2132+
2133+ (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
2134+ (kill-buffer (xmtn-status-data-conflicts-buffer data)))
2135+
2136+ ;; create conflicts file
2137+ (xmtn-conflicts-clean work)
2138+ (xmtn-conflicts-save-opts work work (xmtn-status-data-branch data) (xmtn-status-data-branch data))
2139+ (dvc-run-dvc-sync
2140+ 'xmtn
2141+ (list "conflicts" "store")
2142+ :error (lambda (output error status arguments)
2143+ (pop-to-buffer error)))
2144+
2145+ ;; create conflicts buffer
2146+ (setf (xmtn-status-data-conflicts-buffer data)
2147+ (save-excursion
2148+ (let ((dvc-switch-to-buffer-first nil))
2149+ (xmtn-conflicts-review work)
2150+ (current-buffer))))
2151+
2152+ (with-current-buffer (xmtn-status-data-conflicts-buffer data)
2153+ (case xmtn-conflicts-total-count
2154+ (0 'none)
2155+ (t
2156+ (if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-internal-count)
2157+ 'need-review-resolve-internal
2158+ 'need-resolve))))))
2159+
2160+(defun xmtn-status-refresh-one (data refresh-local-changes)
2161+ "Refresh DATA."
2162+ (let ((work (xmtn-status-work data)))
2163+
2164+ (message "checking heads for %s " work)
2165+
2166+ (let ((heads (xmtn--heads work (xmtn-status-data-branch data)))
2167+ (base-rev (xmtn--get-base-revision-hash-id-or-null work)))
2168+ (case (length heads)
2169+ (1
2170+ (setf (xmtn-status-data-head-rev data) (nth 0 heads))
2171+ (setf (xmtn-status-data-conflicts data) 'none)
2172+ (if (string= (xmtn-status-data-head-rev data) base-rev)
2173+ (setf (xmtn-status-data-heads data) 'at-head)
2174+ (setf (xmtn-status-data-heads data) 'need-update)))
2175+ (t
2176+ (setf (xmtn-status-data-head-rev data) nil)
2177+ (setf (xmtn-status-data-heads data) 'need-merge)
2178+ (case (xmtn-status-data-conflicts data)
2179+ (resolved
2180+ ;; Assume the resolution was just completed, so don't erase it!
2181+ nil)
2182+ (t
2183+ (setf (xmtn-status-data-conflicts data) 'need-scan))))))
2184+
2185+ (message "")
2186+
2187+ (if refresh-local-changes
2188+ (setf (xmtn-status-data-local-changes data) 'need-scan))
2189+
2190+ (case (xmtn-status-data-local-changes data)
2191+ (need-scan
2192+ (setf (xmtn-status-data-local-changes data) (xmtn-automate-local-changes work)))
2193+ (t nil))
2194+
2195+ (case (xmtn-status-data-conflicts data)
2196+ (need-scan
2197+ (setf (xmtn-status-data-conflicts data)
2198+ (xmtn-status-conflicts data)))
2199+ (t nil))
2200+
2201+ (setf (xmtn-status-data-need-refresh data) nil))
2202+
2203+ ;; return non-nil to refresh display as we go along
2204+ t)
2205+
2206+(defun xmtn-status-refresh ()
2207+ "Refresh status of each ewoc element. With prefix arg, reset local changes status to `unknown'."
2208+ (interactive)
2209+ (ewoc-map 'xmtn-status-refresh-one xmtn-status-ewoc current-prefix-arg)
2210+ (message "done"))
2211+
2212+;;;###autoload
2213+(defun xmtn-update-multiple (dir &optional workspaces)
2214+ "Update all projects under DIR."
2215+ (interactive "DUpdate all in (root directory): ")
2216+ (let ((root (file-name-as-directory (substitute-in-file-name dir))))
2217+
2218+ (if (not workspaces) (setq workspaces (xmtn--filter-non-dir root)))
2219+
2220+ (dolist (workspace workspaces)
2221+ (let ((default-directory (concat root workspace)))
2222+ (xmtn-dvc-update nil t)))
2223+ (message "Update %s done" root)))
2224+
2225+;;;###autoload
2226+(defun xmtn-status-multiple (dir &optional workspaces skip-initial-scan)
2227+ "Show actions to update all projects under DIR."
2228+ (interactive "DStatus for all (root directory): \ni\nP")
2229+ (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
2230+ (setq default-directory (file-name-as-directory (substitute-in-file-name dir)))
2231+ (if (not workspaces) (setq workspaces (xmtn--filter-non-dir default-directory)))
2232+ (setq xmtn-status-root (file-name-as-directory default-directory))
2233+ (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
2234+ (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
2235+ (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
2236+ (dolist (workspace workspaces)
2237+ (ewoc-enter-last xmtn-status-ewoc
2238+ (make-xmtn-status-data
2239+ :work workspace
2240+ :branch (xmtn--tree-default-branch (concat xmtn-status-root workspace))
2241+ :need-refresh t
2242+ :heads 'need-scan)))
2243+ (xmtn-multiple-status-mode)
2244+ (when (not skip-initial-scan)
2245+ (progn
2246+ (xmtn-status-refresh)
2247+ (xmtn-status-next))))
2248+
2249+;;;###autoload
2250+(defun xmtn-status-one (work)
2251+ "Show actions to update WORK."
2252+ (interactive "DStatus for (workspace): ")
2253+ (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
2254+ (setq default-directory work)
2255+ (setq xmtn-status-root (expand-file-name (concat (file-name-as-directory work) "../")))
2256+ (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
2257+ (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
2258+ (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
2259+ (ewoc-enter-last xmtn-status-ewoc
2260+ (make-xmtn-status-data
2261+ :work (file-name-nondirectory (directory-file-name work))
2262+ :branch (xmtn--tree-default-branch default-directory)
2263+ :need-refresh t
2264+ :heads 'need-scan))
2265+ (xmtn-multiple-status-mode)
2266+ (xmtn-status-refresh)
2267+ (xmtn-status-next))
2268+
2269+(provide 'xmtn-multi-status)
2270+
2271+;; end of file
2272
2273=== modified file 'lisp/xmtn-propagate.el'
2274--- lisp/xmtn-propagate.el 2009-10-03 12:39:58 +0000
2275+++ lisp/xmtn-propagate.el 2010-02-25 22:31:14 +0000
2276@@ -149,17 +149,21 @@
2277 (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
2278
2279 (if (eq 'at-head (xmtn-propagate-data-to-heads data))
2280- (insert " need clean\n"))
2281+ (insert (dvc-face-add " need clean\n" 'dvc-conflict)))
2282 ))
2283 ;; ewoc ought to do this, but it doesn't
2284 (redisplay))
2285
2286-(defun xmtn-kill-conflicts-buffer (data)
2287+(defun xmtn-propagate-kill-conflicts-buffer (data)
2288 (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
2289 (let ((buffer (xmtn-propagate-data-conflicts-buffer data)))
2290 (with-current-buffer buffer (save-buffer))
2291 (kill-buffer buffer))))
2292
2293+(defun xmtn-propagate-save-conflicts-buffer (data)
2294+ (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
2295+ (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer))))
2296+
2297 (defun xmtn-propagate-clean ()
2298 "Clean current workspace, delete from ewoc"
2299 (interactive)
2300@@ -167,8 +171,8 @@
2301 (data (ewoc-data elem)))
2302
2303 ;; only one conflicts file and buffer
2304+ (xmtn-propagate-kill-conflicts-buffer data)
2305 (xmtn-conflicts-clean (xmtn-propagate-to-work data))
2306- (xmtn-kill-conflicts-buffer data)
2307
2308 (let ((inhibit-read-only t))
2309 (ewoc-delete xmtn-propagate-ewoc elem))))
2310@@ -229,6 +233,12 @@
2311 (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
2312 (data (ewoc-data elem)))
2313 (xmtn-propagate-need-refresh elem data)
2314+
2315+ (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
2316+ ;; user deleted conflicts buffer after resolving conflicts; get it back
2317+ (setf (xmtn-propagate-data-conflicts-buffer data)
2318+ (xmtn-propagate-conflicts-buffer data)))
2319+
2320 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
2321 (let ((xmtn-confirm-operation nil))
2322 (xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data))))
2323@@ -274,7 +284,7 @@
2324 ;; can't create log-edit buffer with both conflicts and status
2325 ;; buffer open, and we'll be killing this as part of the refresh
2326 ;; anyway.
2327- (xmtn-kill-conflicts-buffer data)
2328+ (xmtn-propagate-kill-conflicts-buffer data)
2329
2330 (setf (xmtn-propagate-data-to-local-changes data) 'ok)
2331 (xmtn-status (xmtn-propagate-to-work data))))
2332@@ -452,49 +462,6 @@
2333 (xmtn-propagate-refresh)
2334 (xmtn-propagate-next nil t))
2335
2336-(defun xmtn-propagate-local-changes (work)
2337- "Value for xmtn-propagate-data-local-changes for WORK."
2338- (message "checking %s for local changes" work)
2339- (let ((default-directory work)
2340- result)
2341-
2342- (dvc-run-dvc-sync
2343- 'xmtn
2344- (list "status")
2345- :finished (lambda (output error status arguments)
2346- ;; we don't get an error status for not up-to-date,
2347- ;; so parse the output.
2348- ;; FIXME: add option to automate inventory to just return status; can return on first change
2349- ;; FIXME: 'patch' may be internationalized.
2350-
2351- (message "") ; clear minibuffer
2352- (set-buffer output)
2353- (goto-char (point-min))
2354- (if (search-forward "patch" (point-max) t)
2355- (setq result 'need-commit)
2356- (setq result 'ok)))
2357-
2358- :error (lambda (output error status arguments)
2359- (pop-to-buffer error)))
2360-
2361- (if (eq result 'ok)
2362- ;; check for unknown
2363- (dvc-run-dvc-sync
2364- 'xmtn
2365- (list "ls" "unknown")
2366- :finished (lambda (output error status arguments)
2367- (message "") ; clear minibuffer
2368- (set-buffer output)
2369- (if (not (= (point-min) (point-max)))
2370- (setq result 'need-commit)
2371- (setq result 'ok)))
2372-
2373- :error (lambda (output error status arguments)
2374- (pop-to-buffer error))))
2375-
2376- result)
2377- )
2378-
2379 (defun xmtn-propagate-needed (data)
2380 "t if DATA needs propagate."
2381 (let ((result t)
2382@@ -558,18 +525,24 @@
2383
2384 (defun xmtn-propagate-conflicts (data)
2385 "Return value for xmtn-propagate-data-conflicts for DATA."
2386- ;; if conflicts-buffer is nil, this does the right thing.
2387+
2388+ (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
2389+ ;; user may have deleted conflicts buffer after resolving
2390+ ;; conflicts; don't throw that away.
2391+ (setf (xmtn-propagate-data-conflicts-buffer data)
2392+ (xmtn-propagate-conflicts-buffer data)))
2393+
2394 (let ((revs-current
2395- (and (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
2396- (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
2397- (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)
2398- (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision))))))
2399+ (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
2400+ (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)
2401+ (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))
2402 (if revs-current
2403 (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
2404- (xmtn-conflicts-update-counts))
2405+ (xmtn-conflicts-update-counts)
2406+ (save-buffer))
2407
2408- ;; recreate conflicts
2409- (xmtn-kill-conflicts-buffer data)
2410+ ;; else recreate conflicts
2411+ (xmtn-propagate-kill-conflicts-buffer data)
2412
2413 (xmtn-conflicts-clean (xmtn-propagate-to-work data))
2414
2415@@ -629,19 +602,25 @@
2416 (progn
2417 (ecase (xmtn-propagate-data-from-local-changes data)
2418 ((need-scan need-commit)
2419- (setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work)))
2420+ (setf (xmtn-propagate-data-from-local-changes data) (xmtn-automate-local-changes from-work)))
2421 (ok nil))
2422
2423 (ecase (xmtn-propagate-data-to-local-changes data)
2424 ((need-scan need-commit)
2425- (setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work)))
2426+ (setf (xmtn-propagate-data-to-local-changes data) (xmtn-automate-local-changes to-work)))
2427 (ok nil))))
2428
2429 (if (xmtn-propagate-data-propagate-needed data)
2430- ;; can't compute conflicts if propagate not needed
2431- (setf (xmtn-propagate-data-conflicts data)
2432- (xmtn-propagate-conflicts data))
2433-
2434+ (progn
2435+ (if refresh-local-changes
2436+ (progn
2437+ (xmtn-propagate-kill-conflicts-buffer data)
2438+ (xmtn-conflicts-clean (xmtn-propagate-to-work data))))
2439+
2440+ (setf (xmtn-propagate-data-conflicts data)
2441+ (xmtn-propagate-conflicts data)))
2442+
2443+ ;; can't compute conflicts if propagate not needed
2444 (setf (xmtn-propagate-data-conflicts data) 'need-scan))
2445
2446 (setf (xmtn-propagate-data-need-refresh data) nil))
2447@@ -725,6 +704,8 @@
2448 (from-session (xmtn-automate-cache-session from-work))
2449 (to-session (xmtn-automate-cache-session to-work)))
2450 (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
2451+ ;; default-directory is wrong if buffer is reused
2452+ (setq default-directory to-work)
2453 (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))
2454 (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
2455 (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
2456
2457=== modified file 'lisp/xmtn-revlist.el'
2458--- lisp/xmtn-revlist.el 2009-10-03 12:39:58 +0000
2459+++ lisp/xmtn-revlist.el 2010-02-25 22:31:14 +0000
2460@@ -148,78 +148,77 @@
2461 (assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids))
2462 (ewoc-set-hf ewoc header footer)
2463 (ewoc-filter ewoc (lambda (x) nil)) ; Clear it.
2464- (xmtn-automate-with-session (session root)
2465- (setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
2466- (if last-n
2467- (let ((len (length revision-hash-ids)))
2468- (if (> len last-n)
2469- (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))
2470- (setq revision-hash-ids (coerce revision-hash-ids 'vector))
2471- (xmtn--dotimes-with-progress-reporter (i (length revision-hash-ids))
2472- (case (length revision-hash-ids)
2473- (1 "Setting up revlist buffer (1 revision)...")
2474- (t (format "Setting up revlist buffer (%s revisions)..."
2475- (length revision-hash-ids))))
2476- ;; Maybe also show parents and children? (Could add toggle
2477- ;; commands to show/hide these.)
2478- (lexical-let ((rev (aref revision-hash-ids i))
2479- (branches (list))
2480- (authors (list))
2481- (dates (list))
2482- (changelogs (list))
2483- (tags (list)))
2484- (xmtn--map-parsed-certs
2485- root rev
2486- (lambda (key signature name value trusted)
2487- (declare (ignore key))
2488- (unless (not trusted)
2489- (cond ((equal name "author")
2490- (push value authors))
2491- ((equal name "date")
2492- (push value dates))
2493- ((equal name "changelog")
2494- (push value changelogs))
2495- ((equal name "branch")
2496- (push value branches))
2497- ((equal name "tag")
2498- (push value tags))
2499- (t
2500- (progn))))))
2501- (setq authors (nreverse authors)
2502- dates (nreverse dates)
2503- changelogs (nreverse changelogs)
2504- branches (nreverse branches)
2505- tags (nreverse tags))
2506- (let ((parent-hash-ids
2507- (xmtn-automate-simple-command-output-lines root `("parents"
2508- ,rev)))
2509- (child-hash-ids
2510- (xmtn-automate-simple-command-output-lines root `("children"
2511- ,rev))))
2512- (xmtn--assert-optional (every #'stringp authors))
2513- (xmtn--assert-optional (every #'stringp dates))
2514- (xmtn--assert-optional (every #'stringp changelogs))
2515- (xmtn--assert-optional (every #'stringp branches))
2516- (xmtn--assert-optional (every #'stringp tags))
2517- (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))
2518- (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))
2519- (ewoc-enter-last ewoc
2520- ;; Creating a list `(entry-patch
2521- ;; ,instance-of-dvc-revlist-entry-patch) seems
2522- ;; to be part of DVC's API.
2523- `(entry-patch
2524- ,(make-dvc-revlist-entry-patch
2525- :dvc 'xmtn
2526- :rev-id `(xmtn (revision ,rev))
2527- :struct (xmtn--make-revlist-entry
2528- :revision-hash-id rev
2529- :branches branches
2530- :authors authors
2531- :dates dates
2532- :changelogs changelogs
2533- :tags tags
2534- :parent-hash-ids parent-hash-ids
2535- :child-hash-ids child-hash-ids))))))))
2536+ (setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
2537+ (if last-n
2538+ (let ((len (length revision-hash-ids)))
2539+ (if (> len last-n)
2540+ (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids)))))
2541+ (setq revision-hash-ids (coerce revision-hash-ids 'vector))
2542+ (dotimes-with-progress-reporter (i (length revision-hash-ids))
2543+ (case (length revision-hash-ids)
2544+ (1 "Setting up revlist buffer (1 revision)...")
2545+ (t (format "Setting up revlist buffer (%s revisions)..."
2546+ (length revision-hash-ids))))
2547+ ;; Maybe also show parents and children? (Could add toggle
2548+ ;; commands to show/hide these.)
2549+ (lexical-let ((rev (aref revision-hash-ids i))
2550+ (branches (list))
2551+ (authors (list))
2552+ (dates (list))
2553+ (changelogs (list))
2554+ (tags (list)))
2555+ (xmtn--map-parsed-certs
2556+ root rev
2557+ (lambda (key signature name value trusted)
2558+ (declare (ignore key))
2559+ (unless (not trusted)
2560+ (cond ((equal name "author")
2561+ (push value authors))
2562+ ((equal name "date")
2563+ (push value dates))
2564+ ((equal name "changelog")
2565+ (push value changelogs))
2566+ ((equal name "branch")
2567+ (push value branches))
2568+ ((equal name "tag")
2569+ (push value tags))
2570+ (t
2571+ (progn))))))
2572+ (setq authors (nreverse authors)
2573+ dates (nreverse dates)
2574+ changelogs (nreverse changelogs)
2575+ branches (nreverse branches)
2576+ tags (nreverse tags))
2577+ (let ((parent-hash-ids
2578+ (xmtn-automate-simple-command-output-lines root `("parents"
2579+ ,rev)))
2580+ (child-hash-ids
2581+ (xmtn-automate-simple-command-output-lines root `("children"
2582+ ,rev))))
2583+ (xmtn--assert-optional (every #'stringp authors))
2584+ (xmtn--assert-optional (every #'stringp dates))
2585+ (xmtn--assert-optional (every #'stringp changelogs))
2586+ (xmtn--assert-optional (every #'stringp branches))
2587+ (xmtn--assert-optional (every #'stringp tags))
2588+ (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids))
2589+ (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids))
2590+ (ewoc-enter-last ewoc
2591+ ;; Creating a list `(entry-patch
2592+ ;; ,instance-of-dvc-revlist-entry-patch) seems
2593+ ;; to be part of DVC's API.
2594+ `(entry-patch
2595+ ,(make-dvc-revlist-entry-patch
2596+ :dvc 'xmtn
2597+ :rev-id `(xmtn (revision ,rev))
2598+ :struct (xmtn--make-revlist-entry
2599+ :revision-hash-id rev
2600+ :branches branches
2601+ :authors authors
2602+ :dates dates
2603+ :changelogs changelogs
2604+ :tags tags
2605+ :parent-hash-ids parent-hash-ids
2606+ :child-hash-ids child-hash-ids)))))))
2607 nil)
2608
2609 (defun xmtn-revision-st-message (entry)
2610@@ -257,14 +256,14 @@
2611 (defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n)
2612 ;; Adapted from `dvc-build-revision-list'.
2613 ;; info-generator-fn must return a list of back-end revision ids (strings)
2614- (xmtn-automate-with-session (nil root)
2615- (let ((dvc-temp-current-active-dvc 'xmtn)
2616- (buffer (dvc-revlist-create-buffer
2617- 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))
2618- (with-current-buffer buffer
2619- (setq xmtn--revlist-*info-generator-fn* info-generator-fn)
2620- (xmtn--revlist-refresh))
2621- (xmtn--display-buffer-maybe buffer nil)))
2622+ (xmtn-automate-cache-session root)
2623+ (let ((dvc-temp-current-active-dvc 'xmtn)
2624+ (buffer (dvc-revlist-create-buffer
2625+ 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n)))
2626+ (with-current-buffer buffer
2627+ (setq xmtn--revlist-*info-generator-fn* info-generator-fn)
2628+ (xmtn--revlist-refresh))
2629+ (xmtn--display-buffer-maybe buffer nil))
2630 nil)
2631
2632 ;;;###autoload
2633@@ -293,57 +292,54 @@
2634 (xmtn--setup-revlist
2635 root
2636 (lambda (root)
2637- (xmtn-automate-with-session
2638- (nil root)
2639- (let ((branch (xmtn--tree-default-branch root)))
2640- (list branch
2641- (list
2642- (if dvc-revlist-last-n
2643- (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)
2644- (format "Log for branch %s (all entries):" branch)))
2645- '()
2646- (xmtn--expand-selector
2647- root
2648- ;; This restriction to current branch is completely
2649- ;; arbitrary.
2650- (concat
2651- "b:" ;; returns all revs for current branch
2652- (xmtn--escape-branch-name-for-selector
2653- branch)))))))
2654+ (let ((branch (xmtn--tree-default-branch root)))
2655+ (list branch
2656+ (list
2657+ (if dvc-revlist-last-n
2658+ (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n)
2659+ (format "Log for branch %s (all entries):" branch)))
2660+ '()
2661+ (xmtn--expand-selector
2662+ root
2663+ ;; This restriction to current branch is completely
2664+ ;; arbitrary.
2665+ (concat
2666+ "b:" ;; returns all revs for current branch
2667+ (xmtn--escape-branch-name-for-selector
2668+ branch))))))
2669 first-line-only-p
2670 last-n)))
2671
2672 (defun xmtn--revlist--missing-get-info (root)
2673- (xmtn-automate-with-session (nil root)
2674- (let* ((branch (xmtn--tree-default-branch root))
2675- (heads (xmtn--heads root branch))
2676- (base-revision-hash-id (xmtn--get-base-revision-hash-id root))
2677- (difference
2678- (delete-duplicates
2679- (mapcan
2680- (lambda (head)
2681- (xmtn-automate-simple-command-output-lines
2682- root
2683- `("ancestry_difference"
2684- ,head ,base-revision-hash-id)))
2685- heads))))
2686- (list
2687- branch
2688- `(,(format "Tree %s" root)
2689- ,(format "Branch %s" branch)
2690- ,(format "Base %s" base-revision-hash-id)
2691- ,(case (length heads)
2692- (1 "branch is merged")
2693- (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
2694- nil
2695- ,(case (length difference)
2696- (0 "No revisions that are not in base revision")
2697- (1 "1 revision that is not in base revision:")
2698- (t (format
2699- "%s revisions that are not in base revision:"
2700- (length difference)))))
2701- '()
2702- difference))))
2703+ (let* ((branch (xmtn--tree-default-branch root))
2704+ (heads (xmtn--heads root branch))
2705+ (base-revision-hash-id (xmtn--get-base-revision-hash-id root))
2706+ (difference
2707+ (delete-duplicates
2708+ (mapcan
2709+ (lambda (head)
2710+ (xmtn-automate-simple-command-output-lines
2711+ root
2712+ `("ancestry_difference"
2713+ ,head ,base-revision-hash-id)))
2714+ heads))))
2715+ (list
2716+ branch
2717+ `(,(format "Tree %s" root)
2718+ ,(format "Branch %s" branch)
2719+ ,(format "Base %s" base-revision-hash-id)
2720+ ,(case (length heads)
2721+ (1 "branch is merged")
2722+ (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
2723+ nil
2724+ ,(case (length difference)
2725+ (0 "No revisions that are not in base revision")
2726+ (1 "1 revision that is not in base revision:")
2727+ (t (format
2728+ "%s revisions that are not in base revision:"
2729+ (length difference)))))
2730+ '()
2731+ difference)))
2732
2733 (defun xmtn-revlist-show-conflicts ()
2734 "If point is on a revision that has two parents, show conflicts
2735@@ -459,20 +455,19 @@
2736 (xmtn--setup-revlist
2737 root
2738 (lambda (root)
2739- (xmtn-automate-with-session (nil root)
2740- (let* ((branch (xmtn--tree-default-branch root))
2741- (head-revision-hash-ids (xmtn--heads root branch))
2742- (head-count (length head-revision-hash-ids)))
2743- (list
2744- branch
2745- (list (format "Tree %s" root)
2746- (format "Branch %s" branch)
2747- (case head-count
2748- (0 "No head revisions (branch empty (or circular ;))")
2749- (1 "1 head revision:")
2750- (t (format "%s head revisions: " head-count))))
2751- '()
2752- head-revision-hash-ids))))
2753+ (let* ((branch (xmtn--tree-default-branch root))
2754+ (head-revision-hash-ids (xmtn--heads root branch))
2755+ (head-count (length head-revision-hash-ids)))
2756+ (list
2757+ branch
2758+ (list (format "Tree %s" root)
2759+ (format "Branch %s" branch)
2760+ (case head-count
2761+ (0 "No head revisions (branch empty (or circular ;))")
2762+ (1 "1 head revision:")
2763+ (t (format "%s head revisions: " head-count))))
2764+ '()
2765+ head-revision-hash-ids)))
2766 ;; Passing nil as first-line-only-p, last-n is arbitrary here.
2767 nil nil))
2768 nil)
2769@@ -498,20 +493,19 @@
2770 (xmtn--setup-revlist
2771 root
2772 (lambda (root)
2773- (xmtn-automate-with-session (nil root)
2774- (let ((branch (xmtn--tree-default-branch root))
2775- (revision-hash-ids
2776- (mapcar #'first
2777- (xmtn--get-content-changed-closure
2778- root last-backend-id normalized-file dvc-revlist-last-n))))
2779- (list
2780- branch
2781- (list
2782- (if dvc-revlist-last-n
2783- (format "Log for %s (last %d entries)" file dvc-revlist-last-n)
2784- (format "Log for %s" file)))
2785- '()
2786- revision-hash-ids))))
2787+ (let ((branch (xmtn--tree-default-branch root))
2788+ (revision-hash-ids
2789+ (mapcar #'first
2790+ (xmtn--get-content-changed-closure
2791+ root last-backend-id normalized-file dvc-revlist-last-n))))
2792+ (list
2793+ branch
2794+ (list
2795+ (if dvc-revlist-last-n
2796+ (format "Log for %s (last %d entries)" file dvc-revlist-last-n)
2797+ (format "Log for %s" file)))
2798+ '()
2799+ revision-hash-ids)))
2800 first-line-only-p
2801 last-n))))
2802
2803@@ -530,25 +524,24 @@
2804 (xmtn--setup-revlist
2805 root
2806 (lambda (root)
2807- (xmtn-automate-with-session (nil root)
2808- (let* ((branch (xmtn--tree-default-branch root))
2809- (revision-hash-ids (xmtn--expand-selector root selector))
2810- (count (length revision-hash-ids)))
2811- (list
2812- branch
2813- (list (format "Tree %s" root)
2814- (format "Default branch %s" branch)
2815- (if (with-syntax-table (standard-syntax-table)
2816- (string-match "\\`\\s *\\'" selector))
2817- "Blank selector"
2818- (format "Selector %s" selector))
2819- (case count
2820- (0 "No revisions matching selector")
2821- (1 "1 revision matching selector:")
2822- (t (format "%s revisions matching selector: "
2823- count))))
2824- '()
2825- revision-hash-ids))))
2826+ (let* ((branch (xmtn--tree-default-branch root))
2827+ (revision-hash-ids (xmtn--expand-selector root selector))
2828+ (count (length revision-hash-ids)))
2829+ (list
2830+ branch
2831+ (list (format "Tree %s" root)
2832+ (format "Default branch %s" branch)
2833+ (if (with-syntax-table (standard-syntax-table)
2834+ (string-match "\\`\\s *\\'" selector))
2835+ "Blank selector"
2836+ (format "Selector %s" selector))
2837+ (case count
2838+ (0 "No revisions matching selector")
2839+ (1 "1 revision matching selector:")
2840+ (t (format "%s revisions matching selector: "
2841+ count))))
2842+ '()
2843+ revision-hash-ids)))
2844 ;; Passing nil as first-line-only-p is arbitrary here.
2845 nil
2846 ;; FIXME: it might be useful to specify last-n here
2847@@ -560,28 +553,26 @@
2848 ;;;###autoload
2849 (defun xmtn-dvc-revlog-get-revision (revision-id)
2850 (let ((root (dvc-tree-root)))
2851- (xmtn-automate-with-session (nil root)
2852- (let ((backend-id (xmtn--resolve-revision-id root revision-id)))
2853- (xmtn-match backend-id
2854- ((local-tree $path) (error "Not implemented"))
2855- ((revision $revision-hash-id)
2856- (with-output-to-string
2857- (flet ((write-line (format &rest args)
2858- (princ (apply #'format format args))
2859- (terpri)))
2860- (write-line "Revision %s" revision-hash-id)
2861- ;; FIXME: It would be good to sort the standard certs
2862- ;; like author, date, branch, tag and changelog into
2863- ;; some canonical order and format changelog specially
2864- ;; since it usually spans multiple lines.
2865- (xmtn--map-parsed-certs
2866- root revision-hash-id
2867- (lambda (key signature name value trusted)
2868- (declare (ignore key))
2869- (if (not trusted)
2870- (write-line "Untrusted cert, name=%s" name)
2871- (write-line "%s: %s" name value))))))))))))
2872-
2873+ (let ((backend-id (xmtn--resolve-revision-id root revision-id)))
2874+ (xmtn-match backend-id
2875+ ((local-tree $path) (error "Not implemented"))
2876+ ((revision $revision-hash-id)
2877+ (with-output-to-string
2878+ (flet ((write-line (format &rest args)
2879+ (princ (apply #'format format args))
2880+ (terpri)))
2881+ (write-line "Revision %s" revision-hash-id)
2882+ ;; FIXME: It would be good to sort the standard certs
2883+ ;; like author, date, branch, tag and changelog into
2884+ ;; some canonical order and format changelog specially
2885+ ;; since it usually spans multiple lines.
2886+ (xmtn--map-parsed-certs
2887+ root revision-hash-id
2888+ (lambda (key signature name value trusted)
2889+ (declare (ignore key))
2890+ (if (not trusted)
2891+ (write-line "Untrusted cert, name=%s" name)
2892+ (write-line "%s: %s" name value)))))))))))
2893
2894 (defun xmtn-revlist-explicit-merge ()
2895 "Run mtn explicit_merge on the two marked revisions.
2896@@ -618,29 +609,6 @@
2897 (target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))
2898 (xmtn--update root target-hash-id nil nil)))
2899
2900-;; Being able to conveniently disapprove whole batches of revisions
2901-;; is going to be a lot of fun.
2902-(defun xmtn-revlist-disapprove ()
2903- "Disapprove the marked revisions, or the revision at point if none marked.
2904-
2905-To be invoked from an xmtn revlist buffer."
2906- (interactive)
2907- (let* ((root (dvc-tree-root))
2908- (entries (or (dvc-revision-marked-revisions)
2909- (list (dvc-revlist-current-patch-struct))))
2910- (hash-ids (map 'vector #'xmtn--revlist-entry-revision-hash-id entries))
2911- (description (case (length hash-ids)
2912- (0 (xmtn--assert-nil))
2913- (1 (format "revision %s" (elt hash-ids 0)))
2914- (t (format "%s revisions" (length hash-ids))))))
2915- (assert (every #'xmtn--hash-id-p hash-ids))
2916- (unless (yes-or-no-p (format "Disapprove %s? " description))
2917- (error "Aborted disapprove"))
2918- (xmtn--dotimes-with-progress-reporter (i (length hash-ids))
2919- (format "Disapproving %s..." description)
2920- (let ((hash-id (aref hash-ids i)))
2921- (funcall (xmtn--do-disapprove-future root hash-id))))))
2922-
2923 (provide 'xmtn-revlist)
2924
2925 ;;; xmtn-revlist.el ends here
2926
2927=== modified file 'lisp/xmtn-run.el'
2928--- lisp/xmtn-run.el 2009-08-12 00:15:41 +0000
2929+++ lisp/xmtn-run.el 2010-02-25 22:31:14 +0000
2930@@ -43,31 +43,18 @@
2931
2932 (define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)
2933
2934-(defun xmtn--call-with-environment-for-subprocess (xmtn--thunk)
2935- (let ((process-environment (list* "LC_ALL="
2936- "LC_CTYPE=en_US.UTF-8"
2937- "LC_MESSAGES=C"
2938- process-environment)))
2939- (funcall xmtn--thunk)))
2940-
2941-(defmacro* xmtn--with-environment-for-subprocess (() &body body)
2942- (declare (indent 1) (debug (sexp body)))
2943- `(xmtn--call-with-environment-for-subprocess (lambda () ,@body)))
2944-
2945 (defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key)
2946 (xmtn--check-cached-command-version)
2947 (let ((default-directory (file-truename (or root default-directory))))
2948- (let ((coding-system-for-write 'xmtn--monotone-normal-form))
2949- (xmtn--with-environment-for-subprocess ()
2950- (apply #'dvc-run-dvc-sync
2951- 'xmtn
2952- `(,@xmtn-additional-arguments
2953- ;; We don't pass the --root argument here; it is not
2954- ;; necessary since default-directory is set, and it
2955- ;; confuses the Cygwin version of mtn when run with a
2956- ;; non-Cygwin Emacs.
2957- ,@arguments)
2958- dvc-run-keys)))))
2959+ (dvc-run-dvc-sync
2960+ 'xmtn
2961+ `(,@xmtn-additional-arguments
2962+ ;; We don't pass the --root argument here; it is not
2963+ ;; necessary since default-directory is set, and it
2964+ ;; confuses the Cygwin version of mtn when run with a
2965+ ;; non-Cygwin Emacs.
2966+ ,@arguments)
2967+ dvc-run-keys)))
2968
2969 ;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
2970 ;;; reason, spawns the subprocess with a working directory with all
2971@@ -80,141 +67,36 @@
2972 (defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key)
2973 (xmtn--check-cached-command-version)
2974 (let ((default-directory (file-truename (or root default-directory))))
2975- (let ((coding-system-for-write 'xmtn--monotone-normal-form))
2976- (xmtn--with-environment-for-subprocess ()
2977- (apply #'dvc-run-dvc-async
2978- 'xmtn
2979- `(,@xmtn-additional-arguments
2980- ;; We don't pass the --root argument here; it is not
2981- ;; necessary since default-directory is set, and it
2982- ;; confuses the Cygwin version of mtn when run with a
2983- ;; non-Cygwin Emacs.
2984- ,@arguments)
2985- dvc-run-keys)))))
2986-
2987-(defun* xmtn--command-append-to-buffer-async (buffer root arguments
2988- &rest dvc-run-keys
2989- &key finished)
2990- (xmtn--check-cached-command-version)
2991- (let ((default-directory (file-truename (or root default-directory))))
2992- (let ((coding-system-for-write 'xmtn--monotone-normal-form))
2993- (xmtn--with-environment-for-subprocess ()
2994- (apply #'dvc-run-dvc-async
2995- 'xmtn
2996- `(,@xmtn-additional-arguments
2997- ,@(if root `(,(concat "--root=" (file-truename root))))
2998- ,@arguments)
2999- :finished (lexical-let ((buffer buffer)
3000- (finished finished))
3001- (lambda (output error status arguments)
3002- (with-current-buffer buffer
3003- (save-excursion
3004- (goto-char (point-max))
3005- (let ((inhibit-read-only t))
3006- (insert-buffer-substring output))))
3007- (funcall (or finished #'dvc-default-finish-function)
3008- output error status arguments)))
3009- :related-buffer buffer
3010- dvc-run-keys)))))
3011-
3012-(defun* xmtn--command-lines-future (root which-buffer arguments)
3013- (xmtn--check-cached-command-version)
3014- (lexical-let ((got-output-p nil)
3015- lines)
3016- (lexical-let
3017- ((process
3018- (let ((default-directory (file-truename (or root
3019- default-directory))))
3020- (let ((coding-system-for-write 'xmtn--monotone-normal-form))
3021- (xmtn--with-environment-for-subprocess ()
3022- (dvc-run-dvc-async
3023- 'xmtn
3024- `(,@xmtn-additional-arguments
3025- ,@(if root `(,(concat "--root=" (file-truename root))))
3026- ,@arguments)
3027- :finished
3028- (lexical-let ((which-buffer which-buffer))
3029- (lambda (output error status arguments)
3030- (with-current-buffer (ecase which-buffer
3031- (output output)
3032- (error error))
3033- (save-excursion
3034- (goto-char (point-min))
3035- (setq lines
3036- (loop until (eobp)
3037- collect
3038- (buffer-substring-no-properties
3039- (point)
3040- (progn (end-of-line) (point)))
3041- do (forward-line 1)))
3042- (setq got-output-p t)))
3043- nil))))))))
3044- (lambda ()
3045- (assert (member (process-status process) '(run exit signal)) t)
3046- (while (and (eql (process-status process) 'run)
3047- (accept-process-output process)))
3048- (assert (member (process-status process) '(exit signal)) t)
3049- ;; This (including discarding input) is needed to allow the
3050- ;; sentinel to run, at least on GNU Emacs 21.4.2 and on GNU
3051- ;; Emacs 22.0.50.1 of 2006-06-13. Sentinels are supposed to
3052- ;; be run when `accept-process-output' is called, but they
3053- ;; apparently aren't reliably. I haven't investigated this
3054- ;; further.
3055- ;;
3056- ;; Problems with the sentinel not running mostly seem to be
3057- ;; reproducible (after commenting out the code below) by
3058- ;; pressing C-x V c immediately followed by a few other keys,
3059- ;; or by pressing C-x V c not followed by any further input,
3060- ;; or by editing a file in the tree without saving it, then
3061- ;; pressing C-x V c, waiting for the "Save buffer?" prompt and
3062- ;; then pressing y immediately followed by a few other keys.
3063- ;;
3064- ;; I hate having to discard the input because it interferes
3065- ;; with typing ahead while Emacs is still busy. But hanging
3066- ;; indefinitely waiting for `got-output-p' from a sentinel
3067- ;; that never runs is even worse.
3068- (while (and (eql (process-status process) 'exit)
3069- (eql (process-exit-status process) 0)
3070- (not got-output-p))
3071- (discard-input)
3072- (sit-for .01))
3073- (unless got-output-p
3074- (assert (not (and (eql (process-status process) 'exit)
3075- (eql (process-exit-status process) 0))))
3076- (error "Process %s terminated abnormally, status=%s, exit code=%s"
3077- (process-name process)
3078- (process-status process)
3079- (process-exit-status process)))
3080- lines))))
3081-
3082-(defun* xmtn--command-output-lines-future (root arguments)
3083- (xmtn--command-lines-future root 'output arguments))
3084-
3085-(defun* xmtn--command-error-output-lines-future (root arguments)
3086- (xmtn--command-lines-future root 'error arguments))
3087+ (apply #'dvc-run-dvc-async
3088+ 'xmtn
3089+ `(,@xmtn-additional-arguments
3090+ ;; We don't pass the --root argument here; it is not
3091+ ;; necessary since default-directory is set, and it
3092+ ;; confuses the Cygwin version of mtn when run with a
3093+ ;; non-Cygwin Emacs.
3094+ ,@arguments)
3095+ dvc-run-keys)))
3096
3097 (defun xmtn--command-output-lines (root arguments)
3098 "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings."
3099 (xmtn--check-cached-command-version)
3100 (let ((accu (list)))
3101 (let ((default-directory (file-truename (or root default-directory))))
3102- (let ((coding-system-for-write 'xmtn--monotone-normal-form))
3103- (xmtn--with-environment-for-subprocess ()
3104- (dvc-run-dvc-sync
3105- 'xmtn
3106- `(,@xmtn-additional-arguments
3107- ,@(if root `(,(concat "--root=" (file-truename root))))
3108- ,@arguments)
3109- :finished (lambda (output error status arguments)
3110- (with-current-buffer output
3111- (save-excursion
3112- (goto-char (point-min))
3113- (while (not (eobp))
3114- (push (buffer-substring-no-properties
3115- (point)
3116- (progn (end-of-line) (point)))
3117- accu)
3118- (forward-line 1)))))))))
3119+ (dvc-run-dvc-sync
3120+ 'xmtn
3121+ `(,@xmtn-additional-arguments
3122+ ,@(if root `(,(concat "--root=" (file-truename root))))
3123+ ,@arguments)
3124+ :finished (lambda (output error status arguments)
3125+ (with-current-buffer output
3126+ (save-excursion
3127+ (goto-char (point-min))
3128+ (while (not (eobp))
3129+ (push (buffer-substring-no-properties
3130+ (point)
3131+ (progn (end-of-line) (point)))
3132+ accu)
3133+ (forward-line 1)))))))
3134 (setq accu (nreverse accu))
3135 accu))
3136

Subscribers

People subscribed via source and target branches