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

sync with upstream

Browse Source
This commit is contained in:
Kai Tetzlaff 2010-06-18 09:23:22 +02:00
parent effbe8f128
commit 55f6a1fe09
12 changed files with 448 additions and 491 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dvc/configure.ac
View File

@ -56,7 +56,6 @@ AC_CONFIG_FILES([Makefile lisp/Makefile texinfo/Makefile dvc-load.el lisp/dvc-si
# Common system utilities checking: # Common system utilities checking:
AC_PROG_MAKE_SET AC_PROG_MAKE_SET
AC_PROG_INSTALL AC_PROG_INSTALL
AC_PROG_MKDIR_P
# External programs checking: # External programs checking:

15
dvc/lisp/dvc-buffers.el
View File

@ -1,6 +1,6 @@
;;; dvc-buffers.el --- Buffer management for DVC ;;; dvc-buffers.el --- Buffer management for DVC
;; Copyright (C) 2005-2009 by all contributors ;; Copyright (C) 2005-2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr> ;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from: ;; Contributions from:
@ -659,6 +659,19 @@ just bury it."
(dvc-kill-all-type 'revision) (dvc-kill-all-type 'revision)
(dvc-kill-all-type 'last-revision)) (dvc-kill-all-type 'last-revision))
(defun dvc-kill-all-workspace (workspace)
"Kill all buffers whose files are in the WORKSPACE tree."
(interactive "Dkill buffers in workspace: ")
(let ((workspace (expand-file-name workspace))
(count 0))
(dolist (buffer (buffer-list))
(let ((file-name (buffer-file-name buffer)))
(and file-name ;; some buffers don't have a file name
(string= workspace (substring file-name 0 (min (length file-name) (length workspace))))
(kill-buffer buffer)
(setq count (+ 1 count)))))
(message "killed %d buffers" count)))
(defvar dvc-save-some-buffers-ignored-modes '(dvc-log-edit-mode)) (defvar dvc-save-some-buffers-ignored-modes '(dvc-log-edit-mode))
(defun dvc-save-some-buffers (&optional tree) (defun dvc-save-some-buffers (&optional tree)
"Save all buffers visiting a file in TREE." "Save all buffers visiting a file in TREE."

6
dvc/lisp/dvc-core.el
View File

@ -1,6 +1,6 @@
;;; dvc-core.el --- Core functions for distributed version control ;;; dvc-core.el --- Core functions for distributed version control
;; Copyright (C) 2005-2009 by all contributors ;; Copyright (C) 2005-2010 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at> ;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions From: ;; Contributions From:
@ -109,7 +109,9 @@ This function may be useful to find \{arch\} and/or _darcs directories."
Calls `dvc-find-tree-root-file-first', shows a message when Calls `dvc-find-tree-root-file-first', shows a message when
called interactively, and manages no-error. called interactively, and manages no-error.
If LOCATION is nil, the tree root is returned, and it is If LOCATION is nil, `default-directory' is used instead.
The tree root is returned, and it is
guaranteed to end in a \"/\" character. guaranteed to end in a \"/\" character.
MSG must be of the form \"%S is not a ...-managed tree\"." MSG must be of the form \"%S is not a ...-managed tree\"."

26
dvc/lisp/dvc-diff.el
View File

@ -1,6 +1,6 @@
;;; dvc-diff.el --- A generic diff mode for DVC ;;; dvc-diff.el --- A generic diff mode for DVC
;; Copyright (C) 2005-2009 by all contributors ;; Copyright (C) 2005-2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr> ;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from: ;; Contributions from:
@ -509,15 +509,17 @@ file after."
(unless (and (car dvc-diff-base) (unless (and (car dvc-diff-base)
(car dvc-diff-modified)) (car dvc-diff-modified))
(error "No revision information to base ediff on")) (error "No revision information to base ediff on"))
(let ((on-modified-file (dvc-get-file-info-at-point)) (let ((modified-file (dvc-get-file-info-at-point))
(loc (point))) (loc (point)))
(if (and on-modified-file (if (and modified-file
(dvc-diff-in-ewoc-p)) (dvc-diff-in-ewoc-p))
;; on ewoc item; just ediff ;; on ewoc item; just ediff
(dvc-file-ediff-revisions on-modified-file (dvc-file-ediff-revisions modified-file
dvc-diff-base dvc-diff-base
dvc-diff-modified) dvc-diff-modified
(dvc-fileinfo-base-file))
;; in diff section; find hunk index, so we can jump to it in the ediff. ;; in diff section; find hunk index, so we can jump to it in the ediff.
(end-of-line) (end-of-line)
(dvc-trace "loc=%S" loc) (dvc-trace "loc=%S" loc)
@ -530,7 +532,7 @@ file after."
(setq hunk (1+ hunk))) (setq hunk (1+ hunk)))
(goto-char loc) (goto-char loc)
(with-current-buffer (with-current-buffer
(dvc-file-ediff-revisions on-modified-file (dvc-file-ediff-revisions modified-file
dvc-diff-base dvc-diff-base
dvc-diff-modified) dvc-diff-modified)
(ediff-jump-to-difference hunk)))))) (ediff-jump-to-difference hunk))))))
@ -560,7 +562,8 @@ interactively."
(defun dvc-diff-get-file-at-point () (defun dvc-diff-get-file-at-point ()
"Return filename for file at point. "Return filename for file at point.
Throw an error when not on a file." Throw an error when not on a file. If file is renamed, this is
the modified name."
(if (dvc-diff-in-ewoc-p) (if (dvc-diff-in-ewoc-p)
(dvc-fileinfo-current-file) (dvc-fileinfo-current-file)
(save-excursion (save-excursion
@ -810,11 +813,12 @@ Useful to clear diff buffers after a commit."
(set-auto-mode t))) (set-auto-mode t)))
(dvc-ediff-buffers pristine-buffer file-buffer)))) (dvc-ediff-buffers pristine-buffer file-buffer))))
(defun dvc-file-ediff-revisions (file base modified) (defun dvc-file-ediff-revisions (file base-rev modified-rev &optional base-file)
"View changes in FILE between BASE and MODIFIED using ediff." "View changes in FILE between BASE-REV and MODIFIED-REV using ediff.
Optional BASE-FILE is filename in BASE-REV if different from FILE."
(dvc-ediff-buffers (dvc-ediff-buffers
(dvc-revision-get-file-in-buffer file base) (dvc-revision-get-file-in-buffer (or base-file file) base-rev)
(dvc-revision-get-file-in-buffer file modified))) (dvc-revision-get-file-in-buffer file modified-rev)))
;;;###autoload ;;;###autoload
(defun dvc-dvc-file-diff (file &optional base modified dont-switch) (defun dvc-dvc-file-diff (file &optional base modified dont-switch)

40
dvc/lisp/dvc-fileinfo.el
View File

@ -1,7 +1,7 @@
;;; dvc-fileinfo.el --- An ewoc structure for displaying file information ;;; dvc-fileinfo.el --- An ewoc structure for displaying file information
;;; for DVC ;;; for DVC
;; Copyright (C) 2007 - 2009 by all contributors ;; Copyright (C) 2007 - 2010 by all contributors
;; Author: Stephen Leake, <stephen_leake@stephe-leake.org> ;; Author: Stephen Leake, <stephen_leake@stephe-leake.org>
@ -63,7 +63,8 @@ The elements must all be of class dvc-fileinfo-root.")
(indexed t) ;; Whether changes made to the file have been recorded (indexed t) ;; Whether changes made to the file have been recorded
;; in the index. Use t if the back-end does not ;; in the index. Use t if the back-end does not
;; support an index. ;; support an index.
more-status ;; String; whatever else the backend has to say more-status ;; String. If status is rename-*, this is the other name.
;; Otherwise whatever else the backend has to say
) )
(defun dvc-fileinfo-status-image-full (status) (defun dvc-fileinfo-status-image-full (status)
@ -190,6 +191,12 @@ indicate statuses."
(progn (progn
(newline) (newline)
(insert " ") (insert " ")
(ecase (dvc-fileinfo-file-status fileinfo)
(rename-source
(insert "to "))
(rename-target
(insert "from "))
(t nil))
(insert (dvc-fileinfo-file-more-status fileinfo)))))) (insert (dvc-fileinfo-file-more-status fileinfo))))))
(dvc-fileinfo-legacy (dvc-fileinfo-legacy
@ -289,11 +296,36 @@ containing a 'file."
(defun dvc-fileinfo-current-file () (defun dvc-fileinfo-current-file ()
"Return a string giving the filename (including path from root) "Return a string giving the filename (including path from root)
of the file element on the line at point. Throws an error if of the file element on the line at point. Throws an error if
point is not on a file element line." point is not on a file element line. If file status is
`rename-*', this is the modified (or target) name."
(let ((fileinfo (dvc-fileinfo-current-fileinfo))) (let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo (etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir (dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(dvc-fileinfo-path fileinfo)) (ecase (dvc-fileinfo-file-status fileinfo)
(rename-source
;; target name is in more-status
(dvc-fileinfo-file-more-status fileinfo))
(t
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))
(dvc-fileinfo-legacy
(cadr (dvc-fileinfo-legacy-data fileinfo))))))
(defun dvc-fileinfo-base-file ()
"Return a string giving the filename in the base revision.
Includes path from root). Different from
dvc-fileinfo-current-file only for renamed files."
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo ; also matches dvc-fileinfo-dir
(dvc-fileinfo-file
(ecase (dvc-fileinfo-file-status fileinfo)
(rename-target
;; source name is in more-status, and it includes the path
(dvc-fileinfo-file-more-status fileinfo))
(t
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))
(dvc-fileinfo-legacy (dvc-fileinfo-legacy
(cadr (dvc-fileinfo-legacy-data fileinfo)))))) (cadr (dvc-fileinfo-legacy-data fileinfo))))))

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

