sync with upstream
This commit is contained in:
Kai Tetzlaff
parent
effbe8f128
commit
55f6a1fe09
@ -56,7 +56,6 @@ AC_CONFIG_FILES([Makefile lisp/Makefile texinfo/Makefile dvc-load.el lisp/dvc-si
|
||||
# Common system utilities checking:
|
||||
AC_PROG_MAKE_SET
|
||||
AC_PROG_INSTALL
|
||||
AC_PROG_MKDIR_P
|
||||
|
||||
# External programs checking:
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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>
|
||||
;; Contributions from:
|
||||
@ -659,6 +659,19 @@ just bury it."
|
||||
(dvc-kill-all-type '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))
|
||||
(defun dvc-save-some-buffers (&optional tree)
|
||||
"Save all buffers visiting a file in TREE."
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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>
|
||||
;; 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
|
||||
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.
|
||||
|
||||
MSG must be of the form \"%S is not a ...-managed tree\"."
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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>
|
||||
;; Contributions from:
|
||||
@ -509,15 +509,17 @@ file after."
|
||||
(unless (and (car dvc-diff-base)
|
||||
(car dvc-diff-modified))
|
||||
(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)))
|
||||
|
||||
(if (and on-modified-file
|
||||
(if (and modified-file
|
||||
(dvc-diff-in-ewoc-p))
|
||||
;; on ewoc item; just ediff
|
||||
(dvc-file-ediff-revisions on-modified-file
|
||||
(dvc-file-ediff-revisions modified-file
|
||||
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.
|
||||
(end-of-line)
|
||||
(dvc-trace "loc=%S" loc)
|
||||
@ -530,7 +532,7 @@ file after."
|
||||
(setq hunk (1+ hunk)))
|
||||
(goto-char loc)
|
||||
(with-current-buffer
|
||||
(dvc-file-ediff-revisions on-modified-file
|
||||
(dvc-file-ediff-revisions modified-file
|
||||
dvc-diff-base
|
||||
dvc-diff-modified)
|
||||
(ediff-jump-to-difference hunk))))))
|
||||
@ -560,7 +562,8 @@ interactively."
|
||||
|
||||
(defun dvc-diff-get-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)
|
||||
(dvc-fileinfo-current-file)
|
||||
(save-excursion
|
||||
@ -810,11 +813,12 @@ Useful to clear diff buffers after a commit."
|
||||
(set-auto-mode t)))
|
||||
(dvc-ediff-buffers pristine-buffer file-buffer))))
|
||||
|
||||
(defun dvc-file-ediff-revisions (file base modified)
|
||||
"View changes in FILE between BASE and MODIFIED using ediff."
|
||||
(defun dvc-file-ediff-revisions (file base-rev modified-rev &optional base-file)
|
||||
"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-revision-get-file-in-buffer file base)
|
||||
(dvc-revision-get-file-in-buffer file modified)))
|
||||
(dvc-revision-get-file-in-buffer (or base-file file) base-rev)
|
||||
(dvc-revision-get-file-in-buffer file modified-rev)))
|
||||
|
||||
;;;###autoload
|
||||
(defun dvc-dvc-file-diff (file &optional base modified dont-switch)
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
;;; dvc-fileinfo.el --- An ewoc structure for displaying file information
|
||||
;;; for DVC
|
||||
|
||||
;; Copyright (C) 2007 - 2009 by all contributors
|
||||
;; Copyright (C) 2007 - 2010 by all contributors
|
||||
|
||||
;; 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
|
||||
;; in the index. Use t if the back-end does not
|
||||
;; 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)
|
||||
@ -190,6 +191,12 @@ indicate statuses."
|
||||
(progn
|
||||
(newline)
|
||||
(insert " ")
|
||||
(ecase (dvc-fileinfo-file-status fileinfo)
|
||||
(rename-source
|
||||
(insert "to "))
|
||||
(rename-target
|
||||
(insert "from "))
|
||||
(t nil))
|
||||
(insert (dvc-fileinfo-file-more-status fileinfo))))))
|
||||
|
||||
(dvc-fileinfo-legacy
|
||||
@ -289,11 +296,36 @@ containing a 'file."
|
||||
(defun dvc-fileinfo-current-file ()
|
||||
"Return a string giving the filename (including path from root)
|
||||
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)))
|
||||
(etypecase fileinfo
|
||||
(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
|
||||
(cadr (dvc-fileinfo-legacy-data fileinfo))))))
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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
|
||||
|
||||
;; Author: Christian M. Ohler
|
||||
@ -50,28 +50,18 @@
|
||||
;; `xmtn-automate-new-command' to send commands to monotone.
|
||||
;;
|
||||
;; A COMMAND is a list of strings (the command and its arguments), or
|
||||
;; a cons of lists of strings. If car COMMAND is a list, car COMMAND is
|
||||
;; options (without leading "--"), cdr is the command and arguments.
|
||||
;; a cons of lists of strings. If car COMMAND is a list, car COMMAND
|
||||
;; 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
|
||||
;; handle to check the error code of the command and obtain its
|
||||
;; output. Your Emacs Lisp code can also do other computation while
|
||||
;; the monotone command runs. Allowing this kind of parallelism and
|
||||
;; incremental processing of command output is the main reason for
|
||||
;; introducing command handles.
|
||||
;; the monotone command runs. Allowing this kind of parallelism is
|
||||
;; the main reason for introducing command handles.
|
||||
;;
|
||||
;; The intention behind this protocol is to allow Emacs Lisp code to
|
||||
;; process command output incrementally as it arrives instead of
|
||||
;; 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
|
||||
;; docs/xmtn-readme.txt.
|
||||
|
||||
@ -84,43 +74,25 @@
|
||||
(require 'xmtn-run)
|
||||
(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)
|
||||
(xmtn-automate--command-handle-buffer command))
|
||||
|
||||
(defun xmtn-automate-command-write-marker-position (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)
|
||||
(while (not (xmtn-automate-command-finished-p handle))
|
||||
(xmtn--assert-for-effect (or (xmtn-automate-command-accept-output handle)
|
||||
(xmtn-automate-command-finished-p handle))))
|
||||
(let ((session (xmtn-automate--command-handle-session handle)))
|
||||
(while (not (xmtn-automate--command-handle-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)
|
||||
|
||||
(defvar xmtn-automate--*sessions* '()
|
||||
@ -147,34 +119,24 @@ ROOT, store it in session cache. Return session."
|
||||
workspace root."
|
||||
(cdr (assoc key xmtn-automate--*sessions*)))
|
||||
|
||||
(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle)
|
||||
(xmtn-automate-command-wait-until-finished handle)
|
||||
(defun xmtn-automate--command-output-as-string (handle)
|
||||
(with-current-buffer (xmtn-automate-command-buffer handle)
|
||||
(prog1
|
||||
(buffer-substring-no-properties (point-min) (point-max))
|
||||
(xmtn-automate--cleanup-command handle))))
|
||||
|
||||
(defun xmtn-automate-command-check-for-and-report-error (handle)
|
||||
(unless (eql (xmtn-automate-command-error-code handle) 0)
|
||||
(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)
|
||||
"Send COMMAND to session for ROOT. Return result as a string."
|
||||
(let* ((session (xmtn-automate-cache-session root))
|
||||
(command-handle (xmtn-automate--new-command session command nil)))
|
||||
(xmtn-automate-command-check-for-and-report-error command-handle)
|
||||
(xmtn-automate--command-output-as-string-ignoring-exit-code command-handle)))
|
||||
(command-handle (xmtn-automate--new-command session command)))
|
||||
(xmtn-automate-command-wait-until-finished command-handle)
|
||||
(xmtn-automate--command-output-as-string command-handle)))
|
||||
|
||||
(defun xmtn-automate-simple-command-output-insert-into-buffer
|
||||
(root buffer command)
|
||||
"Send COMMAND to session for ROOT, insert result into BUFFER."
|
||||
(let* ((session (xmtn-automate-cache-session root))
|
||||
(command-handle (xmtn-automate--new-command session command nil)))
|
||||
(xmtn-automate-command-check-for-and-report-error command-handle)
|
||||
(command-handle (xmtn-automate--new-command session command)))
|
||||
(xmtn-automate-command-wait-until-finished command-handle)
|
||||
(with-current-buffer buffer
|
||||
(insert-buffer-substring-no-properties
|
||||
@ -184,10 +146,8 @@ workspace root."
|
||||
(defun xmtn-automate-command-output-lines (handle)
|
||||
"Return list of lines of output in HANDLE; first line output is
|
||||
first in list."
|
||||
(xmtn-automate-command-check-for-and-report-error handle)
|
||||
(xmtn-automate-command-wait-until-finished handle)
|
||||
(save-excursion
|
||||
(set-buffer (xmtn-automate-command-buffer handle))
|
||||
(with-current-buffer (xmtn-automate-command-buffer handle)
|
||||
(goto-char (point-min))
|
||||
(let (result)
|
||||
(while (< (point) (point-max))
|
||||
@ -203,7 +163,7 @@ first in list."
|
||||
"Return list of strings containing output of COMMAND, one line per
|
||||
string."
|
||||
(let* ((session (xmtn-automate-cache-session root))
|
||||
(command-handle (xmtn-automate--new-command session command nil)))
|
||||
(command-handle (xmtn-automate--new-command session command)))
|
||||
(xmtn-automate-command-output-lines command-handle)))
|
||||
|
||||
(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
|
||||
(:constructor xmtn-automate--%make-raw-decoder-state))
|
||||
;; State for decoding stdio output packets.
|
||||
(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)
|
||||
(last-p nil))
|
||||
(stream 0); determines output buffer
|
||||
)
|
||||
|
||||
(defstruct (xmtn-automate--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)
|
||||
(decoder-state)
|
||||
(next-command-number 0)
|
||||
(must-not-kill-counter)
|
||||
(remaining-command-handles)
|
||||
(sent-kill-p)
|
||||
(closed-p nil))
|
||||
|
||||
(defstruct (xmtn-automate--command-handle
|
||||
(:constructor xmtn-automate--%make-raw-command-handle))
|
||||
(arguments)
|
||||
(command)
|
||||
(mtn-command-number)
|
||||
(session-command-number)
|
||||
(session)
|
||||
(buffer)
|
||||
(write-marker)
|
||||
(may-kill-p)
|
||||
(finished-p 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)
|
||||
(let ((process (xmtn-automate--session-process session)))
|
||||
;; Stop parser.
|
||||
(setf (xmtn-automate--session-sent-kill-p session) t)
|
||||
(with-current-buffer (xmtn-automate--session-buffer session)
|
||||
(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))
|
||||
(insert "\n(killing process)\n")
|
||||
(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 (xmtn-automate--session-process session) 'PIPE)
|
||||
|
||||
(signal-process process 'KILL)
|
||||
|
||||
;; This call to `sit-for' is apparently needed in some situations to
|
||||
;; make sure the process really gets killed.
|
||||
(sit-for 0)
|
||||
(interrupt-process process))
|
||||
(sit-for 0))
|
||||
nil)
|
||||
|
||||
(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)))
|
||||
(cond
|
||||
((null process)
|
||||
;; Process died for some reason - most likely 'mtn not found in
|
||||
;; path'. Don't warn if buffer hasn't been deleted; that
|
||||
;; obscures the real error message
|
||||
;; Process was never created or was killed - most likely 'mtn
|
||||
;; not found in path'. Don't warn if buffer hasn't been deleted;
|
||||
;; that obscures the real error message
|
||||
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
|
||||
(process-send-eof process)
|
||||
(if (zerop (xmtn-automate--session-must-not-kill-counter session))
|
||||
(xmtn-automate--session-send-process-kill session)
|
||||
;; We can't kill the buffer yet. We need to dump mtn's output
|
||||
;; in there so we can parse it and determine when the critical
|
||||
;; commands are finished so we can then kill mtn.
|
||||
(dvc-trace
|
||||
"Not killing process %s yet: %s out of %s remaining commands are critical"
|
||||
(process-name process)
|
||||
(xmtn-automate--session-must-not-kill-counter session)
|
||||
(length (xmtn-automate--session-remaining-command-handles session))))
|
||||
(with-current-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)))))
|
||||
(ecase (process-status process)
|
||||
(run
|
||||
(process-send-eof process)
|
||||
(xmtn-automate--session-send-process-kill session)
|
||||
(sleep-for 1.0); let process die before deleting associated buffers
|
||||
)
|
||||
(exit t)
|
||||
(signal t))))
|
||||
|
||||
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
||||
(if (buffer-live-p (xmtn-automate--session-buffer session))
|
||||
(kill-buffer (xmtn-automate--session-buffer session)))))
|
||||
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)
|
||||
(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))
|
||||
(buffer (xmtn-automate--new-buffer 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))
|
||||
(let ((process
|
||||
(apply 'start-process name buffer xmtn-executable
|
||||
"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)
|
||||
(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)
|
||||
;; Need binary (or no-conversion or maybe raw-text-unix?)
|
||||
;; since this is the format in which mtn automate stdio
|
||||
;; computes the size of the output.
|
||||
(set-process-coding-system process 'binary 'binary)
|
||||
(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-sent-kill-p session) nil)
|
||||
process))))
|
||||
@ -399,8 +381,8 @@ the buffer."
|
||||
(goto-char (point-max)))))
|
||||
nil)
|
||||
|
||||
(defun xmtn-automate--send-command-string (session command option-plist session-number)
|
||||
"Send COMMAND and OPTION-PLIST to SESSION."
|
||||
(defun xmtn-automate--send-command-string (session command option-pairs session-number)
|
||||
"Send COMMAND and OPTION-PAIRS to SESSION."
|
||||
(let* ((buffer-name (format "*%s: input for command %s*"
|
||||
(xmtn-automate--session-name session)
|
||||
session-number))
|
||||
@ -419,9 +401,9 @@ the buffer."
|
||||
(set-buffer-multibyte t)
|
||||
(setq buffer-read-only t)
|
||||
(let ((inhibit-read-only t))
|
||||
(when option-plist
|
||||
(when option-pairs
|
||||
(insert "o")
|
||||
(xmtn-automate--append-encoded-strings option-plist)
|
||||
(xmtn-automate--append-encoded-strings option-pairs)
|
||||
(insert "e"))
|
||||
(insert "l")
|
||||
(xmtn-automate--append-encoded-strings command)
|
||||
@ -435,7 +417,7 @@ the buffer."
|
||||
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(defun xmtn-automate--new-command (session command may-kill-p)
|
||||
(defun xmtn-automate--new-command (session command)
|
||||
"Send COMMAND to SESSION."
|
||||
(xmtn-automate--ensure-process session)
|
||||
(let* ((command-number
|
||||
@ -464,67 +446,65 @@ the buffer."
|
||||
(eql (point) (point-max))))
|
||||
(let ((handle (xmtn-automate--%make-raw-command-handle
|
||||
:session session
|
||||
:arguments command
|
||||
:command command
|
||||
:session-command-number command-number
|
||||
:may-kill-p may-kill-p
|
||||
:buffer buffer
|
||||
:write-marker (set-marker (make-marker) (point)))))
|
||||
(setf
|
||||
(xmtn-automate--session-remaining-command-handles session)
|
||||
(nconc (xmtn-automate--session-remaining-command-handles session)
|
||||
(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))))
|
||||
|
||||
(defun xmtn-automate--cleanup-command (handle)
|
||||
(unless xmtn-automate--*preserve-buffers-for-debugging*
|
||||
(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))
|
||||
(state (xmtn-automate--session-decoder-state session))
|
||||
(read-marker (xmtn-automate--decoder-state-read-marker state))
|
||||
(command (first (xmtn-automate--session-remaining-command-handles
|
||||
session)))
|
||||
(command-output-buffer
|
||||
(xmtn-automate--command-handle-buffer command))
|
||||
(output-buffer
|
||||
(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
|
||||
(xmtn-automate--command-handle-write-marker command)))
|
||||
(xmtn--assert-optional (not (xmtn-automate--session-sent-kill-p session)))
|
||||
(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))
|
||||
(point-max)))
|
||||
(chars-to-read (- end read-marker)))
|
||||
(chars-to-read (- end (xmtn-automate--decoder-state-read-marker state))))
|
||||
(cond
|
||||
((= chars-to-read 0)
|
||||
nil)
|
||||
((> 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.
|
||||
(progn)
|
||||
(with-current-buffer command-output-buffer
|
||||
t
|
||||
(with-current-buffer output-buffer
|
||||
(save-excursion
|
||||
(goto-char write-marker)
|
||||
(let ((inhibit-read-only t)
|
||||
deactivate-mark)
|
||||
(insert-buffer-substring-no-properties session-buffer
|
||||
read-marker
|
||||
(xmtn-automate--decoder-state-read-marker state)
|
||||
end))
|
||||
(set-marker write-marker (point))))
|
||||
;;(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)
|
||||
chars-to-read)
|
||||
t)
|
||||
(t (xmtn--assert-nil))))))
|
||||
;; Return value matters!
|
||||
)
|
||||
)))))
|
||||
|
||||
(defun xmtn--debug-mark-text-processed (buffer start end bold-p)
|
||||
(xmtn--assert-optional (< start end) t)
|
||||
@ -541,183 +521,86 @@ the buffer."
|
||||
(add-text-properties start end '(face (:strike-through
|
||||
t))))))))
|
||||
|
||||
(defsubst xmtn-automate--process-new-output (session new-string)
|
||||
(let* ((session-buffer (xmtn-automate--session-buffer session))
|
||||
(state (xmtn-automate--session-decoder-state session))
|
||||
(read-marker (xmtn-automate--decoder-state-read-marker state))
|
||||
(defun xmtn-automate--process-new-output (session)
|
||||
(let* ((state (xmtn-automate--session-decoder-state session))
|
||||
(write-marker (process-mark (xmtn-automate--session-process session)))
|
||||
(tag 'check-for-more))
|
||||
(with-current-buffer session-buffer
|
||||
;; Why oh why doesn't (require 'cl) provide tagbody...
|
||||
(with-current-buffer (xmtn-automate--session-buffer session)
|
||||
(loop
|
||||
for command = (first (xmtn-automate--session-remaining-command-handles
|
||||
session))
|
||||
do
|
||||
(xmtn--assert-optional (or (eql tag 'exit-loop)
|
||||
(not (xmtn-automate--session-sent-kill-p
|
||||
session))))
|
||||
(ecase tag
|
||||
(check-for-more
|
||||
(xmtn--assert-optional (<= read-marker write-marker) t)
|
||||
(if (= read-marker write-marker)
|
||||
(if (= (xmtn-automate--decoder-state-read-marker state) write-marker)
|
||||
(setq tag 'exit-loop)
|
||||
(setq tag 'again)))
|
||||
(again
|
||||
(cond
|
||||
((> (xmtn-automate--decoder-state-remaining-chars state) 0)
|
||||
;; copy more output from the current packet
|
||||
(if (xmtn-automate--process-new-output--copy session)
|
||||
(setq tag 'again)
|
||||
(setq tag 'check-for-more)))
|
||||
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0)
|
||||
(xmtn-automate--decoder-state-last-p state))
|
||||
(xmtn--assert-optional command)
|
||||
(setf (xmtn-automate--command-handle-finished-p command) t)
|
||||
(with-no-warnings
|
||||
;; discard result
|
||||
(pop (xmtn-automate--session-remaining-command-handles session)))
|
||||
(setq tag 'check-for-more)
|
||||
(when (not (xmtn-automate--command-handle-may-kill-p command))
|
||||
(when (zerop (decf (xmtn-automate--session-must-not-kill-counter
|
||||
session)))
|
||||
(xmtn--set-process-query-on-exit-flag
|
||||
(xmtn-automate--session-process session)
|
||||
nil)
|
||||
(when (xmtn-automate--session-closed-p session)
|
||||
(xmtn-automate--session-send-process-kill session)
|
||||
(setq tag 'exit-loop))))
|
||||
(setf (xmtn-automate--decoder-state-last-p state) nil))
|
||||
((and (= (xmtn-automate--decoder-state-remaining-chars state) 0)
|
||||
(not (xmtn-automate--decoder-state-last-p state)))
|
||||
(unless command
|
||||
(error "Unexpected output from mtn: %s" new-string))
|
||||
(save-excursion
|
||||
(goto-char read-marker)
|
||||
(cond ((looking-at
|
||||
"\\([0-9]+\\):\\([012]\\):\\([lm]\\):\\([0-9]+\\):")
|
||||
(let ((command-number (parse-integer (match-string 1)))
|
||||
(error-code (parse-integer (match-string 2)))
|
||||
(last-p (cond
|
||||
((string= (match-string 3) "l") t)
|
||||
((string= (match-string 3) "m") nil)
|
||||
(t (xmtn--assert-nil))))
|
||||
(size (parse-integer (match-string 4))))
|
||||
(xmtn--assert-optional (typep command-number
|
||||
'(integer 0 *))
|
||||
t)
|
||||
(xmtn--assert-optional (typep error-code '(member 0 1 2))
|
||||
t)
|
||||
(xmtn--assert-optional (typep size '(integer 0 *)) t)
|
||||
(xmtn--assert-optional
|
||||
(eql
|
||||
command-number
|
||||
(xmtn-automate--command-handle-mtn-command-number
|
||||
command)))
|
||||
(setf (xmtn-automate--command-handle-error-code command)
|
||||
error-code)
|
||||
(setf (xmtn-automate--decoder-state-remaining-chars
|
||||
state)
|
||||
size)
|
||||
(setf (xmtn-automate--decoder-state-last-p state)
|
||||
last-p)
|
||||
;;(xmtn--debug-mark-text-processed session-buffer
|
||||
;; read-marker
|
||||
;; (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))))
|
||||
|
||||
(t
|
||||
;; new packet
|
||||
(goto-char (xmtn-automate--decoder-state-read-marker state))
|
||||
;; A packet has the structure:
|
||||
;; <command number>:<stream>:<size>:<output>
|
||||
;; Streams are:
|
||||
;; m main
|
||||
;; e error
|
||||
;; w warning
|
||||
;; p progress
|
||||
;; t ticker
|
||||
;; l last
|
||||
;;
|
||||
;; If size is large, we may not have all of the output in new-string
|
||||
(cond
|
||||
((looking-at "\\([0-9]+\\):\\([mewptl]\\):\\([0-9]+\\):")
|
||||
(let ((command-number (parse-integer (match-string 1)))
|
||||
(stream (aref (match-string 2) 0))
|
||||
(size (parse-integer (match-string 3))))
|
||||
(setf (xmtn-automate--decoder-state-read-marker state) (match-end 0))
|
||||
(setf (xmtn-automate--decoder-state-stream state) stream)
|
||||
(ecase stream
|
||||
((?m ?e ?w ?t ?p)
|
||||
(setf (xmtn-automate--decoder-state-remaining-chars state) size)
|
||||
(setq tag 'again) )
|
||||
|
||||
(?l
|
||||
(setf (xmtn-automate--decoder-state-read-marker state) (+ size (match-end 0)))
|
||||
(setf (xmtn-automate--command-handle-error-code command)
|
||||
(parse-integer
|
||||
(buffer-substring-no-properties
|
||||
(match-end 0) (xmtn-automate--decoder-state-read-marker state)) ))
|
||||
(setf (xmtn-automate--command-handle-finished-p command) t)
|
||||
(with-no-warnings
|
||||
;; suppress compiler warning about discarding result
|
||||
(pop (xmtn-automate--session-remaining-command-handles session)))
|
||||
(if (xmtn-automate--session-closed-p session)
|
||||
(setq tag 'exit-loop)
|
||||
(setq tag 'check-for-more))
|
||||
)
|
||||
)))
|
||||
|
||||
(t
|
||||
;; Not a packet. Most likely we are at the end of the
|
||||
;; buffer, and there is more output coming soon. FIXME:
|
||||
;; this means the loop logic screwed up.
|
||||
(if (= (point) (point-max))
|
||||
(setq tag 'exit-loop)
|
||||
(error "Unexpected output from mtn at '%s':%d:'%s'"
|
||||
(current-buffer)
|
||||
(point)
|
||||
(buffer-substring (point) (line-end-position)))))))))
|
||||
|
||||
(exit-loop (return))))))
|
||||
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)
|
||||
(lexical-let ((root xmtn--root)
|
||||
(revision-hash-id xmtn--revision-hash-id)
|
||||
@ -728,7 +611,7 @@ the buffer."
|
||||
for xmtn--stanza = (funcall xmtn--next-stanza)
|
||||
while xmtn--stanza
|
||||
do (xmtn-match xmtn--stanza
|
||||
((("key" (string $xmtn--key))
|
||||
((("key" (id $xmtn--key))
|
||||
("signature" (string $xmtn--signature))
|
||||
("name" (string $xmtn--name))
|
||||
("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)
|
||||
(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)
|
||||
"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
|
||||
default-directory
|
||||
(list (list "no-unchanged" "no-ignored")
|
||||
(list (list "no-unchanged" "" "no-ignored" "")
|
||||
"inventory"))))
|
||||
(if (> (length result) 0)
|
||||
'need-commit
|
||||
'ok))))
|
||||
|
||||
(message (concat msg " done") work)
|
||||
|
||||
(if (> (length result) 0)
|
||||
'need-commit
|
||||
'ok))))
|
||||
|
||||
(provide 'xmtn-automate)
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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
|
||||
;; Keywords: tools
|
||||
@ -73,7 +73,7 @@
|
||||
|
||||
(defvar xmtn-conflicts-ancestor-revision ""
|
||||
"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
|
||||
"Total count of conflicts.")
|
||||
@ -226,7 +226,7 @@ header."
|
||||
;; right_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex"
|
||||
;; right_file_id [d1eee768379694a59b2b015dd59a61cf67505182]
|
||||
;;
|
||||
;; optional resolution: {resolved_internal | resolved_user}
|
||||
;; optional resolution: {resolved_internal | resolved_user_left}
|
||||
(let ((conflict (make-xmtn-conflicts-conflict)))
|
||||
(setf (xmtn-conflicts-conflict-conflict_type conflict) 'content)
|
||||
(xmtn-basic-io-check-line "node_type"
|
||||
@ -250,7 +250,7 @@ header."
|
||||
(setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count))
|
||||
(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))))
|
||||
|
||||
(t
|
||||
@ -523,7 +523,7 @@ header."
|
||||
(insert "resolved_keep_left \n"))
|
||||
|
||||
(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)
|
||||
@ -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-B 'B nil nil)
|
||||
(ediff-dispose-of-variant-according-to-user ediff-ancestor-buffer 'Ancestor nil nil)
|
||||
(save-excursion
|
||||
(set-buffer ediff-buffer-C)
|
||||
(save-buffer))
|
||||
(with-current-buffer ediff-buffer-C (save-buffer))
|
||||
(ediff-kill-buffer-carefully ediff-buffer-C)
|
||||
|
||||
(let ((control-buffer ediff-control-buffer))
|
||||
@ -763,13 +761,13 @@ header."
|
||||
(set-window-configuration window-config)
|
||||
(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."
|
||||
(let ((file (concat (file-name-as-directory dir) file-name)))
|
||||
(setq dir (file-name-directory file))
|
||||
(unless (file-exists-p dir)
|
||||
(make-directory dir t))
|
||||
(xmtn--get-file-by-id default-directory file-id file)
|
||||
(xmtn--get-file-by-id work file-id file)
|
||||
file))
|
||||
|
||||
(defun xmtn-conflicts-resolve-ediff (side)
|
||||
@ -791,13 +789,16 @@ header."
|
||||
;;
|
||||
;; duplicate_name conflicts have no ancestor.
|
||||
(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"
|
||||
(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-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-conflict-right_name conflict)))
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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
|
||||
|
||||
;; Author: Christian M. Ohler
|
||||
@ -71,26 +71,23 @@
|
||||
(dvc-register-dvc 'xmtn "monotone")
|
||||
|
||||
(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)
|
||||
(declare (indent 1) (debug (sexp body)))
|
||||
(let ((parser-tmp (gensym))
|
||||
(root (gensym))
|
||||
(let ((root (gensym))
|
||||
(command (gensym))
|
||||
(may-kill-p (gensym))
|
||||
(session (gensym))
|
||||
(handle (gensym)))
|
||||
`(let ((,root ,root-form)
|
||||
(,command ,command-form)
|
||||
(,may-kill-p ,may-kill-p-form))
|
||||
(,command ,command-form))
|
||||
(let* ((,session (xmtn-automate-cache-session ,root))
|
||||
(,handle (xmtn-automate--new-command ,session ,command ,may-kill-p)))
|
||||
(xmtn-automate-command-check-for-and-report-error ,handle)
|
||||
(,handle (xmtn-automate--new-command ,session ,command)))
|
||||
(xmtn-automate-command-wait-until-finished ,handle)
|
||||
(xmtn-basic-io-with-stanza-parser (,parser
|
||||
(xmtn-automate-command-buffer
|
||||
,handle))
|
||||
,@body)))))
|
||||
(prog1
|
||||
(xmtn-basic-io-with-stanza-parser
|
||||
(,parser (xmtn-automate-command-buffer ,handle))
|
||||
,@body)
|
||||
(xmtn-automate--cleanup-command ,handle))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun xmtn-dvc-log-edit-file-name-func (&optional root)
|
||||
@ -136,7 +133,7 @@ the file before saving."
|
||||
(concat "--message-file=" log-edit-file))))
|
||||
|
||||
;;;###autoload
|
||||
(defun xmtn-dvc-log-edit-done ()
|
||||
(defun xmtn-dvc-log-edit-done (&optional prompt-branch)
|
||||
(let* ((root default-directory)
|
||||
(files (or (with-current-buffer dvc-partner-buffer
|
||||
(dvc-current-file-list 'nil-if-none-marked))
|
||||
@ -153,7 +150,14 @@ the file before saving."
|
||||
(excluded-files
|
||||
(with-current-buffer dvc-partner-buffer
|
||||
(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.
|
||||
(save-buffer)
|
||||
(dvc-save-some-buffers root)
|
||||
@ -167,7 +171,7 @@ the file before saving."
|
||||
;; We used to check for things that would make commit fail;
|
||||
;; missing files, nothing to commit. But that just slows things
|
||||
;; 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
|
||||
(case normalized-files
|
||||
(all (format "Committing all files in %s" root))
|
||||
@ -183,6 +187,7 @@ the file before saving."
|
||||
root
|
||||
`("commit" ,(xmtn-dvc-log-message)
|
||||
,(concat "--branch=" branch)
|
||||
"--non-interactive"
|
||||
,@(case normalized-files
|
||||
(all
|
||||
(if excluded-files
|
||||
@ -206,8 +211,11 @@ the file before saving."
|
||||
;; commit was successful. Let's not interfere with
|
||||
;; that. (Calling `dvc-log-close' would.)
|
||||
|
||||
;; we'd like to delete log-edit-buffer here, but
|
||||
;; we can't do that from a process sentinel
|
||||
;; we'd like to delete log-edit-buffer here, but we
|
||||
;; 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
|
||||
default-directory
|
||||
@ -293,11 +301,7 @@ the file before saving."
|
||||
:dir (file-name-directory path)
|
||||
:file (file-name-nondirectory path)
|
||||
:status status
|
||||
:more-status (if orig-path
|
||||
(if (eq status 'rename-target)
|
||||
(concat "from " orig-path)
|
||||
(concat "to " orig-path))
|
||||
""))))))
|
||||
:more-status (or orig-path ""))))))
|
||||
(likely-dir-p (path) (string-match "/\\'" path)))
|
||||
|
||||
;; 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.
|
||||
;; Don't throw an error; upper level might be doing other directories as well.
|
||||
(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
|
||||
(unless no-ding (ding))
|
||||
(message "Tree %s is already based on target revision %s"
|
||||
@ -1087,7 +1091,9 @@ finished."
|
||||
(let* ((branch (xmtn--tree-default-branch root))
|
||||
(heads (xmtn--heads root branch)))
|
||||
(case (length heads)
|
||||
(0 (assert nil))
|
||||
(0
|
||||
(error "branch %s has no revisions" branch))
|
||||
|
||||
(1
|
||||
(xmtn--update root (first heads) t no-ding))
|
||||
|
||||
@ -1133,24 +1139,20 @@ finished."
|
||||
(lambda ()
|
||||
(xmtn--refresh-status-header display-buffer)
|
||||
(message "%s... done" msg)))
|
||||
(xmtn--run-command-sync
|
||||
root cmd
|
||||
:finished (lambda (output error status arguments)
|
||||
(xmtn--refresh-status-header display-buffer)
|
||||
(message "%s... done" msg)))))))
|
||||
(xmtn--run-command-sync root cmd)
|
||||
(xmtn--refresh-status-header display-buffer)
|
||||
(message "%s... done" msg)))))
|
||||
|
||||
(defun xmtn-dvc-merge-1 (root refresh-status)
|
||||
(lexical-let ((refresh-status refresh-status))
|
||||
(xmtn--run-command-async
|
||||
root
|
||||
(list
|
||||
"merge"
|
||||
(if (file-exists-p (concat root "/_MTN/conflicts"))
|
||||
"--resolve-conflicts-file=_MTN/conflicts")
|
||||
(xmtn-dvc-log-message))
|
||||
:finished (lambda (output error status arguments)
|
||||
(if refresh-status
|
||||
(xmtn--refresh-status-header (current-buffer)))))))
|
||||
(xmtn--run-command-sync
|
||||
root
|
||||
(list
|
||||
"merge"
|
||||
(if (file-exists-p (concat root "/_MTN/conflicts"))
|
||||
"--resolve-conflicts-file=_MTN/conflicts")
|
||||
(xmtn-dvc-log-message)))
|
||||
(if refresh-status
|
||||
(xmtn--refresh-status-header (current-buffer))))
|
||||
|
||||
;;;###autoload
|
||||
(defun xmtn-dvc-merge (&optional other)
|
||||
@ -1193,20 +1195,16 @@ finished."
|
||||
(let ((root (dvc-tree-root)))
|
||||
(assert (not (endp file-names)))
|
||||
(dvc-save-some-buffers root)
|
||||
(let ((normalized-file-names (xmtn--normalize-file-names root file-names)))
|
||||
(lexical-let
|
||||
((root root)
|
||||
(progress-message
|
||||
(if (eql (length file-names) 1)
|
||||
(format "Reverting file %s" (first file-names))
|
||||
(format "Reverting %s files" (length file-names)))))
|
||||
(message "%s..." progress-message)
|
||||
(xmtn--run-command-sync root `("revert" "--"
|
||||
,@normalized-file-names)
|
||||
:finished
|
||||
(lambda (output error status arguments)
|
||||
(message "%s... done" progress-message)))
|
||||
(dvc-revert-some-buffers root))))
|
||||
(let ((normalized-file-names (xmtn--normalize-file-names root file-names))
|
||||
(progress-message
|
||||
(if (eql (length file-names) 1)
|
||||
(format "Reverting file %s" (first file-names))
|
||||
(format "Reverting %s files" (length file-names)))))
|
||||
(message "%s..." progress-message)
|
||||
(xmtn--run-command-sync root `("revert" "--"
|
||||
,@normalized-file-names))
|
||||
(message "%s... done" progress-message))
|
||||
(dvc-revert-some-buffers root))
|
||||
nil)
|
||||
|
||||
;;;###autoload
|
||||
@ -1222,48 +1220,38 @@ finished."
|
||||
(xmtn--revision-get-file-helper file `(revision ,@stuff)))
|
||||
|
||||
(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* ((normalized-file (xmtn--normalize-file-name root file))
|
||||
(corresponding-file
|
||||
(xmtn--get-corresponding-path root normalized-file
|
||||
`(local-tree ,root) backend-id)))
|
||||
(if (null corresponding-file)
|
||||
;; File doesn't exist. Since this function is (as far
|
||||
;; as I know) only called from diff-like functions, a
|
||||
;; missing file is not an error but just means the diff
|
||||
;; should be computed against an empty file. So just
|
||||
;; leave the buffer empty.
|
||||
(progn)
|
||||
(let ((temp-dir nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq temp-dir (make-temp-file
|
||||
"xmtn--revision-get-file-" t))
|
||||
;; Going through a temporary file and using
|
||||
;; `insert-file-contents' in conjunction with as
|
||||
;; much of the original file name as possible seems
|
||||
;; to be the best way to make sure that Emacs'
|
||||
;; entire file coding system detection logic is
|
||||
;; applied. Functions like
|
||||
;; `find-operation-coding-system' and
|
||||
;; `find-file-name-handler' are not a complete
|
||||
;; replacement since they don't look at the contents
|
||||
;; at all.
|
||||
(let ((temp-file (concat temp-dir "/" corresponding-file)))
|
||||
(make-directory (file-name-directory temp-file) t)
|
||||
(with-temp-file temp-file
|
||||
(set-buffer-multibyte nil)
|
||||
(setq buffer-file-coding-system 'binary)
|
||||
(xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
|
||||
(let ((output-buffer (current-buffer)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents temp-file)
|
||||
(let ((input-buffer (current-buffer)))
|
||||
(with-current-buffer output-buffer
|
||||
(insert-buffer-substring input-buffer)))))))
|
||||
(when temp-dir
|
||||
(dvc-delete-recursively temp-dir))))))))
|
||||
(let ((normalized-file (xmtn--normalize-file-name root file))
|
||||
(temp-dir nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq temp-dir (make-temp-file
|
||||
"xmtn--revision-get-file-" t))
|
||||
;; Going through a temporary file and using
|
||||
;; `insert-file-contents' in conjunction with as
|
||||
;; much of the original file name as possible seems
|
||||
;; to be the best way to make sure that Emacs'
|
||||
;; entire file coding system detection logic is
|
||||
;; applied. Functions like
|
||||
;; `find-operation-coding-system' and
|
||||
;; `find-file-name-handler' are not a complete
|
||||
;; replacement since they don't look at the contents
|
||||
;; at all.
|
||||
(let ((temp-file (concat temp-dir "/" normalized-file)))
|
||||
(make-directory (file-name-directory temp-file) t)
|
||||
(with-temp-file temp-file
|
||||
(set-buffer-multibyte nil)
|
||||
(setq buffer-file-coding-system 'binary)
|
||||
(xmtn--insert-file-contents-by-name root backend-id normalized-file (current-buffer)))
|
||||
(let ((output-buffer (current-buffer)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents temp-file)
|
||||
(let ((input-buffer (current-buffer)))
|
||||
(with-current-buffer output-buffer
|
||||
(insert-buffer-substring input-buffer)))))))
|
||||
(when temp-dir
|
||||
(dvc-delete-recursively temp-dir))))))
|
||||
|
||||
(defun xmtn--get-file-by-id (root file-id save-as)
|
||||
"Store contents of FILE-ID in file SAVE-AS."
|
||||
@ -1341,25 +1329,12 @@ finished."
|
||||
`(,id ,normalized-file))))
|
||||
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
|
||||
source-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
|
||||
(let (source-revision-hash-id
|
||||
target-revision-hash-id
|
||||
@ -1382,9 +1357,11 @@ finished."
|
||||
((local-tree $target-path)
|
||||
(assert (xmtn--same-tree-p path target-path))
|
||||
(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
|
||||
path normalized-file-name))
|
||||
(setq source-revision-hash-id base-revision-hash-id)))))
|
||||
|
||||
(xmtn-match resolved-target-revision
|
||||
((revision $hash-id)
|
||||
(setq target-revision-hash-id hash-id))
|
||||
@ -1394,8 +1371,9 @@ finished."
|
||||
(xmtn--get-base-revision-hash-id-or-null path)))
|
||||
(if (null base-revision-hash-id)
|
||||
(return-from get-corresponding-path nil)
|
||||
(setq target-revision-hash-id base-revision-hash-id
|
||||
file-name-postprocessor
|
||||
(setq target-revision-hash-id base-revision-hash-id)
|
||||
;; Handle an uncommitted rename in the current workspace
|
||||
(setq file-name-postprocessor
|
||||
(lexical-let ((path path))
|
||||
(lambda (file-name)
|
||||
(xmtn--get-rename-in-workspace-from path
|
||||
@ -1409,6 +1387,9 @@ finished."
|
||||
(funcall file-name-postprocessor result))))))
|
||||
|
||||
(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
|
||||
(check-type normalized-source-file-name string)
|
||||
(block parse
|
||||
@ -1424,6 +1405,10 @@ finished."
|
||||
normalized-source-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
|
||||
(check-type normalized-target-file-name string)
|
||||
(block parse
|
||||
|
||||
@ -219,7 +219,7 @@ See file commentary for details."
|
||||
must be a workspace."
|
||||
(let* (result
|
||||
(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)
|
||||
(with-current-buffer (xmtn-automate-command-buffer handle)
|
||||
;; now in buffer containing basic_io certs; find the branch certs
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; xmtn-status.el --- manage actions for multiple projects
|
||||
|
||||
;; Copyright (C) 2009 Stephen Leake
|
||||
;; Copyright (C) 2009 - 2010 Stephen Leake
|
||||
|
||||
;; Author: Stephen Leake
|
||||
;; 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))
|
||||
(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 ()
|
||||
"Clean current workspace, delete from ewoc"
|
||||
(interactive)
|
||||
(let* ((elem (ewoc-locate xmtn-status-ewoc))
|
||||
(data (ewoc-data elem))
|
||||
(inhibit-read-only t))
|
||||
(xmtn-status-kill-conflicts-buffer data)
|
||||
(xmtn-conflicts-clean (xmtn-status-work data))
|
||||
(xmtn-status-clean-1 data)
|
||||
(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 ()
|
||||
"Non-nil if clean & quit is appropriate for current workspace."
|
||||
(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)))
|
||||
(xmtn-status-need-refresh elem data)
|
||||
(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 ()
|
||||
"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))
|
||||
(data (ewoc-data elem))
|
||||
(default-directory (xmtn-status-work data)))
|
||||
(xmtn-status-need-refresh elem data)
|
||||
(xmtn-status-save-conflicts-buffer data)
|
||||
(xmtn-dvc-merge-1 default-directory nil)))
|
||||
(xmtn-dvc-merge-1 default-directory nil)
|
||||
(xmtn-status-refresh-one data nil)
|
||||
(ewoc-invalidate xmtn-status-ewoc elem)))
|
||||
|
||||
(defun xmtn-status-heads ()
|
||||
"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"
|
||||
xmtn-status-update
|
||||
:visible (xmtn-status-updatep)))
|
||||
(define-key map [?4] '(menu-item "4) xmtn-merge"
|
||||
(define-key map [?4] '(menu-item "4) merge"
|
||||
xmtn-status-merge
|
||||
: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
|
||||
:visible (xmtn-status-headsp)))
|
||||
(define-key map [?2] '(menu-item "2) resolve conflicts"
|
||||
xmtn-status-resolve-conflicts
|
||||
:visible (xmtn-status-resolve-conflictsp)))
|
||||
(define-key map [?1] '(menu-item "1) dvc-missing"
|
||||
(define-key map [?1] '(menu-item "1) show missing"
|
||||
xmtn-status-missing
|
||||
:visible (xmtn-status-missingp)))
|
||||
(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 [?n] 'xmtn-status-next)
|
||||
(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)
|
||||
"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."
|
||||
(interactive "DStatus for (workspace): ")
|
||||
(pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
|
||||
(setq default-directory work)
|
||||
(setq xmtn-status-root (expand-file-name (concat (file-name-as-directory work) "../")))
|
||||
;; allow WORK to be relative, and ensure it is a workspace root
|
||||
(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))
|
||||
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
|
||||
(ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
|
||||
(ewoc-enter-last xmtn-status-ewoc
|
||||
(make-xmtn-status-data
|
||||
:work (file-name-nondirectory (directory-file-name work))
|
||||
:work (file-name-nondirectory (directory-file-name default-directory))
|
||||
:branch (xmtn--tree-default-branch default-directory)
|
||||
:need-refresh t
|
||||
:heads 'need-scan))
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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
|
||||
;; Keywords: tools
|
||||
@ -53,8 +53,6 @@ The elements must all be of class xmtn-propagate-data.")
|
||||
to-name ;
|
||||
from-branch ; branch name (assumed never changes)
|
||||
to-branch ;
|
||||
from-session ; mtn automate session
|
||||
to-session ;
|
||||
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
|
||||
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))
|
||||
(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 ()
|
||||
"Clean current workspace, delete from ewoc"
|
||||
(interactive)
|
||||
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
||||
(data (ewoc-data elem)))
|
||||
|
||||
;; only one conflicts file and buffer
|
||||
(xmtn-propagate-kill-conflicts-buffer data)
|
||||
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
|
||||
|
||||
(xmtn-propagate-clean-1 data)
|
||||
(let ((inhibit-read-only t))
|
||||
(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 ()
|
||||
"Non-nil if clean is appropriate for current workspace."
|
||||
(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))
|
||||
xmtn-propagate-status-from-ok
|
||||
: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
|
||||
: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
|
||||
:visible (xmtn-propagate-missing-fromp)))
|
||||
(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))
|
||||
xmtn-propagate-status-from
|
||||
: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
|
||||
: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
|
||||
:visible (xmtn-propagate-heads-fromp)))
|
||||
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 [?n] 'xmtn-propagate-next)
|
||||
(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)
|
||||
"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)
|
||||
"FROM-WORKSPACE, TO-WORKSPACE are relative names"
|
||||
(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-session (xmtn-automate-cache-session to-work))
|
||||
)
|
||||
|
||||
(ewoc-enter-last
|
||||
@ -654,8 +659,6 @@ The elements must all be of class xmtn-propagate-data.")
|
||||
:to-name to-name
|
||||
:from-branch (xmtn--tree-default-branch from-work)
|
||||
:to-branch (xmtn--tree-default-branch to-work)
|
||||
:from-session nil ;; from-session
|
||||
:to-session nil ;; to-session
|
||||
:need-refresh t))))
|
||||
|
||||
;;;###autoload
|
||||
@ -700,9 +703,7 @@ scanned and all common ones found are used."
|
||||
(interactive "DPropagate all from (workspace): \nDto (workspace): ")
|
||||
(setq from-work (substitute-in-file-name from-work))
|
||||
(setq to-work (substitute-in-file-name to-work))
|
||||
(let ((default-directory to-work)
|
||||
(from-session (xmtn-automate-cache-session from-work))
|
||||
(to-session (xmtn-automate-cache-session to-work)))
|
||||
(let ((default-directory to-work))
|
||||
(pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
|
||||
;; default-directory is wrong if buffer is reused
|
||||
(setq default-directory to-work)
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;; 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
|
||||
|
||||
;; Author: Christian M. Ohler
|
||||
@ -43,7 +43,7 @@
|
||||
|
||||
(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)
|
||||
(let ((default-directory (file-truename (or root default-directory))))
|
||||
(dvc-run-dvc-sync
|
||||
@ -53,8 +53,7 @@
|
||||
;; necessary since default-directory is set, and it
|
||||
;; confuses the Cygwin version of mtn when run with a
|
||||
;; non-Cygwin Emacs.
|
||||
,@arguments)
|
||||
dvc-run-keys)))
|
||||
,@arguments))))
|
||||
|
||||
;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
|
||||
;;; 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))
|
||||
(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 ()
|
||||
"Non-nil if mtn automate inventory supports --no-ignore, --no-unknown, --no-unchanged options."
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user