From 55f6a1fe0965ebdbcc8ce236eca0c9c4db83b42a Mon Sep 17 00:00:00 2001 From: Kai Tetzlaff Date: Fri, 18 Jun 2010 09:23:22 +0200 Subject: [PATCH] sync with upstream --- dvc/configure.ac | 1 - dvc/lisp/dvc-buffers.el | 15 +- dvc/lisp/dvc-core.el | 6 +- dvc/lisp/dvc-diff.el | 26 +- dvc/lisp/dvc-fileinfo.el | 40 ++- dvc/lisp/xmtn-automate.el | 516 ++++++++++++++-------------------- dvc/lisp/xmtn-conflicts.el | 27 +- dvc/lisp/xmtn-dvc.el | 213 +++++++------- dvc/lisp/xmtn-ids.el | 2 +- dvc/lisp/xmtn-multi-status.el | 42 ++- dvc/lisp/xmtn-propagate.el | 41 +-- dvc/lisp/xmtn-run.el | 10 +- 12 files changed, 448 insertions(+), 491 deletions(-) diff --git a/dvc/configure.ac b/dvc/configure.ac index 2c6cefe..e4149a1 100644 --- a/dvc/configure.ac +++ b/dvc/configure.ac @@ -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: diff --git a/dvc/lisp/dvc-buffers.el b/dvc/lisp/dvc-buffers.el index 86ac642..d5b2f22 100644 --- a/dvc/lisp/dvc-buffers.el +++ b/dvc/lisp/dvc-buffers.el @@ -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 ;; 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." diff --git a/dvc/lisp/dvc-core.el b/dvc/lisp/dvc-core.el index 0a10749..20aca6e 100644 --- a/dvc/lisp/dvc-core.el +++ b/dvc/lisp/dvc-core.el @@ -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, ;; 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\"." diff --git a/dvc/lisp/dvc-diff.el b/dvc/lisp/dvc-diff.el index 8dbb16c..656d1fd 100644 --- a/dvc/lisp/dvc-diff.el +++ b/dvc/lisp/dvc-diff.el @@ -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 ;; 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) diff --git a/dvc/lisp/dvc-fileinfo.el b/dvc/lisp/dvc-fileinfo.el index 15077a7..04b6d91 100644 --- a/dvc/lisp/dvc-fileinfo.el +++ b/dvc/lisp/dvc-fileinfo.el @@ -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, @@ -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)))))) diff --git a/dvc/lisp/xmtn-automate.el b/dvc/lisp/xmtn-automate.el index eb7e9d6..5dea1ea 100644 --- a/dvc/lisp/xmtn-automate.el +++ b/dvc/lisp/xmtn-automate.el @@ -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 (::::) 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: + ;; ::: + ;; 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) diff --git a/dvc/lisp/xmtn-conflicts.el b/dvc/lisp/xmtn-conflicts.el index cfae437..034ee36 100644 --- a/dvc/lisp/xmtn-conflicts.el +++ b/dvc/lisp/xmtn-conflicts.el @@ -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))) diff --git a/dvc/lisp/xmtn-dvc.el b/dvc/lisp/xmtn-dvc.el index 6474076..f768f59 100644 --- a/dvc/lisp/xmtn-dvc.el +++ b/dvc/lisp/xmtn-dvc.el @@ -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 diff --git a/dvc/lisp/xmtn-ids.el b/dvc/lisp/xmtn-ids.el index 30dbe5f..f257f33 100644 --- a/dvc/lisp/xmtn-ids.el +++ b/dvc/lisp/xmtn-ids.el @@ -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 diff --git a/dvc/lisp/xmtn-multi-status.el b/dvc/lisp/xmtn-multi-status.el index dd7de5c..26a69b0 100644 --- a/dvc/lisp/xmtn-multi-status.el +++ b/dvc/lisp/xmtn-multi-status.el @@ -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)) diff --git a/dvc/lisp/xmtn-propagate.el b/dvc/lisp/xmtn-propagate.el index 5930379..4c8ee9b 100644 --- a/dvc/lisp/xmtn-propagate.el +++ b/dvc/lisp/xmtn-propagate.el @@ -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) diff --git a/dvc/lisp/xmtn-run.el b/dvc/lisp/xmtn-run.el index cdc34ae..7c899c1 100644 --- a/dvc/lisp/xmtn-run.el +++ b/dvc/lisp/xmtn-run.el @@ -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."