@ -1,6 +1,6 @@
;;; xmtn-automate.el --- Interface to monotone's "automate" functionality ;;; xmtn-automate.el --- Interface to monotone's "automate" functionality
;; Copyright (C) 2008, 2009 Stephen Leake ;; Copyright (C) 2008 - 2010 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -50,28 +50,18 @@
;; `xmtn-automate-new-command' to send commands to monotone. ;; `xmtn-automate-new-command' to send commands to monotone.
;; ;;
;; A COMMAND is a list of strings (the command and its arguments), or ;; A COMMAND is a list of strings (the command and its arguments), or
;; a cons of lists of strings. If car COMMAND is a list, car COMMAND is ;; a cons of lists of strings. If car COMMAND is a list, car COMMAND
;; options (without leading "--"), cdr is the command and arguments. ;; is options, cdr is the command and arguments. Options are always
;; specified as pairs of keyword and value, and without the leading
;; "--". If an option has no value, use ""; see
;; xmtn-automate-local-changes for an example.
;; ;;
;; `xmtn-automate-new-command' returns a command handle. You use this ;; `xmtn-automate-new-command' returns a command handle. You use this
;; handle to check the error code of the command and obtain its ;; handle to check the error code of the command and obtain its
;; output. Your Emacs Lisp code can also do other computation while ;; output. Your Emacs Lisp code can also do other computation while
;; the monotone command runs. Allowing this kind of parallelism and ;; the monotone command runs. Allowing this kind of parallelism is
;; incremental processing of command output is the main reason for ;; the main reason for introducing command handles.
;; introducing command handles.
;; ;;
;; The intention behind this protocol is to allow Emacs Lisp code to
;; process command output incrementally as it arrives instead of
;; waiting until it is complete. However, for xmtn-basic-io, the
;; bookkeeping overhead for this kind of pipelining was excessive --
;; byte-compiled Emacs Lisp is rather slow. But I didn't try very
;; hard to tune it, either. So I'm not sure whether incremental
;; processing is useful.
;;
;; In the output buffer, the mtn stdio output header (<command
;; number>:<err code>:<last?>:<size>:<data>) has been processed;
;; only the data is present.
;; There are some notes on the design of xmtn in ;; There are some notes on the design of xmtn in
;; docs/xmtn-readme.txt. ;; docs/xmtn-readme.txt.
@ -84,43 +74,25 @@
(require 'xmtn-run) (require 'xmtn-run)
(require 'xmtn-compat)) (require 'xmtn-compat))
(defun xmtn-automate-command-error-code (command)
(let ((process (xmtn-automate--session-process
(xmtn-automate--command-handle-session command))))
(while (null (xmtn-automate--command-handle-error-code command))
(xmtn--assert-for-effect
(accept-process-output process))))
(xmtn-automate--command-handle-error-code command))
(defun xmtn-automate-command-buffer (command) (defun xmtn-automate-command-buffer (command)
(xmtn-automate--command-handle-buffer command)) (xmtn-automate--command-handle-buffer command))
(defun xmtn-automate-command-write-marker-position (command) (defun xmtn-automate-command-write-marker-position (command)
(marker-position (xmtn-automate--command-handle-write-marker command))) (marker-position (xmtn-automate--command-handle-write-marker command)))
(defun xmtn-automate-command-accept-output (command)
(let ((previous-write-marker-position
(marker-position (xmtn-automate--command-handle-write-marker
command))))
(while (and (= (marker-position (xmtn-automate--command-handle-write-marker
command))
previous-write-marker-position)
(not (xmtn-automate--command-handle-finished-p command)))
(xmtn--assert-for-effect
(accept-process-output
(xmtn-automate--session-process
(xmtn-automate--command-handle-session command)))))
(> (marker-position (xmtn-automate--command-handle-write-marker
command))
previous-write-marker-position)))
(defun xmtn-automate-command-finished-p (command)
(xmtn-automate--command-handle-finished-p command))
(defun xmtn-automate-command-wait-until-finished (handle) (defun xmtn-automate-command-wait-until-finished (handle)
(while (not (xmtn-automate-command-finished-p handle)) (let ((session (xmtn-automate--command-handle-session handle)))
(xmtn--assert-for-effect (or (xmtn-automate-command-accept-output handle) (while (not (xmtn-automate--command-handle-finished-p handle))
(xmtn-automate-command-finished-p handle)))) ;; we use a timeout here to allow debugging, and possible incremental processing
(accept-process-output (xmtn-automate--session-process session) 1.0)
(xmtn-automate--process-new-output session))
(unless (eql (xmtn-automate--command-handle-error-code handle) 0)
(xmtn-automate--cleanup-command handle)
(pop-to-buffer (format dvc-error-buffer 'xmtn))
(goto-char (point-max))
(newline)
(insert (format "command: %s" (xmtn-automate--command-handle-command handle)))
(error "mtn error %s" (xmtn-automate--command-handle-error-code handle))))
nil) nil)
(defvar xmtn-automate--*sessions* '() (defvar xmtn-automate--*sessions* '()
@ -147,34 +119,24 @@ ROOT, store it in session cache. Return session."
workspace root." workspace root."
(cdr (assoc key xmtn-automate--*sessions*))) (cdr (assoc key xmtn-automate--*sessions*)))
(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle) (defun xmtn-automate--command-output-as-string (handle)
(xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle) (with-current-buffer (xmtn-automate-command-buffer handle)
(prog1 (prog1
(buffer-substring-no-properties (point-min) (point-max)) (buffer-substring-no-properties (point-min) (point-max))
(xmtn-automate--cleanup-command handle)))) (xmtn-automate--cleanup-command handle))))
(defun xmtn-automate-command-check-for-and-report-error (handle)
(unless (eql (xmtn-automate-command-error-code handle) 0)
(error "mtn automate command (arguments %S) reported an error (code %s):\n%s"
(xmtn-automate--command-handle-arguments handle)
(xmtn-automate-command-error-code handle)
(xmtn-automate--command-output-as-string-ignoring-exit-code handle)))
nil)
(defun xmtn-automate-simple-command-output-string (root command) (defun xmtn-automate-simple-command-output-string (root command)
"Send COMMAND to session for ROOT. Return result as a string." "Send COMMAND to session for ROOT. Return result as a string."
(let* ((session (xmtn-automate-cache-session root)) (let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil))) (command-handle (xmtn-automate--new-command session command)))
(xmtn-automate-command-check-for-and-report-error command-handle) (xmtn-automate-command-wait-until-finished command-handle)
(xmtn-automate--command-output-as-string-ignoring-exit-code command-handle))) (xmtn-automate--command-output-as-string command-handle)))
(defun xmtn-automate-simple-command-output-insert-into-buffer (defun xmtn-automate-simple-command-output-insert-into-buffer
(root buffer command) (root buffer command)
"Send COMMAND to session for ROOT, insert result into BUFFER." "Send COMMAND to session for ROOT, insert result into BUFFER."
(let* ((session (xmtn-automate-cache-session root)) (let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil))) (command-handle (xmtn-automate--new-command session command)))
(xmtn-automate-command-check-for-and-report-error command-handle)
(xmtn-automate-command-wait-until-finished command-handle) (xmtn-automate-command-wait-until-finished command-handle)
(with-current-buffer buffer (with-current-buffer buffer
(insert-buffer-substring-no-properties (insert-buffer-substring-no-properties
@ -184,10 +146,8 @@ workspace root."
(defun xmtn-automate-command-output-lines (handle) (defun xmtn-automate-command-output-lines (handle)
"Return list of lines of output in HANDLE; first line output is "Return list of lines of output in HANDLE; first line output is
first in list." first in list."
(xmtn-automate-command-check-for-and-report-error handle)
(xmtn-automate-command-wait-until-finished handle) (xmtn-automate-command-wait-until-finished handle)
(save-excursion (with-current-buffer (xmtn-automate-command-buffer handle)
(set-buffer (xmtn-automate-command-buffer handle))
(goto-char (point-min)) (goto-char (point-min))
(let (result) (let (result)
(while (< (point) (point-max)) (while (< (point) (point-max))
@ -203,7 +163,7 @@ first in list."
"Return list of strings containing output of COMMAND, one line per "Return list of strings containing output of COMMAND, one line per
string." string."
(let* ((session (xmtn-automate-cache-session root)) (let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command nil))) (command-handle (xmtn-automate--new-command session command)))
(xmtn-automate-command-output-lines command-handle))) (xmtn-automate-command-output-lines command-handle)))
(defun xmtn-automate-simple-command-output-line (root command) (defun xmtn-automate-simple-command-output-line (root command)
@ -226,9 +186,14 @@ Signals an error if output contains zero lines or more than one line."
(defstruct (xmtn-automate--decoder-state (defstruct (xmtn-automate--decoder-state
(:constructor xmtn-automate--%make-raw-decoder-state)) (:constructor xmtn-automate--%make-raw-decoder-state))
;; State for decoding stdio output packets.
(read-marker) (read-marker)
;; char position (not marker) of last character read. We use a
;; position, not a marker, because text gets inserted in front of
;; the marker, and it moves.
(remaining-chars 0) (remaining-chars 0)
(last-p nil)) (stream 0); determines output buffer
)
(defstruct (xmtn-automate--session (defstruct (xmtn-automate--session
(:constructor xmtn-automate--%make-raw-session) (:constructor xmtn-automate--%make-raw-session)
@ -239,20 +204,18 @@ Signals an error if output contains zero lines or more than one line."
(process nil) (process nil)
(decoder-state) (decoder-state)
(next-command-number 0) (next-command-number 0)
(must-not-kill-counter)
(remaining-command-handles) (remaining-command-handles)
(sent-kill-p) (sent-kill-p)
(closed-p nil)) (closed-p nil))
(defstruct (xmtn-automate--command-handle (defstruct (xmtn-automate--command-handle
(:constructor xmtn-automate--%make-raw-command-handle)) (:constructor xmtn-automate--%make-raw-command-handle))
(arguments) (command)
(mtn-command-number) (mtn-command-number)
(session-command-number) (session-command-number)
(session) (session)
(buffer) (buffer)
(write-marker) (write-marker)
(may-kill-p)
(finished-p nil) (finished-p nil)
(error-code nil)) (error-code nil))
@ -273,7 +236,6 @@ Signals an error if output contains zero lines or more than one line."
(defun xmtn-automate--session-send-process-kill (session) (defun xmtn-automate--session-send-process-kill (session)
(let ((process (xmtn-automate--session-process session))) (let ((process (xmtn-automate--session-process session)))
;; Stop parser.
(setf (xmtn-automate--session-sent-kill-p session) t) (setf (xmtn-automate--session-sent-kill-p session) t)
(with-current-buffer (xmtn-automate--session-buffer session) (with-current-buffer (xmtn-automate--session-buffer session)
(let ((inhibit-read-only t) (let ((inhibit-read-only t)
@ -282,13 +244,12 @@ Signals an error if output contains zero lines or more than one line."
(goto-char (process-mark process)) (goto-char (process-mark process))
(insert "\n(killing process)\n") (insert "\n(killing process)\n")
(set-marker (process-mark process) (point))))) (set-marker (process-mark process) (point)))))
;; Maybe this should really be a sigpipe. But let's not get too
;; fancy (ha!) and non-portable. (signal-process process 'KILL)
;;(signal-process (xmtn-automate--session-process session) 'PIPE)
;; This call to `sit-for' is apparently needed in some situations to ;; This call to `sit-for' is apparently needed in some situations to
;; make sure the process really gets killed. ;; make sure the process really gets killed.
(sit-for 0) (sit-for 0))
(interrupt-process process))
nil) nil)
(defun xmtn-automate--close-session (session) (defun xmtn-automate--close-session (session)
@ -297,65 +258,86 @@ Signals an error if output contains zero lines or more than one line."
(let ((process (xmtn-automate--session-process session))) (let ((process (xmtn-automate--session-process session)))
(cond (cond
((null process) ((null process)
;; Process died for some reason - most likely 'mtn not found in ;; Process was never created or was killed - most likely 'mtn
;; path'. Don't warn if buffer hasn't been deleted; that ;; not found in path'. Don't warn if buffer hasn't been deleted;
;; obscures the real error message ;; that obscures the real error message
nil) nil)
((ecase (process-status process)
(run nil)
(exit t)
(signal t))
(unless xmtn-automate--*preserve-buffers-for-debugging*
(kill-buffer (xmtn-automate--session-buffer session))))
(t (t
(process-send-eof process) (ecase (process-status process)
(if (zerop (xmtn-automate--session-must-not-kill-counter session)) (run
(xmtn-automate--session-send-process-kill session) (process-send-eof process)
;; We can't kill the buffer yet. We need to dump mtn's output (xmtn-automate--session-send-process-kill session)
;; in there so we can parse it and determine when the critical (sleep-for 1.0); let process die before deleting associated buffers
;; commands are finished so we can then kill mtn. )
(dvc-trace (exit t)
"Not killing process %s yet: %s out of %s remaining commands are critical" (signal t))))
(process-name process)
(xmtn-automate--session-must-not-kill-counter session) (unless xmtn-automate--*preserve-buffers-for-debugging*
(length (xmtn-automate--session-remaining-command-handles session)))) (if (buffer-live-p (xmtn-automate--session-buffer session))
(with-current-buffer (xmtn-automate--session-buffer session) (kill-buffer (xmtn-automate--session-buffer session)))))
;; This isn't essential but helps debugging.
(rename-buffer (format "*%s: killed session*"
(xmtn-automate--session-name session))
t))
(let ((fake-session (xmtn-automate--copy-session session)))
(xmtn-automate--set-process-session process fake-session)))))
nil) nil)
(defun xmtn-automate-kill-session (root)
"Kill session for ROOT."
(interactive)
(let ((temp (assoc (dvc-uniquify-file-name root) xmtn-automate--*sessions*)))
(xmtn-automate--close-session (cdr temp))
(setq xmtn-automate--*sessions*
(delete temp xmtn-automate--*sessions* ))))
(defun xmtn-kill-all-sessions ()
"Kill all xmtn-automate sessions."
(interactive)
(let ((count 0)
(key " *xmtn automate session for"))
(dolist (session xmtn-automate--*sessions*)
(xmtn-automate--close-session (cdr session))
(setq count (+ 1 count)))
(setq xmtn-automate--*sessions* nil)
(message "killed %d sessions" count)))
(defun xmtn-automate--start-process (session) (defun xmtn-automate--start-process (session)
(xmtn--check-cached-command-version) (xmtn--check-cached-command-version)
(xmtn--assert-optional (not (xmtn-automate--session-closed-p session)))
(xmtn--assert-optional (typep session 'xmtn-automate--session))
(let ((name (xmtn-automate--session-name session)) (let ((name (xmtn-automate--session-name session))
(buffer (xmtn-automate--new-buffer session)) (buffer (xmtn-automate--new-buffer session))
(root (xmtn-automate--session-root session))) (root (xmtn-automate--session-root session)))
(let ((process-connection-type nil) (let ((process-connection-type nil); use a pipe, not a tty
(default-directory root)) (default-directory root))
(let ((process (let ((process
(apply 'start-process name buffer xmtn-executable (apply 'start-process name buffer xmtn-executable
"automate" "stdio" xmtn-additional-arguments))) "automate" "stdio" xmtn-additional-arguments)))
(ecase (process-status process)
(run
;; If the process started ok, it outputs the stdio
;; header. If there was an error (like default_directory is
;; not a mtn workspace), it outputs an error message and
;; exits.
(accept-process-output process)
(with-current-buffer buffer
;; If the format version changes, we probably need to
;; adapt. So we insist on an exact match.
(goto-char (point-min))
(if (looking-at "format-version: \\([0-9]+\\)\n\n")
(if (not (string-equal (match-string 1) xmtn--required-automate-format-version))
(error "unexpected mtn automate stdio format version %s" (match-string 0)))
;; Some error. Display the session buffer to show the error
(pop-to-buffer buffer)
(error "failed to create mtn automate process"))))
((exit signal)
(pop-to-buffer buffer)
(error "failed to create mtn automate process")))
(setf (xmtn-automate--session-decoder-state session)
(xmtn-automate--%make-raw-decoder-state
:read-marker (with-current-buffer buffer (match-end 0))))
(xmtn-automate--set-process-session process session) (xmtn-automate--set-process-session process session)
(set-process-filter process 'xmtn-automate--process-filter)
(set-process-sentinel process 'xmtn-automate--process-sentinel)
(xmtn--set-process-query-on-exit-flag process nil) (xmtn--set-process-query-on-exit-flag process nil)
;; Need binary (or no-conversion or maybe raw-text-unix?) ;; Need binary (or no-conversion or maybe raw-text-unix?)
;; since this is the format in which mtn automate stdio ;; since this is the format in which mtn automate stdio
;; computes the size of the output. ;; computes the size of the output.
(set-process-coding-system process 'binary 'binary) (set-process-coding-system process 'binary 'binary)
(setf (xmtn-automate--session-process session) process) (setf (xmtn-automate--session-process session) process)
(setf (xmtn-automate--session-decoder-state session)
(xmtn-automate--%make-raw-decoder-state
:read-marker (with-current-buffer buffer
(xmtn--assert-optional (eql (point-min) (point)) t)
(set-marker (make-marker)
(point-min)))))
(setf (xmtn-automate--session-must-not-kill-counter session) 0)
(setf (xmtn-automate--session-remaining-command-handles session) (list)) (setf (xmtn-automate--session-remaining-command-handles session) (list))
(setf (xmtn-automate--session-sent-kill-p session) nil) (setf (xmtn-automate--session-sent-kill-p session) nil)
process)))) process))))
@ -399,8 +381,8 @@ the buffer."
(goto-char (point-max))))) (goto-char (point-max)))))
nil) nil)
(defun xmtn-automate--send-command-string (session command option-plist session-number) (defun xmtn-automate--send-command-string (session command option-pairs session-number)
"Send COMMAND and OPTION-PLIST to SESSION." "Send COMMAND and OPTION-PAIRS to SESSION."
(let* ((buffer-name (format "*%s: input for command %s*" (let* ((buffer-name (format "*%s: input for command %s*"
(xmtn-automate--session-name session) (xmtn-automate--session-name session)
session-number)) session-number))
@ -419,9 +401,9 @@ the buffer."
(set-buffer-multibyte t) (set-buffer-multibyte t)
(setq buffer-read-only t) (setq buffer-read-only t)
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(when option-plist (when option-pairs
(insert "o") (insert "o")
(xmtn-automate--append-encoded-strings option-plist) (xmtn-automate--append-encoded-strings option-pairs)
(insert "e")) (insert "e"))
(insert "l") (insert "l")
(xmtn-automate--append-encoded-strings command) (xmtn-automate--append-encoded-strings command)
@ -435,7 +417,7 @@ the buffer."
(unless xmtn-automate--*preserve-buffers-for-debugging* (unless xmtn-automate--*preserve-buffers-for-debugging*
(kill-buffer buffer)))))) (kill-buffer buffer))))))
(defun xmtn-automate--new-command (session command may-kill-p) (defun xmtn-automate--new-command (session command)
"Send COMMAND to SESSION." "Send COMMAND to SESSION."
(xmtn-automate--ensure-process session) (xmtn-automate--ensure-process session)
(let* ((command-number (let* ((command-number
@ -464,67 +446,65 @@ the buffer."
(eql (point) (point-max)))) (eql (point) (point-max))))
(let ((handle (xmtn-automate--%make-raw-command-handle (let ((handle (xmtn-automate--%make-raw-command-handle
:session session :session session
:arguments command :command command
:session-command-number command-number :session-command-number command-number
:may-kill-p may-kill-p
:buffer buffer :buffer buffer
:write-marker (set-marker (make-marker) (point))))) :write-marker (set-marker (make-marker) (point)))))
(setf (setf
(xmtn-automate--session-remaining-command-handles session) (xmtn-automate--session-remaining-command-handles session)
(nconc (xmtn-automate--session-remaining-command-handles session) (nconc (xmtn-automate--session-remaining-command-handles session)
(list handle))) (list handle)))
(when (not may-kill-p)
(incf (xmtn-automate--session-must-not-kill-counter session))
(xmtn--set-process-query-on-exit-flag
(xmtn-automate--session-process session)
t))
handle)))) handle))))
(defun xmtn-automate--cleanup-command (handle) (defun xmtn-automate--cleanup-command (handle)
(unless xmtn-automate--*preserve-buffers-for-debugging* (unless xmtn-automate--*preserve-buffers-for-debugging*
(kill-buffer (xmtn-automate--command-handle-buffer handle)))) (kill-buffer (xmtn-automate--command-handle-buffer handle))))
(defsubst xmtn-automate--process-new-output--copy (session) (defun xmtn-automate--process-new-output--copy (session)
"Copy SESSION current packet output to command output or error buffer.
Return non-nil if some text copied."
(let* ((session-buffer (xmtn-automate--session-buffer session)) (let* ((session-buffer (xmtn-automate--session-buffer session))
(state (xmtn-automate--session-decoder-state session)) (state (xmtn-automate--session-decoder-state session))
(read-marker (xmtn-automate--decoder-state-read-marker state))
(command (first (xmtn-automate--session-remaining-command-handles (command (first (xmtn-automate--session-remaining-command-handles
session))) session)))
(command-output-buffer (output-buffer
(xmtn-automate--command-handle-buffer command)) (ecase (xmtn-automate--decoder-state-stream state)
(?m
(xmtn-automate--command-handle-buffer command))
((?e ?w ?p ?t)
;; probably ought to do something else with p and t, but
;; this is good enough for now.
(get-buffer-create (format dvc-error-buffer 'xmtn)))))
(write-marker (write-marker
(xmtn-automate--command-handle-write-marker command))) (xmtn-automate--command-handle-write-marker command)))
(xmtn--assert-optional (not (xmtn-automate--session-sent-kill-p session)))
(with-current-buffer session-buffer (with-current-buffer session-buffer
(let* ((end (min (+ read-marker (let* ((end (min (+ (xmtn-automate--decoder-state-read-marker state)
(xmtn-automate--decoder-state-remaining-chars state)) (xmtn-automate--decoder-state-remaining-chars state))
(point-max))) (point-max)))
(chars-to-read (- end read-marker))) (chars-to-read (- end (xmtn-automate--decoder-state-read-marker state))))
(cond (cond
((= chars-to-read 0) ((= chars-to-read 0)
nil) nil)
((> chars-to-read 0) ((> chars-to-read 0)
(if (not (buffer-live-p command-output-buffer)) (if (not (buffer-live-p output-buffer))
;; Buffer has already been killed, just discard input. ;; Buffer has already been killed, just discard input.
(progn) t
(with-current-buffer command-output-buffer (with-current-buffer output-buffer
(save-excursion (save-excursion
(goto-char write-marker) (goto-char write-marker)
(let ((inhibit-read-only t) (let ((inhibit-read-only t)
deactivate-mark) deactivate-mark)
(insert-buffer-substring-no-properties session-buffer (insert-buffer-substring-no-properties session-buffer
read-marker (xmtn-automate--decoder-state-read-marker state)
end)) end))
(set-marker write-marker (point)))) (set-marker write-marker (point))))
;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil) ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil)
) )
(set-marker read-marker end) (setf (xmtn-automate--decoder-state-read-marker state) end)
(decf (xmtn-automate--decoder-state-remaining-chars state) (decf (xmtn-automate--decoder-state-remaining-chars state)
chars-to-read) chars-to-read)
t) t)
(t (xmtn--assert-nil)))))) )))))
;; Return value matters!
)
(defun xmtn--debug-mark-text-processed (buffer start end bold-p) (defun xmtn--debug-mark-text-processed (buffer start end bold-p)
(xmtn--assert-optional (< start end) t) (xmtn--assert-optional (< start end) t)
@ -541,183 +521,86 @@ the buffer."
(add-text-properties start end '(face (:strike-through (add-text-properties start end '(face (:strike-through
t)))))))) t))))))))
(defsubst xmtn-automate--process-new-output (session new-string) (defun xmtn-automate--process-new-output (session)
(let* ((session-buffer (xmtn-automate--session-buffer session)) (let* ((state (xmtn-automate--session-decoder-state session))
(state (xmtn-automate--session-decoder-state session))
(read-marker (xmtn-automate--decoder-state-read-marker state))
(write-marker (process-mark (xmtn-automate--session-process session))) (write-marker (process-mark (xmtn-automate--session-process session)))
(tag 'check-for-more)) (tag 'check-for-more))
(with-current-buffer session-buffer (with-current-buffer (xmtn-automate--session-buffer session)
;; Why oh why doesn't (require 'cl) provide tagbody...
(loop (loop
for command = (first (xmtn-automate--session-remaining-command-handles for command = (first (xmtn-automate--session-remaining-command-handles
session)) session))
do do
(xmtn--assert-optional (or (eql tag 'exit-loop)
(not (xmtn-automate--session-sent-kill-p
session))))
(ecase tag (ecase tag
(check-for-more (check-for-more
(xmtn--assert-optional (<= read-marker write-marker) t) (if (= (xmtn-automate--decoder-state-read-marker state) write-marker)
(if (= read-marker write-marker)
(setq tag 'exit-loop) (setq tag 'exit-loop)
(setq tag 'again))) (setq tag 'again)))
(again (again
(cond (cond
((> (xmtn-automate--decoder-state-remaining-chars state) 0) ((> (xmtn-automate--decoder-state-remaining-chars state) 0)
;; copy more output from the current packet
(if (xmtn-automate--process-new-output--copy session) (if (xmtn-automate--process-new-output--copy session)
(setq tag 'again) (setq tag 'again)
(setq tag 'check-for-more))) (setq tag 'check-for-more)))
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0)
(xmtn-automate--decoder-state-last-p state)) (t
(xmtn--assert-optional command) ;; new packet
(setf (xmtn-automate--command-handle-finished-p command) t) (goto-char (xmtn-automate--decoder-state-read-marker state))
(with-no-warnings ;; A packet has the structure:
;; discard result ;; <command number>:<stream>:<size>:<output>
(pop (xmtn-automate--session-remaining-command-handles session))) ;; Streams are:
(setq tag 'check-for-more) ;; m main
(when (not (xmtn-automate--command-handle-may-kill-p command)) ;; e error
(when (zerop (decf (xmtn-automate--session-must-not-kill-counter ;; w warning
session))) ;; p progress
(xmtn--set-process-query-on-exit-flag ;; t ticker
(xmtn-automate--session-process session) ;; l last
nil) ;;
(when (xmtn-automate--session-closed-p session) ;; If size is large, we may not have all of the output in new-string
(xmtn-automate--session-send-process-kill session) (cond
(setq tag 'exit-loop)))) ((looking-at "\\([0-9]+\\):\\([mewptl]\\):\\([0-9]+\\):")
(setf (xmtn-automate--decoder-state-last-p state) nil)) (let ((command-number (parse-integer (match-string 1)))
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0) (stream (aref (match-string 2) 0))
(not (xmtn-automate--decoder-state-last-p state))) (size (parse-integer (match-string 3))))
(unless command (setf (xmtn-automate--decoder-state-read-marker state) (match-end 0))
(error "Unexpected output from mtn: %s" new-string)) (setf (xmtn-automate--decoder-state-stream state) stream)
(save-excursion (ecase stream
(goto-char read-marker) ((?m ?e ?w ?t ?p)
(cond ((looking-at (setf (xmtn-automate--decoder-state-remaining-chars state) size)
"\\([0-9]+\\):\\([012]\\):\\([lm]\\):\\([0-9]+\\):") (setq tag 'again) )
(let ((command-number (parse-integer (match-string 1)))
(error-code (parse-integer (match-string 2))) (?l
(last-p (cond (setf (xmtn-automate--decoder-state-read-marker state) (+ size (match-end 0)))
((string= (match-string 3) "l") t) (setf (xmtn-automate--command-handle-error-code command)
((string= (match-string 3) "m") nil) (parse-integer
(t (xmtn--assert-nil)))) (buffer-substring-no-properties
(size (parse-integer (match-string 4)))) (match-end 0) (xmtn-automate--decoder-state-read-marker state)) ))
(xmtn--assert-optional (typep command-number (setf (xmtn-automate--command-handle-finished-p command) t)
'(integer 0 *)) (with-no-warnings
t) ;; suppress compiler warning about discarding result
(xmtn--assert-optional (typep error-code '(member 0 1 2)) (pop (xmtn-automate--session-remaining-command-handles session)))
t) (if (xmtn-automate--session-closed-p session)
(xmtn--assert-optional (typep size '(integer 0 *)) t) (setq tag 'exit-loop)
(xmtn--assert-optional (setq tag 'check-for-more))
(eql )
command-number )))
(xmtn-automate--command-handle-mtn-command-number
command))) (t
(setf (xmtn-automate--command-handle-error-code command) ;; Not a packet. Most likely we are at the end of the
error-code) ;; buffer, and there is more output coming soon. FIXME:
(setf (xmtn-automate--decoder-state-remaining-chars ;; this means the loop logic screwed up.
state) (if (= (point) (point-max))
size) (setq tag 'exit-loop)
(setf (xmtn-automate--decoder-state-last-p state) (error "Unexpected output from mtn at '%s':%d:'%s'"
last-p) (current-buffer)
;;(xmtn--debug-mark-text-processed session-buffer (point)
;; read-marker (buffer-substring (point) (line-end-position)))))))))
;; (match-end 0)
;; t)
(set-marker read-marker (match-end 0)))
(setq tag 'again))
;; This is just a simple heuristic, there are many
;; kinds of invalid input that it doesn't detect.
;; FIXME: This can errorneously be triggered by
;; warnings that mtn prints on stderr; but Emacs
;; interleaves stdout and stderr (see (elisp)
;; Output from Processes) with no way to
;; distinguish between them. We'll probably have
;; to spawn mtn inside a shell that redirects
;; stderr to a file. But I don't think that's
;; possible in a portable way...
((looking-at "[^0-9]")
(error "Invalid output from mtn: %s"
(buffer-substring-no-properties (point)
(point-max))))
(t
(xmtn--assert-optional command)
(setq tag 'exit-loop)))))
(t (xmtn--assert-nil))))
(exit-loop (return)))))) (exit-loop (return))))))
nil) nil)
(defvar xmtn-automate--*preserve-buffers-for-debugging* nil) (defvar xmtn-automate--*preserve-buffers-for-debugging* nil)
(defun xmtn-automate--process-sentinel (process event-string)
(let ((status (process-status process))
(session (xmtn-automate--process-session process)))
(let ((buffer (xmtn-automate--session-buffer session)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(let ((inhibit-read-only t)
deactivate-mark)
(save-excursion
;; This seems to fail in XEmacs when running the test
;; `file-diff'. I don't know why.
(xmtn--assert-optional (marker-position (process-mark process))
t)
(goto-char (process-mark process))
(insert (format "\n(process exited: %S)\n"
(if (eql (aref event-string
(1- (length event-string)))
?\n)
(subseq event-string 0
(1- (length event-string)))
event-string)))
(set-marker (process-mark process) (point))))))
(flet ((reclaim-buffer ()
(unless xmtn-automate--*preserve-buffers-for-debugging*
;; Maybe it's not such a good idea to kill the buffer
;; from here since that will run `kill-buffer-hook',
;; and the functions in there might not be prepared to
;; run inside a sentinel. But let's wait until someone
;; actually encounters this problem.
(kill-buffer buffer)
)))
(ecase status
(exit
(xmtn--assert-optional (eql (process-exit-status process) 0) t)
(reclaim-buffer))
(signal
(if (xmtn-automate--session-sent-kill-p session)
(reclaim-buffer)
(message "Process %s died due to signal" (process-name process))
(when (not (zerop (xmtn-automate--session-must-not-kill-counter
session)))
(lwarn
'xmtn ':error
"Process %s died due to signal during a critical operation"
(process-name process))))))))))
(defun xmtn-automate--process-filter (process input-string)
(let ((session (xmtn-automate--process-session process)))
(let ((buffer (xmtn-automate--session-buffer session)))
(xmtn--assert-optional (eql (process-buffer process) buffer))
(xmtn--assert-optional (buffer-live-p buffer))
(with-current-buffer buffer
(let* ((mark (process-mark process))
(move-point-p (= (point) mark)))
(save-excursion
(goto-char mark)
(let ((inhibit-read-only t)
deactivate-mark)
(insert input-string))
(set-marker mark (point)))
(when move-point-p (goto-char mark))))
;;(with-local-quit ; For debugging.
;; Emacs receives a message "mtn: operation canceled: Interrupt"
;; from mtn after we kill it. Ignore such "input".
(unless (xmtn-automate--session-sent-kill-p session)
(xmtn-automate--process-new-output session input-string))
;;)
)))
(defun xmtn--map-parsed-certs (xmtn--root xmtn--revision-hash-id xmtn--thunk) (defun xmtn--map-parsed-certs (xmtn--root xmtn--revision-hash-id xmtn--thunk)
(lexical-let ((root xmtn--root) (lexical-let ((root xmtn--root)
(revision-hash-id xmtn--revision-hash-id) (revision-hash-id xmtn--revision-hash-id)
@ -728,7 +611,7 @@ the buffer."
for xmtn--stanza = (funcall xmtn--next-stanza) for xmtn--stanza = (funcall xmtn--next-stanza)
while xmtn--stanza while xmtn--stanza
do (xmtn-match xmtn--stanza do (xmtn-match xmtn--stanza
((("key" (string $xmtn--key)) ((("key" (id $xmtn--key))
("signature" (string $xmtn--signature)) ("signature" (string $xmtn--signature))
("name" (string $xmtn--name)) ("name" (string $xmtn--name))
("value" (string $xmtn--value)) ("value" (string $xmtn--value))
@ -778,18 +661,39 @@ Each element of the list is a list; key, signature, name, value, trust."
(defun xmtn--tree-default-branch (root) (defun xmtn--tree-default-branch (root)
(xmtn-automate-simple-command-output-line root `("get_option" "branch"))) (xmtn-automate-simple-command-output-line root `("get_option" "branch")))
(defun xmtn--get-corresponding-path-raw (root normalized-file-name
source-revision-hash-id
target-revision-hash-id)
"Given NORMALIZED-FILE-NAME in SOURCE-REVISION-HASH-ID, return file name in TARGET-REVISION-HASH-ID"
(check-type normalized-file-name string)
(xmtn--with-automate-command-output-basic-io-parser
(next-stanza root `("get_corresponding_path"
,source-revision-hash-id
,normalized-file-name
,target-revision-hash-id))
(xmtn-match (funcall next-stanza)
(nil nil)
((("file" (string $result)))
(assert (null (funcall next-stanza)))
result))))
(defun xmtn-automate-local-changes (work) (defun xmtn-automate-local-changes (work)
"Summary of status for WORK; 'ok if no changes, 'need-commit if changes." "Summary of status for WORK; 'ok if no changes, 'need-commit if changes."
(message "checking %s for local changes" work) (let ((default-directory work)
(let ((default-directory work)) (msg "checking %s for local changes ..."))
(message msg work)
(let ((result (xmtn-automate-simple-command-output-string (let ((result (xmtn-automate-simple-command-output-string
default-directory default-directory
(list (list "no-unchanged" "no-ignored") (list (list "no-unchanged" "" "no-ignored" "")
"inventory")))) "inventory"))))
(if (> (length result) 0)
'need-commit (message (concat msg " done") work)
'ok))))
(if (> (length result) 0)
'need-commit
'ok))))
(provide 'xmtn-automate) (provide 'xmtn-automate)

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

@ -1,6 +1,6 @@
;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone ;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone
;; Copyright (C) 2008 - 2009 Stephen Leake ;; Copyright (C) 2008 - 2010 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -73,7 +73,7 @@
(defvar xmtn-conflicts-ancestor-revision "" (defvar xmtn-conflicts-ancestor-revision ""
"Buffer-local variable holding ancestor revision id.") "Buffer-local variable holding ancestor revision id.")
(make-variable-buffer-local 'xmtn-conflicts-ancestor-revision-spec) (make-variable-buffer-local 'xmtn-conflicts-ancestor-revision)
(defvar xmtn-conflicts-total-count nil (defvar xmtn-conflicts-total-count nil
"Total count of conflicts.") "Total count of conflicts.")
@ -226,7 +226,7 @@ header."
;; right_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex" ;; right_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex"
;; right_file_id [d1eee768379694a59b2b015dd59a61cf67505182] ;; right_file_id [d1eee768379694a59b2b015dd59a61cf67505182]
;; ;;
;; optional resolution: {resolved_internal | resolved_user} ;; optional resolution: {resolved_internal | resolved_user_left}
(let ((conflict (make-xmtn-conflicts-conflict))) (let ((conflict (make-xmtn-conflicts-conflict)))
(setf (xmtn-conflicts-conflict-conflict_type conflict) 'content) (setf (xmtn-conflicts-conflict-conflict_type conflict) 'content)
(xmtn-basic-io-check-line "node_type" (xmtn-basic-io-check-line "node_type"
@ -250,7 +250,7 @@ header."
(setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count)) (setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count))
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal))) (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal)))
((string= "resolved_user" symbol) ((string= "resolved_user_left" symbol)
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user (cadar value)))) (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user (cadar value))))
(t (t
@ -523,7 +523,7 @@ header."
(insert "resolved_keep_left \n")) (insert "resolved_keep_left \n"))
(resolved_user (resolved_user
(xmtn-basic-io-write-str "resolved_user" (cadr (xmtn-conflicts-conflict-left_resolution conflict)))) (xmtn-basic-io-write-str "resolved_user_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict))))
)))) ))))
(defun xmtn-conflicts-write-duplicate_name (conflict) (defun xmtn-conflicts-write-duplicate_name (conflict)
@ -735,9 +735,7 @@ header."
(ediff-dispose-of-variant-according-to-user ediff-buffer-A 'A nil nil) (ediff-dispose-of-variant-according-to-user ediff-buffer-A 'A nil nil)
(ediff-dispose-of-variant-according-to-user ediff-buffer-B 'B nil nil) (ediff-dispose-of-variant-according-to-user ediff-buffer-B 'B nil nil)
(ediff-dispose-of-variant-according-to-user ediff-ancestor-buffer 'Ancestor nil nil) (ediff-dispose-of-variant-according-to-user ediff-ancestor-buffer 'Ancestor nil nil)
(save-excursion (with-current-buffer ediff-buffer-C (save-buffer))
(set-buffer ediff-buffer-C)
(save-buffer))
(ediff-kill-buffer-carefully ediff-buffer-C) (ediff-kill-buffer-carefully ediff-buffer-C)
(let ((control-buffer ediff-control-buffer)) (let ((control-buffer ediff-control-buffer))
@ -763,13 +761,13 @@ header."
(set-window-configuration window-config) (set-window-configuration window-config)
(set-buffer control-buffer)))) (set-buffer control-buffer))))
(defun xmtn-conflicts-get-file (file-id dir file-name) (defun xmtn-conflicts-get-file (work file-id dir file-name)
"Get contents of FILE-ID into DIR/FILE-NAME. Return full file name." "Get contents of FILE-ID into DIR/FILE-NAME. Return full file name."
(let ((file (concat (file-name-as-directory dir) file-name))) (let ((file (concat (file-name-as-directory dir) file-name)))
(setq dir (file-name-directory file)) (setq dir (file-name-directory file))
(unless (file-exists-p dir) (unless (file-exists-p dir)
(make-directory dir t)) (make-directory dir t))
(xmtn--get-file-by-id default-directory file-id file) (xmtn--get-file-by-id work file-id file)
file)) file))
(defun xmtn-conflicts-resolve-ediff (side) (defun xmtn-conflicts-resolve-ediff (side)
@ -791,13 +789,16 @@ header."
;; ;;
;; duplicate_name conflicts have no ancestor. ;; duplicate_name conflicts have no ancestor.
(let ((file-ancestor (and (xmtn-conflicts-conflict-ancestor_file_id conflict) (let ((file-ancestor (and (xmtn-conflicts-conflict-ancestor_file_id conflict)
(xmtn-conflicts-get-file (xmtn-conflicts-conflict-ancestor_file_id conflict) (xmtn-conflicts-get-file default-directory
(xmtn-conflicts-conflict-ancestor_file_id conflict)
"_MTN/resolutions/ancestor" "_MTN/resolutions/ancestor"
(xmtn-conflicts-conflict-ancestor_name conflict)))) (xmtn-conflicts-conflict-ancestor_name conflict))))
(file-left (xmtn-conflicts-get-file (xmtn-conflicts-conflict-left_file_id conflict) (file-left (xmtn-conflicts-get-file xmtn-conflicts-left-work
(xmtn-conflicts-conflict-left_file_id conflict)
xmtn-conflicts-left-root xmtn-conflicts-left-root
(xmtn-conflicts-conflict-left_name conflict))) (xmtn-conflicts-conflict-left_name conflict)))
(file-right (xmtn-conflicts-get-file (xmtn-conflicts-conflict-right_file_id conflict) (file-right (xmtn-conflicts-get-file xmtn-conflicts-right-work
(xmtn-conflicts-conflict-right_file_id conflict)
xmtn-conflicts-right-root xmtn-conflicts-right-root
(xmtn-conflicts-conflict-right_name conflict))) (xmtn-conflicts-conflict-right_name conflict)))

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

@ -1,6 +1,6 @@
;;; xmtn-dvc.el --- DVC backend for monotone ;;; xmtn-dvc.el --- DVC backend for monotone
;; Copyright (C) 2008 - 2009 Stephen Leake ;; Copyright (C) 2008 - 2010 Stephen Leake
;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler ;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -71,26 +71,23 @@
(dvc-register-dvc 'xmtn "monotone") (dvc-register-dvc 'xmtn "monotone")
(defmacro* xmtn--with-automate-command-output-basic-io-parser (defmacro* xmtn--with-automate-command-output-basic-io-parser
((parser root-form command-form &key ((:may-kill-p may-kill-p-form))) ((parser root-form command-form)
&body body) &body body)
(declare (indent 1) (debug (sexp body))) (declare (indent 1) (debug (sexp body)))
(let ((parser-tmp (gensym)) (let ((root (gensym))
(root (gensym))
(command (gensym)) (command (gensym))
(may-kill-p (gensym))
(session (gensym)) (session (gensym))
(handle (gensym))) (handle (gensym)))
`(let ((,root ,root-form) `(let ((,root ,root-form)
(,command ,command-form) (,command ,command-form))
(,may-kill-p ,may-kill-p-form))
(let* ((,session (xmtn-automate-cache-session ,root)) (let* ((,session (xmtn-automate-cache-session ,root))
(,handle (xmtn-automate--new-command ,session ,command ,may-kill-p))) (,handle (xmtn-automate--new-command ,session ,command)))
(xmtn-automate-command-check-for-and-report-error ,handle)
(xmtn-automate-command-wait-until-finished ,handle) (xmtn-automate-command-wait-until-finished ,handle)
(xmtn-basic-io-with-stanza-parser (,parser (prog1
(xmtn-automate-command-buffer (xmtn-basic-io-with-stanza-parser
,handle)) (,parser (xmtn-automate-command-buffer ,handle))
,@body))))) ,@body)
(xmtn-automate--cleanup-command ,handle))))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-log-edit-file-name-func (&optional root) (defun xmtn-dvc-log-edit-file-name-func (&optional root)
@ -136,7 +133,7 @@ the file before saving."
(concat "--message-file=" log-edit-file)))) (concat "--message-file=" log-edit-file))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-log-edit-done () (defun xmtn-dvc-log-edit-done (&optional prompt-branch)
(let* ((root default-directory) (let* ((root default-directory)
(files (or (with-current-buffer dvc-partner-buffer (files (or (with-current-buffer dvc-partner-buffer
(dvc-current-file-list 'nil-if-none-marked)) (dvc-current-file-list 'nil-if-none-marked))
@ -153,7 +150,14 @@ the file before saving."
(excluded-files (excluded-files
(with-current-buffer dvc-partner-buffer (with-current-buffer dvc-partner-buffer
(xmtn--normalize-file-names root (dvc-fileinfo-excluded-files)))) (xmtn--normalize-file-names root (dvc-fileinfo-excluded-files))))
(branch (xmtn--tree-default-branch root))) (branch (if prompt-branch
(progn
;; an automate session caches the original
;; options, and will not use the new branch.
(let ((session (xmtn-automate-get-cached-session (dvc-uniquify-file-name root))))
(if session (xmtn-automate--close-session session)))
(read-from-minibuffer "branch: " (xmtn--tree-default-branch root)))
(xmtn--tree-default-branch root))))
;; Saving the buffer will automatically delete any log edit hints. ;; Saving the buffer will automatically delete any log edit hints.
(save-buffer) (save-buffer)
(dvc-save-some-buffers root) (dvc-save-some-buffers root)
@ -167,7 +171,7 @@ the file before saving."
;; We used to check for things that would make commit fail; ;; We used to check for things that would make commit fail;
;; missing files, nothing to commit. But that just slows things ;; missing files, nothing to commit. But that just slows things
;; down in the typical case; better to just handle the error ;; down in the typical case; better to just handle the error
;; message, which is way more informative anyway. ;; message, which is nicely informative anyway.
(lexical-let* ((progress-message (lexical-let* ((progress-message
(case normalized-files (case normalized-files
(all (format "Committing all files in %s" root)) (all (format "Committing all files in %s" root))
@ -183,6 +187,7 @@ the file before saving."
root root
`("commit" ,(xmtn-dvc-log-message) `("commit" ,(xmtn-dvc-log-message)
,(concat "--branch=" branch) ,(concat "--branch=" branch)
"--non-interactive"
,@(case normalized-files ,@(case normalized-files
(all (all
(if excluded-files (if excluded-files
@ -206,8 +211,11 @@ the file before saving."
;; commit was successful. Let's not interfere with ;; commit was successful. Let's not interfere with
;; that. (Calling `dvc-log-close' would.) ;; that. (Calling `dvc-log-close' would.)
;; we'd like to delete log-edit-buffer here, but ;; we'd like to delete log-edit-buffer here, but we
;; we can't do that from a process sentinel ;; can't do that from a process sentinel. And we'd
;; have to find it; it may not be current buffer,
;; if log-edit-done was invoked from the ediff
;; window.
(dvc-diff-clear-buffers 'xmtn (dvc-diff-clear-buffers 'xmtn
default-directory default-directory
@ -293,11 +301,7 @@ the file before saving."
:dir (file-name-directory path) :dir (file-name-directory path)
:file (file-name-nondirectory path) :file (file-name-nondirectory path)
:status status :status status
:more-status (if orig-path :more-status (or orig-path ""))))))
(if (eq status 'rename-target)
(concat "from " orig-path)
(concat "to " orig-path))
""))))))
(likely-dir-p (path) (string-match "/\\'" path))) (likely-dir-p (path) (string-match "/\\'" path)))
;; First parse the basic_io contained in dvc-header, if any. ;; First parse the basic_io contained in dvc-header, if any.
@ -1070,7 +1074,7 @@ finished."
;; the user won't see. So check that here - it's fast. ;; the user won't see. So check that here - it's fast.
;; Don't throw an error; upper level might be doing other directories as well. ;; Don't throw an error; upper level might be doing other directories as well.
(if (and check-id-p (if (and check-id-p
(equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id)) (equal (xmtn--get-base-revision-hash-id-or-null root) target-revision-hash-id))
(progn (progn
(unless no-ding (ding)) (unless no-ding (ding))
(message "Tree %s is already based on target revision %s" (message "Tree %s is already based on target revision %s"
@ -1087,7 +1091,9 @@ finished."
(let* ((branch (xmtn--tree-default-branch root)) (let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch))) (heads (xmtn--heads root branch)))
(case (length heads) (case (length heads)
(0 (assert nil)) (0
(error "branch %s has no revisions" branch))
(1 (1
(xmtn--update root (first heads) t no-ding)) (xmtn--update root (first heads) t no-ding))
@ -1133,24 +1139,20 @@ finished."
(lambda () (lambda ()
(xmtn--refresh-status-header display-buffer) (xmtn--refresh-status-header display-buffer)
(message "%s... done" msg))) (message "%s... done" msg)))
(xmtn--run-command-sync (xmtn--run-command-sync root cmd)
root cmd (xmtn--refresh-status-header display-buffer)
:finished (lambda (output error status arguments) (message "%s... done" msg)))))
(xmtn--refresh-status-header display-buffer)
(message "%s... done" msg)))))))
(defun xmtn-dvc-merge-1 (root refresh-status) (defun xmtn-dvc-merge-1 (root refresh-status)
(lexical-let ((refresh-status refresh-status)) (xmtn--run-command-sync
(xmtn--run-command-async root
root (list
(list "merge"
"merge" (if (file-exists-p (concat root "/_MTN/conflicts"))
(if (file-exists-p (concat root "/_MTN/conflicts")) "--resolve-conflicts-file=_MTN/conflicts")
"--resolve-conflicts-file=_MTN/conflicts") (xmtn-dvc-log-message)))
(xmtn-dvc-log-message)) (if refresh-status
:finished (lambda (output error status arguments) (xmtn--refresh-status-header (current-buffer))))
(if refresh-status
(xmtn--refresh-status-header (current-buffer)))))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-merge (&optional other) (defun xmtn-dvc-merge (&optional other)
@ -1193,20 +1195,16 @@ finished."
(let ((root (dvc-tree-root))) (let ((root (dvc-tree-root)))
(assert (not (endp file-names))) (assert (not (endp file-names)))
(dvc-save-some-buffers root) (dvc-save-some-buffers root)
(let ((normalized-file-names (xmtn--normalize-file-names root file-names))) (let ((normalized-file-names (xmtn--normalize-file-names root file-names))
(lexical-let (progress-message
((root root) (if (eql (length file-names) 1)
(progress-message (format "Reverting file %s" (first file-names))
(if (eql (length file-names) 1) (format "Reverting %s files" (length file-names)))))
(format "Reverting file %s" (first file-names)) (message "%s..." progress-message)
(format "Reverting %s files" (length file-names))))) (xmtn--run-command-sync root `("revert" "--"
(message "%s..." progress-message) ,@normalized-file-names))
(xmtn--run-command-sync root `("revert" "--" (message "%s... done" progress-message))
,@normalized-file-names) (dvc-revert-some-buffers root))
:finished
(lambda (output error status arguments)
(message "%s... done" progress-message)))
(dvc-revert-some-buffers root))))
nil) nil)
;;;###autoload ;;;###autoload
@ -1222,48 +1220,38 @@ finished."
(xmtn--revision-get-file-helper file `(revision ,@stuff))) (xmtn--revision-get-file-helper file `(revision ,@stuff)))
(defun xmtn--revision-get-file-helper (file backend-id) (defun xmtn--revision-get-file-helper (file backend-id)
"Fill current buffer with the contents of FILE revision BACKEND-ID." "Fill current buffer with the contents of FILE in revision BACKEND-ID."
(let ((root (dvc-tree-root))) (let ((root (dvc-tree-root)))
(let* ((normalized-file (xmtn--normalize-file-name root file)) (let ((normalized-file (xmtn--normalize-file-name root file))
(corresponding-file (temp-dir nil))
(xmtn--get-corresponding-path root normalized-file (unwind-protect
`(local-tree ,root) backend-id))) (progn
(if (null corresponding-file) (setq temp-dir (make-temp-file
;; File doesn't exist. Since this function is (as far "xmtn--revision-get-file-" t))
;; as I know) only called from diff-like functions, a ;; Going through a temporary file and using
;; missing file is not an error but just means the diff ;; `insert-file-contents' in conjunction with as
;; should be computed against an empty file. So just ;; much of the original file name as possible seems
;; leave the buffer empty. ;; to be the best way to make sure that Emacs'
(progn) ;; entire file coding system detection logic is
(let ((temp-dir nil)) ;; applied. Functions like
(unwind-protect ;; `find-operation-coding-system' and
(progn ;; `find-file-name-handler' are not a complete
(setq temp-dir (make-temp-file ;; replacement since they don't look at the contents
"xmtn--revision-get-file-" t)) ;; at all.
;; Going through a temporary file and using (let ((temp-file (concat temp-dir "/" normalized-file)))
;; `insert-file-contents' in conjunction with as (make-directory (file-name-directory temp-file) t)
;; much of the original file name as possible seems (with-temp-file temp-file
;; to be the best way to make sure that Emacs' (set-buffer-multibyte nil)
;; entire file coding system detection logic is (setq buffer-file-coding-system 'binary)
;; applied. Functions like (xmtn--insert-file-contents-by-name root backend-id normalized-file (current-buffer)))
;; `find-operation-coding-system' and (let ((output-buffer (current-buffer)))
;; `find-file-name-handler' are not a complete (with-temp-buffer
;; replacement since they don't look at the contents (insert-file-contents temp-file)
;; at all. (let ((input-buffer (current-buffer)))
(let ((temp-file (concat temp-dir "/" corresponding-file))) (with-current-buffer output-buffer
(make-directory (file-name-directory temp-file) t) (insert-buffer-substring input-buffer)))))))
(with-temp-file temp-file (when temp-dir
(set-buffer-multibyte nil) (dvc-delete-recursively temp-dir))))))
(setq buffer-file-coding-system 'binary)
(xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
(let ((output-buffer (current-buffer)))
(with-temp-buffer
(insert-file-contents temp-file)
(let ((input-buffer (current-buffer)))
(with-current-buffer output-buffer
(insert-buffer-substring input-buffer)))))))
(when temp-dir
(dvc-delete-recursively temp-dir))))))))
(defun xmtn--get-file-by-id (root file-id save-as) (defun xmtn--get-file-by-id (root file-id save-as)
"Store contents of FILE-ID in file SAVE-AS." "Store contents of FILE-ID in file SAVE-AS."
@ -1341,25 +1329,12 @@ finished."
`(,id ,normalized-file)))) `(,id ,normalized-file))))
last-n)))) last-n))))
(defun xmtn--get-corresponding-path-raw (root normalized-file-name
source-revision-hash-id
target-revision-hash-id)
(check-type normalized-file-name string)
(xmtn--with-automate-command-output-basic-io-parser
(next-stanza root `("get_corresponding_path"
,source-revision-hash-id
,normalized-file-name
,target-revision-hash-id))
(xmtn-match (funcall next-stanza)
(nil nil)
((("file" (string $result)))
(assert (null (funcall next-stanza)))
result))))
(defun xmtn--get-corresponding-path (root normalized-file-name (defun xmtn--get-corresponding-path (root normalized-file-name
source-revision-backend-id source-revision-backend-id
target-revision-backend-id) target-revision-backend-id)
;; normalized-file-name is a file in
;; source-revision-backend-id. Return its name in
;; target-revision-backend-id.
(block get-corresponding-path (block get-corresponding-path
(let (source-revision-hash-id (let (source-revision-hash-id
target-revision-hash-id target-revision-hash-id
@ -1382,9 +1357,11 @@ finished."
((local-tree $target-path) ((local-tree $target-path)
(assert (xmtn--same-tree-p path target-path)) (assert (xmtn--same-tree-p path target-path))
(return-from get-corresponding-path normalized-file-name))) (return-from get-corresponding-path normalized-file-name)))
;; Handle an uncommitted rename in the current workspace
(setq normalized-file-name (xmtn--get-rename-in-workspace-to (setq normalized-file-name (xmtn--get-rename-in-workspace-to
path normalized-file-name)) path normalized-file-name))
(setq source-revision-hash-id base-revision-hash-id))))) (setq source-revision-hash-id base-revision-hash-id)))))
(xmtn-match resolved-target-revision (xmtn-match resolved-target-revision
((revision $hash-id) ((revision $hash-id)
(setq target-revision-hash-id hash-id)) (setq target-revision-hash-id hash-id))
@ -1394,8 +1371,9 @@ finished."
(xmtn--get-base-revision-hash-id-or-null path))) (xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id) (if (null base-revision-hash-id)
(return-from get-corresponding-path nil) (return-from get-corresponding-path nil)
(setq target-revision-hash-id base-revision-hash-id (setq target-revision-hash-id base-revision-hash-id)
file-name-postprocessor ;; Handle an uncommitted rename in the current workspace
(setq file-name-postprocessor
(lexical-let ((path path)) (lexical-let ((path path))
(lambda (file-name) (lambda (file-name)
(xmtn--get-rename-in-workspace-from path (xmtn--get-rename-in-workspace-from path
@ -1409,6 +1387,9 @@ finished."
(funcall file-name-postprocessor result)))))) (funcall file-name-postprocessor result))))))
(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name) (defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)
;; Given a workspace ROOT and a file name
;; NORMALIZED-SOURCE-FILE-NAME in the base revision of the
;; workspace, return the current name of that file in the workspace.
;; FIXME: need a better way to implement this ;; FIXME: need a better way to implement this
(check-type normalized-source-file-name string) (check-type normalized-source-file-name string)
(block parse (block parse
@ -1424,6 +1405,10 @@ finished."
normalized-source-file-name)) normalized-source-file-name))
(defun xmtn--get-rename-in-workspace-to (root normalized-target-file-name) (defun xmtn--get-rename-in-workspace-to (root normalized-target-file-name)
;; Given a workspace ROOT and a file name
;; NORMALIZED-TARGET-FILE-NAME in the current revision of the
;; workspace, return the name of that file in the base revision of
;; the workspace.
;; FIXME: need a better way to implement this ;; FIXME: need a better way to implement this
(check-type normalized-target-file-name string) (check-type normalized-target-file-name string)
(block parse (block parse

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

@ -219,7 +219,7 @@ See file commentary for details."
must be a workspace." must be a workspace."
(let* (result (let* (result
(session (xmtn-automate-cache-session default-directory)) (session (xmtn-automate-cache-session default-directory))
(handle (xmtn-automate--new-command session `("certs" ,hash-id) nil))) (handle (xmtn-automate--new-command session `("certs" ,hash-id))))
(xmtn-automate-command-wait-until-finished handle) (xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle) (with-current-buffer (xmtn-automate-command-buffer handle)
;; now in buffer containing basic_io certs; find the branch certs ;; now in buffer containing basic_io certs; find the branch certs

42
dvc/lisp/xmtn-multi-status.el
View File

@ -1,6 +1,6 @@
;;; xmtn-status.el --- manage actions for multiple projects ;;; xmtn-status.el --- manage actions for multiple projects
;; Copyright (C) 2009 Stephen Leake ;; Copyright (C) 2009 - 2010 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -107,16 +107,27 @@ The elements must all be of class xmtn-status-data.")
(if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
(with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer)))) (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer))))
(defun xmtn-status-clean-1 (data)
"Clean DATA workspace."
(xmtn-automate-kill-session (xmtn-status-work data))
(xmtn-status-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-status-work data)))
(defun xmtn-status-clean () (defun xmtn-status-clean ()
"Clean current workspace, delete from ewoc" "Clean current workspace, delete from ewoc"
(interactive) (interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc)) (let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)) (data (ewoc-data elem))
(inhibit-read-only t)) (inhibit-read-only t))
(xmtn-status-kill-conflicts-buffer data) (xmtn-status-clean-1 data)
(xmtn-conflicts-clean (xmtn-status-work data))
(ewoc-delete xmtn-status-ewoc elem))) (ewoc-delete xmtn-status-ewoc elem)))
(defun xmtn-status-quit ()
"Clean all remaining workspaces, kill automate sessions, kill buffer."
(interactive)
(ewoc-map 'xmtn-status-clean-1 xmtn-status-ewoc)
(kill-buffer))
(defun xmtn-status-cleanp () (defun xmtn-status-cleanp ()
"Non-nil if clean & quit is appropriate for current workspace." "Non-nil if clean & quit is appropriate for current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
@ -181,7 +192,10 @@ The elements must all be of class xmtn-status-data.")
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-status-need-refresh elem data) (xmtn-status-need-refresh elem data)
(setf (xmtn-status-data-local-changes data) 'ok) (setf (xmtn-status-data-local-changes data) 'ok)
(xmtn-status (xmtn-status-work data)))) (xmtn-status (xmtn-status-work data))
;; IMPROVEME: create a log-edit buffer now, since we have both a
;; status and conflict buffer, and that confuses dvc-log-edit
))
(defun xmtn-status-status-ok () (defun xmtn-status-status-ok ()
"Ignore local changes in current workspace." "Ignore local changes in current workspace."
@ -223,9 +237,10 @@ The elements must all be of class xmtn-status-data.")
(let* ((elem (ewoc-locate xmtn-status-ewoc)) (let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)) (data (ewoc-data elem))
(default-directory (xmtn-status-work data))) (default-directory (xmtn-status-work data)))
(xmtn-status-need-refresh elem data)
(xmtn-status-save-conflicts-buffer data) (xmtn-status-save-conflicts-buffer data)
(xmtn-dvc-merge-1 default-directory nil))) (xmtn-dvc-merge-1 default-directory nil)
(xmtn-status-refresh-one data nil)
(ewoc-invalidate xmtn-status-ewoc elem)))
(defun xmtn-status-heads () (defun xmtn-status-heads ()
"Run xmtn-heads on current workspace." "Run xmtn-heads on current workspace."
@ -256,16 +271,16 @@ The elements must all be of class xmtn-status-data.")
(define-key map [?5] '(menu-item "5) update" (define-key map [?5] '(menu-item "5) update"
xmtn-status-update xmtn-status-update
:visible (xmtn-status-updatep))) :visible (xmtn-status-updatep)))
(define-key map [?4] '(menu-item "4) xmtn-merge" (define-key map [?4] '(menu-item "4) merge"
xmtn-status-merge xmtn-status-merge
:visible (xmtn-status-headsp))) :visible (xmtn-status-headsp)))
(define-key map [?3] '(menu-item "3) xmtn-heads" (define-key map [?3] '(menu-item "3) show heads"
xmtn-status-heads xmtn-status-heads
:visible (xmtn-status-headsp))) :visible (xmtn-status-headsp)))
(define-key map [?2] '(menu-item "2) resolve conflicts" (define-key map [?2] '(menu-item "2) resolve conflicts"
xmtn-status-resolve-conflicts xmtn-status-resolve-conflicts
:visible (xmtn-status-resolve-conflictsp))) :visible (xmtn-status-resolve-conflictsp)))
(define-key map [?1] '(menu-item "1) dvc-missing" (define-key map [?1] '(menu-item "1) show missing"
xmtn-status-missing xmtn-status-missing
:visible (xmtn-status-missingp))) :visible (xmtn-status-missingp)))
(define-key map [?0] '(menu-item "0) status" (define-key map [?0] '(menu-item "0) status"
@ -283,7 +298,7 @@ The elements must all be of class xmtn-status-data.")
(define-key map [?g] 'xmtn-status-refresh) (define-key map [?g] 'xmtn-status-refresh)
(define-key map [?n] 'xmtn-status-next) (define-key map [?n] 'xmtn-status-next)
(define-key map [?p] 'xmtn-status-prev) (define-key map [?p] 'xmtn-status-prev)
(define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer)))) (define-key map [?q] 'xmtn-status-quit)
map) map)
"Keymap used in `xmtn-multiple-status-mode'.") "Keymap used in `xmtn-multiple-status-mode'.")
@ -430,14 +445,15 @@ The elements must all be of class xmtn-status-data.")
"Show actions to update WORK." "Show actions to update WORK."
(interactive "DStatus for (workspace): ") (interactive "DStatus for (workspace): ")
(pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
(setq default-directory work) ;; allow WORK to be relative, and ensure it is a workspace root
(setq xmtn-status-root (expand-file-name (concat (file-name-as-directory work) "../"))) (setq default-directory (xmtn-tree-root (expand-file-name work)))
(setq xmtn-status-root (expand-file-name (concat (file-name-as-directory default-directory) "../")))
(setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
(ewoc-enter-last xmtn-status-ewoc (ewoc-enter-last xmtn-status-ewoc
(make-xmtn-status-data (make-xmtn-status-data
:work (file-name-nondirectory (directory-file-name work)) :work (file-name-nondirectory (directory-file-name default-directory))
:branch (xmtn--tree-default-branch default-directory) :branch (xmtn--tree-default-branch default-directory)
:need-refresh t :need-refresh t
:heads 'need-scan)) :heads 'need-scan))

41
dvc/lisp/xmtn-propagate.el
View File

@ -1,6 +1,6 @@
;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone ;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone
;; Copyright (C) 2009 Stephen Leake ;; Copyright (C) 2009, 2010 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -53,8 +53,6 @@ The elements must all be of class xmtn-propagate-data.")
to-name ; to-name ;
from-branch ; branch name (assumed never changes) from-branch ; branch name (assumed never changes)
to-branch ; to-branch ;
from-session ; mtn automate session
to-session ;
need-refresh ; nil | t; if an async process was started that invalidates state data need-refresh ; nil | t; if an async process was started that invalidates state data
from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads
to-head-rev ; to-head-rev ;
@ -164,19 +162,29 @@ The elements must all be of class xmtn-propagate-data.")
(if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer)))) (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer))))
(defun xmtn-propagate-clean-1 (data)
"Clean DATA workspace"
(xmtn-automate-kill-session (xmtn-propagate-from-work data))
(xmtn-automate-kill-session (xmtn-propagate-to-work data))
(xmtn-propagate-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data)))
(defun xmtn-propagate-clean () (defun xmtn-propagate-clean ()
"Clean current workspace, delete from ewoc" "Clean current workspace, delete from ewoc"
(interactive) (interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc)) (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
;; only one conflicts file and buffer (xmtn-propagate-clean-1 data)
(xmtn-propagate-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(ewoc-delete xmtn-propagate-ewoc elem)))) (ewoc-delete xmtn-propagate-ewoc elem))))
(defun xmtn-propagate-quit ()
"Clean all remaining workspaces, kill automate sessions, kill buffer."
(interactive)
(ewoc-map 'xmtn-propagate-clean-1 xmtn-propagate-ewoc)
(kill-buffer))
(defun xmtn-propagate-cleanp () (defun xmtn-propagate-cleanp ()
"Non-nil if clean is appropriate for current workspace." "Non-nil if clean is appropriate for current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
@ -406,10 +414,10 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?8] '(menu-item (concat "8) ignore local changes " (xmtn-propagate-from-name)) (define-key map [?8] '(menu-item (concat "8) ignore local changes " (xmtn-propagate-from-name))
xmtn-propagate-status-from-ok xmtn-propagate-status-from-ok
:visible (xmtn-propagate-status-fromp))) :visible (xmtn-propagate-status-fromp)))
(define-key map [?7] '(menu-item (concat "7) dvc-missing " (xmtn-propagate-to-name)) (define-key map [?7] '(menu-item (concat "7) show missing " (xmtn-propagate-to-name))
xmtn-propagate-missing-to xmtn-propagate-missing-to
:visible (xmtn-propagate-missing-top))) :visible (xmtn-propagate-missing-top)))
(define-key map [?6] '(menu-item (concat "6) dvc-missing " (xmtn-propagate-from-name)) (define-key map [?6] '(menu-item (concat "6) show missing " (xmtn-propagate-from-name))
xmtn-propagate-missing-from xmtn-propagate-missing-from
:visible (xmtn-propagate-missing-fromp))) :visible (xmtn-propagate-missing-fromp)))
(define-key map [?5] '(menu-item (concat "5) update " (xmtn-propagate-to-name)) (define-key map [?5] '(menu-item (concat "5) update " (xmtn-propagate-to-name))
@ -424,10 +432,10 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?2] '(menu-item (concat "2) commit " (xmtn-propagate-from-name)) (define-key map [?2] '(menu-item (concat "2) commit " (xmtn-propagate-from-name))
xmtn-propagate-status-from xmtn-propagate-status-from
:visible (xmtn-propagate-status-fromp))) :visible (xmtn-propagate-status-fromp)))
(define-key map [?1] '(menu-item (concat "1) xmtn-heads " (xmtn-propagate-to-name)) (define-key map [?1] '(menu-item (concat "1) show heads " (xmtn-propagate-to-name))
xmtn-propagate-heads-to xmtn-propagate-heads-to
:visible (xmtn-propagate-heads-top))) :visible (xmtn-propagate-heads-top)))
(define-key map [?0] '(menu-item (concat "0) xmtn-heads " (xmtn-propagate-from-name)) (define-key map [?0] '(menu-item (concat "0) show heads " (xmtn-propagate-from-name))
xmtn-propagate-heads-from xmtn-propagate-heads-from
:visible (xmtn-propagate-heads-fromp))) :visible (xmtn-propagate-heads-fromp)))
map) map)
@ -442,7 +450,7 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?g] 'xmtn-propagate-refresh) (define-key map [?g] 'xmtn-propagate-refresh)
(define-key map [?n] 'xmtn-propagate-next) (define-key map [?n] 'xmtn-propagate-next)
(define-key map [?p] 'xmtn-propagate-prev) (define-key map [?p] 'xmtn-propagate-prev)
(define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer)))) (define-key map [?q] 'xmtn-propagate-quit)
map) map)
"Keymap used in `xmtn-propagate-mode'.") "Keymap used in `xmtn-propagate-mode'.")
@ -639,10 +647,7 @@ The elements must all be of class xmtn-propagate-data.")
(defun xmtn-propagate-make-data (from-workspace to-workspace from-name to-name) (defun xmtn-propagate-make-data (from-workspace to-workspace from-name to-name)
"FROM-WORKSPACE, TO-WORKSPACE are relative names" "FROM-WORKSPACE, TO-WORKSPACE are relative names"
(let* ((from-work (concat xmtn-propagate-from-root from-workspace)) (let* ((from-work (concat xmtn-propagate-from-root from-workspace))
;; cached sessions not working (yet)
;;(from-session (xmtn-automate-cache-session from-work))
(to-work (concat xmtn-propagate-to-root to-workspace)) (to-work (concat xmtn-propagate-to-root to-workspace))
;;(to-session (xmtn-automate-cache-session to-work))
) )
(ewoc-enter-last (ewoc-enter-last
@ -654,8 +659,6 @@ The elements must all be of class xmtn-propagate-data.")
:to-name to-name :to-name to-name
:from-branch (xmtn--tree-default-branch from-work) :from-branch (xmtn--tree-default-branch from-work)
:to-branch (xmtn--tree-default-branch to-work) :to-branch (xmtn--tree-default-branch to-work)
:from-session nil ;; from-session
:to-session nil ;; to-session
:need-refresh t)))) :need-refresh t))))
;;;###autoload ;;;###autoload
@ -700,9 +703,7 @@ scanned and all common ones found are used."
(interactive "DPropagate all from (workspace): \nDto (workspace): ") (interactive "DPropagate all from (workspace): \nDto (workspace): ")
(setq from-work (substitute-in-file-name from-work)) (setq from-work (substitute-in-file-name from-work))
(setq to-work (substitute-in-file-name to-work)) (setq to-work (substitute-in-file-name to-work))
(let ((default-directory to-work) (let ((default-directory to-work))
(from-session (xmtn-automate-cache-session from-work))
(to-session (xmtn-automate-cache-session to-work)))
(pop-to-buffer (get-buffer-create "*xmtn-propagate*")) (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
;; default-directory is wrong if buffer is reused ;; default-directory is wrong if buffer is reused
(setq default-directory to-work) (setq default-directory to-work)

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

@ -1,6 +1,6 @@
;;; xmtn-run.el --- Functions for runnning monotone commands ;;; xmtn-run.el --- Functions for runnning monotone commands
;; Copyright (C) 2008 - 2009 Stephen Leake ;; Copyright (C) 2008 - 2010 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -43,7 +43,7 @@
(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix) (define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)
(defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key) (defun* xmtn--run-command-sync (root arguments)
(xmtn--check-cached-command-version) (xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory)))) (let ((default-directory (file-truename (or root default-directory))))
(dvc-run-dvc-sync (dvc-run-dvc-sync
@ -53,8 +53,7 @@
;; necessary since default-directory is set, and it ;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a ;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs. ;; non-Cygwin Emacs.
,@arguments) ,@arguments))))
dvc-run-keys)))
;;; The `dvc-run-dvc-*' functions use `call-process', which, for some ;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
;;; reason, spawns the subprocess with a working directory with all ;;; reason, spawns the subprocess with a working directory with all
@ -112,7 +111,8 @@ Signals an error if more (or fewer) than one line is output."
arguments)) arguments))
(first lines))) (first lines)))
(defconst xmtn--minimum-required-command-version '(0 45)) (defconst xmtn--minimum-required-command-version '(0 46))
(defconst xmtn--required-automate-format-version "2")
(defun xmtn--have-no-ignore () (defun xmtn--have-no-ignore ()
"Non-nil if mtn automate inventory supports --no-ignore, --no-unknown, --no-unchanged options." "Non-nil if mtn automate inventory supports --no-ignore, --no-unknown, --no-unchanged options."