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

update subrepo elisp-vcs

Browse Source
This commit is contained in:
Kai Tetzlaff 2011-04-24 09:16:02 +02:00
parent 7473bfb2cb
commit b10fbbad5b
17 changed files with 1021 additions and 711 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dvc/lisp/Makefile.in
View File

@ -53,6 +53,7 @@ install: all
echo Installing $$elc ; \ echo Installing $$elc ; \
$(INSTALL_DATA) $$elc "$(lispdir)" ; \ $(INSTALL_DATA) $$elc "$(lispdir)" ; \
done done
$(INSTALL_DATA) xmtn-hooks.lua $(lispdir)
clean: clean:
rm -f *.elc dvc-site.el \ rm -f *.elc dvc-site.el \

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

@ -1,6 +1,6 @@
;;; dvc-buffers.el --- Buffer management for DVC ;;; dvc-buffers.el --- Buffer management for DVC
;; Copyright (C) 2005-2010 by all contributors ;; Copyright (C) 2005-2011 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr> ;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from: ;; Contributions from:
@ -178,8 +178,9 @@ See also `dvc-get-buffer'"
(eq mode 'string-multiple)) (eq mode 'string-multiple))
(generate-new-buffer (format name path)) (generate-new-buffer (format name path))
(let ((default-directory (let ((default-directory
(or (file-name-directory path) (if (file-name-directory path)
default-directory))) (expand-file-name (file-name-directory path))
default-directory)))
(dvc-create-buffer name))))) (dvc-create-buffer name)))))
(with-current-buffer buffer (with-current-buffer buffer
(if (featurep 'xemacs) (if (featurep 'xemacs)

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

@ -1,7 +1,7 @@
;;; dvc-fileinfo.el --- An ewoc structure for displaying file information ;;; dvc-fileinfo.el --- An ewoc structure for displaying file information
;;; for DVC ;;; for DVC
;; Copyright (C) 2007 - 2010 by all contributors ;; Copyright (C) 2007 - 2011 by all contributors
;; Author: Stephen Leake, <stephen_leake@stephe-leake.org> ;; Author: Stephen Leake, <stephen_leake@stephe-leake.org>
@ -553,42 +553,8 @@ in that directory. Then move to previous ewoc entry."
(otherwise (otherwise
(error "not on a file or directory"))))) (error "not on a file or directory")))))
(defun dvc-fileinfo-next (&optional no-ding) (dvc-make-ewoc-next dvc-fileinfo-next dvc-fileinfo-ewoc)
"Move to the next ewoc entry. If optional NO-DING, don't ding (dvc-make-ewoc-prev dvc-fileinfo-prev dvc-fileinfo-ewoc)
if there is no next."
(interactive)
(let* ((current (ewoc-locate dvc-fileinfo-ewoc))
(cur-location (ewoc-location current))
(next (ewoc-next dvc-fileinfo-ewoc current)))
(cond
((> cur-location (point))
;; not exactly at an element; move there
(goto-char cur-location))
(next
(goto-char (ewoc-location next)))
(t
;; at last element
(unless no-ding (ding))))))
(defun dvc-fileinfo-prev (&optional no-ding)
"Move to the previous ewoc entry. If optional NO-DING, don't ding
if there is no prev."
(interactive)
(let* ((current (ewoc-locate dvc-fileinfo-ewoc))
(cur-location (ewoc-location current))
(prev (ewoc-prev dvc-fileinfo-ewoc current)))
(cond
((> (point) cur-location)
(goto-char cur-location))
(prev
(goto-char (ewoc-location prev)))
(t
;; at first element
(unless no-ding (ding))))))
(defun dvc-fileinfo-find-file (file) (defun dvc-fileinfo-find-file (file)
"Return ewoc element for FILE (full path)." "Return ewoc element for FILE (full path)."

4
dvc/lisp/dvc-log.el
View File

@ -1,6 +1,6 @@
;;; dvc-log.el --- Manipulation of the log before committing ;;; dvc-log.el --- Manipulation of the log before committing
;; Copyright (C) 2005-2008 by all contributors ;; Copyright (C) 2005-2008, 2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr> ;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from: ;; Contributions from:
@ -121,7 +121,7 @@ is reused."
(current-window-configuration)) (current-window-configuration))
(let ((start-buffer (current-buffer))) (let ((start-buffer (current-buffer)))
(dvc-switch-to-buffer (dvc-switch-to-buffer
(dvc-get-buffer-create (dvc-current-active-dvc) 'log-edit) (dvc-get-buffer-create (dvc-current-active-dvc) 'log-edit root)
other-frame) other-frame)
;; `no-init' is somewhat misleading here. It is set to t in ;; `no-init' is somewhat misleading here. It is set to t in
;; dvc-add-log-entry, and nil in dvc-log-edit. That prevents ;; dvc-add-log-entry, and nil in dvc-log-edit. That prevents

9
dvc/lisp/dvc-status.el
View File

@ -1,6 +1,6 @@
;;; dvc-status.el --- A generic status mode for DVC ;;; dvc-status.el --- A generic status mode for DVC
;; Copyright (C) 2007 - 2009 by all contributors ;; Copyright (C) 2007 - 2009, 2011 by all contributors
;; Author: Stephen Leake, <stephen_leake@stephe-leake.org> ;; Author: Stephen Leake, <stephen_leake@stephe-leake.org>
@ -32,12 +32,12 @@
(require 'uniquify) (require 'uniquify)
(defcustom dvc-status-display-known nil (defcustom dvc-status-display-known nil
"If non-nil, display files with 'known' status in xmtn-status buffer." "If non-nil, display files with 'known' status in dvc-status buffer."
:type 'boolean :type 'boolean
:group 'dvc) :group 'dvc)
(defcustom dvc-status-display-ignored nil (defcustom dvc-status-display-ignored nil
"If non-nil, display files with 'ignored' status in xmtn-status buffer." "If non-nil, display files with 'ignored' status in dvc-status buffer."
:type 'boolean :type 'boolean
:group 'dvc) :group 'dvc)
@ -126,8 +126,7 @@
;; "<back-end>-status-mode", if defined, will be used instead of this ;; "<back-end>-status-mode", if defined, will be used instead of this
;; one. If so, it should be derived from dvc-status-mode (via ;; one. If so, it should be derived from dvc-status-mode (via
;; `define-derived-mode'), and rely on it for as many features as ;; `define-derived-mode'), and rely on it for as many features as
;; possible (one can, for example, extend the menu and keymap). See ;; possible (one can, for example, extend the menu and keymap).
;; `xmtn-status-mode' in xmtn-dvc.el for a good example.
;; Remember to add the new mode to uniquify-list-buffers-directory-modes ;; Remember to add the new mode to uniquify-list-buffers-directory-modes
(define-derived-mode dvc-status-mode fundamental-mode "dvc-status" (define-derived-mode dvc-status-mode fundamental-mode "dvc-status"
"Major mode to display workspace status." "Major mode to display workspace status."

12
dvc/lisp/dvc-unified.el
View File

@ -287,15 +287,23 @@ If DONT-SWITCH is non-nil, just show the diff buffer, don't select it."
buffer file name; nil means entire tree; negative prefix arg buffer file name; nil means entire tree; negative prefix arg
means prompt for tree depending on value of means prompt for tree depending on value of
dvc-read-project-tree-mode), LAST-N entries (default dvc-read-project-tree-mode), LAST-N entries (default
`dvc-log-last-n'; all if nil, positive prefix value means that `dvc-log-last-n'; all if nil, prefix value means that
many entries). Use `dvc-changelog' for the full log." many entries (absolute value)). Use `dvc-changelog' for the full log."
(interactive "i\nP") (interactive "i\nP")
<<<<<<< TREE
(let* ((allentries (or (eq last-n nil) (let* ((allentries (or (eq last-n nil)
(< (prefix-numeric-value last-n) 0))) (< (prefix-numeric-value last-n) 0)))
(last-n (prefix-numeric-value last-n)) (last-n (prefix-numeric-value last-n))
(path (if (< last-n 0) (path (if (< last-n 0)
nil (buffer-file-name))) nil (buffer-file-name)))
(last-n (if allentries nil last-n)) (last-n (if allentries nil last-n))
=======
(let* ((path (if (and last-n (< (prefix-numeric-value last-n) 0))
nil (buffer-file-name)))
(last-n (if last-n
(abs (prefix-numeric-value last-n))
dvc-log-last-n))
>>>>>>> MERGE-SOURCE
(default-directory (default-directory
(dvc-read-project-tree-maybe "DVC tree root (directory): " (dvc-read-project-tree-maybe "DVC tree root (directory): "
(when path (expand-file-name path)) (when path (expand-file-name path))

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

@ -1,6 +1,6 @@
;;; xmtn-automate.el --- Interface to monotone's "automate" functionality ;;; xmtn-automate.el --- Interface to monotone's "automate" functionality
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -131,7 +131,7 @@ workspace root."
(buffer-substring-no-properties (point-min) (point-max)) (buffer-substring-no-properties (point-min) (point-max))
(xmtn-automate--cleanup-command handle)))) (xmtn-automate--cleanup-command handle))))
(defun xmtn-automate-simple-command-output-string (root command) (defun xmtn-automate-command-output-string (root command)
"Send COMMAND to session for ROOT. Return result as a string." "Send COMMAND to session for ROOT. Return result as a string."
(let* ((session (xmtn-automate-cache-session root)) (let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command))) (command-handle (xmtn-automate--new-command session command)))
@ -149,34 +149,37 @@ workspace root."
(xmtn-automate-command-buffer command-handle))) (xmtn-automate-command-buffer command-handle)))
(xmtn-automate--cleanup-command command-handle))) (xmtn-automate--cleanup-command command-handle)))
(defun xmtn-automate-command-output-lines (handle) (defun xmtn-automate-command-output-file (root file command)
"Return list of lines of output in HANDLE; first line output is "Send COMMAND to session for ROOT, store result in FILE."
first in list." (let* ((session (xmtn-automate-cache-session root))
(xmtn-automate-command-wait-until-finished handle) (command-handle (xmtn-automate--new-command session command nil nil)))
(with-current-buffer (xmtn-automate-command-buffer handle) (xmtn-automate-command-wait-until-finished command-handle)
(goto-char (point-min)) (with-current-buffer (xmtn-automate-command-buffer command-handle)
(let (result) (write-region nil nil file))
(while (< (point) (point-max)) (xmtn-automate--cleanup-command command-handle)))
(setq result (cons (buffer-substring-no-properties
(point)
(progn (end-of-line) (point)))
result))
(forward-line 1))
(xmtn-automate--cleanup-command handle)
(nreverse result))))
(defun xmtn-automate-simple-command-output-lines (root command) (defun xmtn-automate-command-output-lines (root command)
"Return list of strings containing output of COMMAND, one line per "Return list of strings containing output of COMMAND, one line per
string." string."
(let* ((session (xmtn-automate-cache-session root)) (let* ((session (xmtn-automate-cache-session root))
(command-handle (xmtn-automate--new-command session command))) (handle (xmtn-automate--new-command session command)))
(xmtn-automate-command-output-lines command-handle))) (xmtn-automate-command-wait-until-finished handle)
(with-current-buffer (xmtn-automate-command-buffer handle)
(goto-char (point-max))
(let (result)
(while (= 0 (forward-line -1))
(setq result (cons (buffer-substring-no-properties
(point)
(progn (end-of-line) (point)))
result)))
(xmtn-automate--cleanup-command handle)
result))))
(defun xmtn-automate-simple-command-output-line (root command) (defun xmtn-automate-command-output-line (root command)
"Return the one line output from mtn automate as a string. "Return the one line output from mtn automate as a string.
Signals an error if output contains zero lines or more than one line." Signals an error if output contains zero lines or more than one line."
(let ((lines (xmtn-automate-simple-command-output-lines root command))) (let ((lines (xmtn-automate-command-output-lines root command)))
(unless (eql (length lines) 1) (unless (eql (length lines) 1)
(error "Expected precisely one line of output from mtn automate, got %s: %s %S" (error "Expected precisely one line of output from mtn automate, got %s: %s %S"
(length lines) (length lines)
@ -287,12 +290,14 @@ Signals an error if output contains zero lines or more than one line."
(defun xmtn-automate-kill-session (root) (defun xmtn-automate-kill-session (root)
"Kill session for ROOT." "Kill session for ROOT."
(interactive) (interactive)
(let ((temp (assoc (dvc-uniquify-file-name root) xmtn-automate--*sessions*))) (let ((session (assoc (dvc-uniquify-file-name root) xmtn-automate--*sessions*)))
;; session may have already been killed ;; session may have already been killed
(when temp (when session
(xmtn-automate--close-session (cdr temp)) (when (xmtn-automate--session-error-file (cdr session))
(delete-file (xmtn-automate--session-error-file session)))
(xmtn-automate--close-session (cdr session))
(setq xmtn-automate--*sessions* (setq xmtn-automate--*sessions*
(delete temp xmtn-automate--*sessions* ))))) (delete session xmtn-automate--*sessions*)))))
(defun xmtn-kill-all-sessions () (defun xmtn-kill-all-sessions ()
"Kill all xmtn-automate sessions." "Kill all xmtn-automate sessions."
@ -671,7 +676,7 @@ Each element of the list is a list; key, signature, name, value, trust."
accu)) accu))
(defun xmtn--heads (root branch) (defun xmtn--heads (root branch)
(xmtn-automate-simple-command-output-lines (xmtn-automate-command-output-lines
root root
(cons (cons
(list "ignore-suspend-certs" "") (list "ignore-suspend-certs" "")
@ -679,8 +684,33 @@ Each element of the list is a list; key, signature, name, value, trust."
(or branch (or branch
(xmtn--tree-default-branch root)))))) (xmtn--tree-default-branch root))))))
(defun xmtn--rev-author (root rev)
"Return first author of REV"
(let (cert-name
result)
(with-temp-buffer
(xmtn-automate-command-output-buffer root (current-buffer) (list "certs" rev))
(goto-char (point-min))
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; signature "ok"
;; name "author"
;; value "beth"
;; trust "trusted"
;;
;; ...
(while (not result)
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-skip-line "signature")
(xmtn-basic-io-check-line "name" (setq cert-name (cadar value)))
(xmtn-basic-io-check-line "value"
(if (string= cert-name "author")
(setq result (cadar value))))
(xmtn-basic-io-skip-line "trust")
(xmtn-basic-io-check-empty)))
result))
(defun xmtn--tree-default-branch (root) (defun xmtn--tree-default-branch (root)
(xmtn-automate-simple-command-output-line root `("get_option" "branch"))) (xmtn-automate-command-output-line root `("get_option" "branch")))
(defun xmtn--get-corresponding-path-raw (root normalized-file-name (defun xmtn--get-corresponding-path-raw (root normalized-file-name
source-revision-hash-id source-revision-hash-id

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

@ -1,6 +1,6 @@
;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone ;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -44,34 +44,38 @@
(defvar xmtn-conflicts-left-work "" (defvar xmtn-conflicts-left-work ""
"Buffer-local variable holding left workspace root.") "Buffer-local variable holding left workspace root.")
(make-variable-buffer-local 'xmtn-conflicts-left-work) (make-variable-buffer-local 'xmtn-conflicts-left-work)
(put 'xmtn-conflicts-left-work 'permanent-local t)
(defvar xmtn-conflicts-right-work "" (defvar xmtn-conflicts-right-work ""
"Buffer-local variable holding right workspace root.") "Buffer-local variable holding right workspace root.")
(make-variable-buffer-local 'xmtn-conflicts-right-work) (make-variable-buffer-local 'xmtn-conflicts-right-work)
(put 'xmtn-conflicts-right-work 'permanent-local t)
(defvar xmtn-conflicts-left-root "" (defvar xmtn-conflicts-left-resolution-root ""
"Buffer-local variable holding left resolution root directory "Buffer-local variable holding left resolution root directory
name; relative to workspace root.") name; relative to workspace root.")
(make-variable-buffer-local 'xmtn-conflicts-left-root) (make-variable-buffer-local 'xmtn-conflicts-left-resolution-root)
(defvar xmtn-conflicts-right-root "" (defvar xmtn-conflicts-right-resolution-root ""
"Buffer-local variable holding right resolution root directory "Buffer-local variable holding right resolution root directory
name; relative to workspace root.") name; relative to workspace root.")
(make-variable-buffer-local 'xmtn-conflicts-right-root) (make-variable-buffer-local 'xmtn-conflicts-right-resolution-root)
(defvar xmtn-conflicts-left-branch "" (defvar xmtn-conflicts-left-branch ""
"Buffer-local variable holding left resolution branch.") "Buffer-local variable holding left branch.")
(make-variable-buffer-local 'xmtn-conflicts-left-branch) (make-variable-buffer-local 'xmtn-conflicts-left-branch)
(put 'xmtn-conflicts-left-branch 'permanent-local t)
(defvar xmtn-conflicts-right-branch "" (defvar xmtn-conflicts-right-branch ""
"Buffer-local variable holding right resolution branch.") "Buffer-local variable holding right branch.")
(make-variable-buffer-local 'xmtn-conflicts-right-branch) (make-variable-buffer-local 'xmtn-conflicts-right-branch)
(put 'xmtn-conflicts-right-branch 'permanent-local t)
(defvar xmtn-conflicts-ancestor-revision "" (defvar xmtn-conflicts-left-author ""
"Buffer-local variable holding left author.")
(make-variable-buffer-local 'xmtn-conflicts-left-author)
(defvar xmtn-conflicts-right-author ""
"Buffer-local variable holding right branch.")
(make-variable-buffer-local 'xmtn-conflicts-right-author)
(defvar xmtn-conflicts-ancestor-revision nil
"Buffer-local variable holding ancestor revision id.") "Buffer-local variable holding ancestor revision id.")
(make-variable-buffer-local 'xmtn-conflicts-ancestor-revision) (make-variable-buffer-local 'xmtn-conflicts-ancestor-revision)
@ -87,10 +91,6 @@
"Count of resolved-internal conflicts.") "Count of resolved-internal conflicts.")
(make-variable-buffer-local 'xmtn-conflicts-resolved-internal-count) (make-variable-buffer-local 'xmtn-conflicts-resolved-internal-count)
(defvar xmtn-conflicts-output-buffer nil
"Buffer to write basic-io to, when saving a conflicts buffer.")
(make-variable-buffer-local 'xmtn-conflicts-output-buffer)
(defvar xmtn-conflicts-current-conflict-buffer nil (defvar xmtn-conflicts-current-conflict-buffer nil
"Global variable for use in ediff quit hook.") "Global variable for use in ediff quit hook.")
;; xmtn-conflicts-current-conflict-buffer cannot be buffer local, ;; xmtn-conflicts-current-conflict-buffer cannot be buffer local,
@ -185,8 +185,8 @@ The elements must all be of type xmtn-conflicts-conflict.")
(make-variable-buffer-local 'xmtn-conflicts-ewoc) (make-variable-buffer-local 'xmtn-conflicts-ewoc)
(defun xmtn-conflicts-parse-header () (defun xmtn-conflicts-parse-header ()
"Fill `xmtn-conflicts-left-revision', `xmtn-conflicts-left-root', "Fill `xmtn-conflicts-left-revision', `xmtn-conflicts-left-resolution-root',
`xmtn-conflicts-right-revision', `xmtn-conflicts-right-root' `xmtn-conflicts-right-revision', `xmtn-conflicts-right-resolution-root'
`xmtn-conflicts-ancestor-revision' with data from conflict `xmtn-conflicts-ancestor-revision' with data from conflict
header." header."
;; left [9a019f3a364416050a8ff5c05f1e44d67a79e393] ;; left [9a019f3a364416050a8ff5c05f1e44d67a79e393]
@ -201,15 +201,16 @@ header."
(setq xmtn-conflicts-ancestor-revision (cadar value))) (setq xmtn-conflicts-ancestor-revision (cadar value)))
(xmtn-basic-io-check-empty) (xmtn-basic-io-check-empty)
;; xmtn-conflicts-left-branch xmtn-conflicts-right-branch set by xmtn-conflicts-load-opts ;; xmtn-conflicts-left-branch, -right-branch, -left-author,
;; -right-author set by xmtn-conflicts-load-opts
(if (string= xmtn-conflicts-left-branch xmtn-conflicts-right-branch) (if (string= xmtn-conflicts-left-branch xmtn-conflicts-right-branch)
(progn (progn
(setq xmtn-conflicts-left-root "_MTN/resolutions/left") (setq xmtn-conflicts-left-resolution-root "_MTN/resolutions/left")
(setq xmtn-conflicts-right-root "_MTN/resolutions/right")) (setq xmtn-conflicts-right-resolution-root "_MTN/resolutions/right"))
(progn (progn
(setq xmtn-conflicts-left-root (concat "_MTN/resolutions/" xmtn-conflicts-left-branch)) (setq xmtn-conflicts-left-resolution-root (concat "_MTN/resolutions/" xmtn-conflicts-left-branch))
(setq xmtn-conflicts-right-root (concat "_MTN/resolutions/" xmtn-conflicts-right-branch)))) (setq xmtn-conflicts-right-resolution-root (concat "_MTN/resolutions/" xmtn-conflicts-right-branch))))
(setq xmtn-conflicts-total-count 0) (setq xmtn-conflicts-total-count 0)
(setq xmtn-conflicts-resolved-count 0) (setq xmtn-conflicts-resolved-count 0)
(setq xmtn-conflicts-resolved-internal-count 0) (setq xmtn-conflicts-resolved-internal-count 0)
@ -476,7 +477,9 @@ header."
xmtn-conflicts-ewoc xmtn-conflicts-ewoc
(concat (concat
(format " Left branch : %s\n" xmtn-conflicts-left-branch) (format " Left branch : %s\n" xmtn-conflicts-left-branch)
(format " Left author : %s\n" xmtn-conflicts-left-author)
(format " Right branch : %s\n" xmtn-conflicts-right-branch) (format " Right branch : %s\n" xmtn-conflicts-right-branch)
(format " Right author : %s\n" xmtn-conflicts-right-author)
(format " Total conflicts : %d\n" xmtn-conflicts-total-count) (format " Total conflicts : %d\n" xmtn-conflicts-total-count)
(format "Resolved conflicts : %d\n" xmtn-conflicts-resolved-count) (format "Resolved conflicts : %d\n" xmtn-conflicts-resolved-count)
) )
@ -491,10 +494,13 @@ header."
(goto-char begin) (goto-char begin)
(xmtn-conflicts-parse-header) (xmtn-conflicts-parse-header)
(if xmtn-conflicts-ancestor-revision (if xmtn-conflicts-ancestor-revision
;; if there is no ancestor revision, then left is ancestor of
;; right or vice versa, and there can be no conflicts.
(xmtn-conflicts-parse-conflicts (1- end)); off-by-one somewhere. (xmtn-conflicts-parse-conflicts (1- end)); off-by-one somewhere.
;; else no conflicts ;; else no conflicts
) )
(let ((inhibit-read-only t)) (delete-region begin (1- end))) (let ((inhibit-read-only t)) (delete-region begin (1- end)))
(xmtn-conflicts-load-opts)
(xmtn-conflicts-set-hf) (xmtn-conflicts-set-hf)
(set-buffer-modified-p nil) (set-buffer-modified-p nil)
(point-max)) (point-max))
@ -509,7 +515,7 @@ header."
;; point, and inserts empty header and footer lines. ;; point, and inserts empty header and footer lines.
(goto-char (point-max)) (goto-char (point-max))
(let ((text-end (point))) (let ((text-end (point)))
(xmtn-conflicts-mode) (xmtn-conflicts-mode) ;; kills non-permanent buffer-local variables
(xmtn-conflicts-read (point-min) text-end)) (xmtn-conflicts-read (point-min) text-end))
(set-buffer-modified-p nil) (set-buffer-modified-p nil)
@ -517,10 +523,10 @@ header."
(xmtn-conflicts-next nil t)) (xmtn-conflicts-next nil t))
(defun xmtn-conflicts-write-header (ewoc-buffer) (defun xmtn-conflicts-write-header (ewoc-buffer)
"Write EWOC-BUFFER header info in basic-io format to current buffer." "Write revisions from EWOC-BUFFER header info in basic-io format to current buffer."
(xmtn-basic-io-write-id "left" (with-current-buffer ewoc-buffer xmtn-conflicts-left-revision)) (xmtn-basic-io-write-id "left" (with-current-buffer ewoc-buffer xmtn-conflicts-left-revision))
(xmtn-basic-io-write-id "right" (with-current-buffer ewoc-buffer xmtn-conflicts-right-revision)) (xmtn-basic-io-write-id "right" (with-current-buffer ewoc-buffer xmtn-conflicts-right-revision))
(if xmtn-conflicts-ancestor-revision (if (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision)
(xmtn-basic-io-write-id "ancestor" (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision))) (xmtn-basic-io-write-id "ancestor" (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision)))
) )
@ -672,13 +678,13 @@ header."
(xmtn-basic-io-write-str "resolved_rename_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict)))) (xmtn-basic-io-write-str "resolved_rename_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict))))
)))) ))))
(defun xmtn-conflicts-write-conflicts (ewoc) (defun xmtn-conflicts-write-conflicts (ewoc buffer)
"Write EWOC elements in basic-io format to xmtn-conflicts-output-buffer." "Write EWOC elements in basic-io format to BUFFER."
(setq xmtn-conflicts-resolved-count 0) (setq xmtn-conflicts-resolved-count 0)
(setq xmtn-conflicts-resolved-internal-count 0) (setq xmtn-conflicts-resolved-internal-count 0)
(ewoc-map (ewoc-map
(lambda (conflict) (lambda (conflict)
(with-current-buffer xmtn-conflicts-output-buffer (with-current-buffer buffer
(ecase (xmtn-conflicts-conflict-conflict_type conflict) (ecase (xmtn-conflicts-conflict-conflict_type conflict)
(content (content
(xmtn-conflicts-write-content conflict)) (xmtn-conflicts-write-content conflict))
@ -693,20 +699,16 @@ header."
"Replace region BEGIN END with EWOC-BUFFER ewoc in basic-io format." "Replace region BEGIN END with EWOC-BUFFER ewoc in basic-io format."
(delete-region begin end) (delete-region begin end)
(xmtn-conflicts-write-header ewoc-buffer) (xmtn-conflicts-write-header ewoc-buffer)
;; ewoc-map sets current-buffer to ewoc-buffer, so we need a (let ((ewoc (with-current-buffer ewoc-buffer xmtn-conflicts-ewoc)))
;; reference to the current buffer. (xmtn-conflicts-write-conflicts ewoc (current-buffer))
(let ((xmtn-conflicts-output-buffer (current-buffer))
(ewoc (with-current-buffer ewoc-buffer xmtn-conflicts-ewoc))) ;; 'update' not needed for save, but it's nice for the user
(xmtn-conflicts-write-conflicts ewoc) (with-current-buffer ewoc-buffer (xmtn-conflicts-update-counts))
(with-current-buffer ewoc-buffer (xmtn-conflicts-set-hf))
)) ))
;; Arrange for xmtn-conflicts-save to be called by save-buffer. We do ;; Arrange for xmtn-conflicts-save to be called by save-buffer. We
;; not automatically convert in insert-file-contents, because we don't ;; also set after-insert-file-functions to a buffer-local value in
;; want to convert _all_ conflict files (consider the monotone test ;; xmtn-conflicts-mode.
;; suite!). Instead, we call xmtn-conflicts-read explicitly from
;; xmtn-conflicts-review, and set after-insert-file-functions to a
;; buffer-local value in xmtn-conflicts-mode.
(add-to-list 'format-alist (add-to-list 'format-alist
'(xmtn-conflicts-format '(xmtn-conflicts-format
"Save conflicts in basic-io format." "Save conflicts in basic-io format."
@ -719,6 +721,7 @@ header."
(defun xmtn-conflicts-update-counts () (defun xmtn-conflicts-update-counts ()
"Update resolved counts." "Update resolved counts."
(interactive)
(setq xmtn-conflicts-resolved-count 0) (setq xmtn-conflicts-resolved-count 0)
(setq xmtn-conflicts-resolved-internal-count 0) (setq xmtn-conflicts-resolved-internal-count 0)
@ -742,7 +745,8 @@ header."
(setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)))) (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count))))
)) ))
xmtn-conflicts-ewoc)) xmtn-conflicts-ewoc)
(xmtn-conflicts-set-hf))
(dvc-make-ewoc-next xmtn-conflicts-next xmtn-conflicts-ewoc) (dvc-make-ewoc-next xmtn-conflicts-next xmtn-conflicts-ewoc)
(dvc-make-ewoc-prev xmtn-conflicts-prev xmtn-conflicts-ewoc) (dvc-make-ewoc-prev xmtn-conflicts-prev xmtn-conflicts-ewoc)
@ -845,11 +849,11 @@ header."
(xmtn-conflicts-conflict-ancestor_name conflict)))) (xmtn-conflicts-conflict-ancestor_name conflict))))
(file-left (xmtn-conflicts-get-file xmtn-conflicts-left-work (file-left (xmtn-conflicts-get-file xmtn-conflicts-left-work
(xmtn-conflicts-conflict-left_file_id conflict) (xmtn-conflicts-conflict-left_file_id conflict)
xmtn-conflicts-left-root xmtn-conflicts-left-resolution-root
(xmtn-conflicts-conflict-left_name conflict))) (xmtn-conflicts-conflict-left_name conflict)))
(file-right (xmtn-conflicts-get-file xmtn-conflicts-right-work (file-right (xmtn-conflicts-get-file xmtn-conflicts-right-work
(xmtn-conflicts-conflict-right_file_id conflict) (xmtn-conflicts-conflict-right_file_id conflict)
xmtn-conflicts-right-root xmtn-conflicts-right-resolution-root
(xmtn-conflicts-conflict-right_name conflict))) (xmtn-conflicts-conflict-right_name conflict)))
(result-file (concat "_MTN/resolutions/result/" (xmtn-conflicts-conflict-right_name conflict))) ) (result-file (concat "_MTN/resolutions/result/" (xmtn-conflicts-conflict-right_name conflict))) )
@ -1137,22 +1141,6 @@ non-nil, show log-edit buffer in other frame."
(insert ": ") (insert ": ")
)) ))
(defun xmtn-conflicts-do-propagate (&optional cached-branch)
"Perform propagate on revisions in current conflict buffer."
(interactive)
(save-some-buffers t); log buffer
;; save-some-buffers does not save the conflicts buffer, which is the current buffer
(save-buffer)
(xmtn-propagate-from xmtn-conflicts-left-branch cached-branch))
(defun xmtn-conflicts-do-merge ()
"Perform merge on revisions in current conflict buffer."
(interactive)
(save-some-buffers t); log buffer
;; save-some-buffers does not save the conflicts buffer, which is the current buffer
(save-buffer)
(xmtn-dvc-merge-1 default-directory nil))
(defun xmtn-conflicts-ediff-resolution-ws () (defun xmtn-conflicts-ediff-resolution-ws ()
"Ediff current resolution file against workspace." "Ediff current resolution file against workspace."
(interactive) (interactive)
@ -1177,22 +1165,18 @@ non-nil, show log-edit buffer in other frame."
(define-key map [?q] 'dvc-buffer-quit) (define-key map [?q] 'dvc-buffer-quit)
(define-key map [?r] xmtn-conflicts-resolve-map) (define-key map [?r] xmtn-conflicts-resolve-map)
(define-key map [?t] 'xmtn-conflicts-add-log-entry) (define-key map [?t] 'xmtn-conflicts-add-log-entry)
(define-key map [?u] 'xmtn-conflicts-update-counts)
(define-key map "\M-d" xmtn-conflicts-resolve-map) (define-key map "\M-d" xmtn-conflicts-resolve-map)
(define-key map "MM" 'xmtn-conflicts-do-merge)
(define-key map "MP" 'xmtn-conflicts-do-propagate)
(define-key map "MU" 'dvc-update)
map) map)
"Keymap used in `xmtn-conflicts-mode'.") "Keymap used in `xmtn-conflicts-mode'.")
(easy-menu-define xmtn-conflicts-mode-menu xmtn-conflicts-mode-map (easy-menu-define xmtn-conflicts-mode-menu xmtn-conflicts-mode-map
"`xmtn-conflicts' menu" "`xmtn-conflicts' menu"
`("Mtn-conflicts" `("Mtn-conflicts"
["Clear resolution" xmtn-conflicts-clear-resolution t] ["Clear resolution" xmtn-conflicts-clear-resolution t]
["Ediff resolution to ws" xmtn-conflicts-ediff-resolution-ws t] ["Ediff resolution to ws" xmtn-conflicts-ediff-resolution-ws t]
["Propagate" xmtn-conflicts-do-propagate t] ["Add log entry" xmtn-conflicts-add-log-entry t]
["Merge" xmtn-conflicts-do-merge t] ["Clean" xmtn-conflicts-clean t]
["Update" dvc-update t]
["Clean" xmtn-conflicts-clean t]
)) ))
;; derive from nil causes no keymap to be used, but still have self-insert keys ;; derive from nil causes no keymap to be used, but still have self-insert keys
@ -1217,20 +1201,23 @@ non-nil, show log-edit buffer in other frame."
(defconst xmtn-conflicts-opts-file "_MTN/dvc-conflicts-opts") (defconst xmtn-conflicts-opts-file "_MTN/dvc-conflicts-opts")
(defun xmtn-conflicts-save-opts (left-work right-work &optional left-branch right-branch) (defun xmtn-conflicts-save-opts (left-work right-work left-branch right-branch left-rev right-rev)
"Store LEFT-WORK, RIGHT-WORK in `xmtn-conflicts-opts-file', for "Store LEFT-*, RIGHT-* in `xmtn-conflicts-opts-file', for
retrieval by `xmtn-conflicts-load-opts'." retrieval by `xmtn-conflicts-load-opts'."
;; need correct buffer-local variable names for load-opts
(let ((xmtn-conflicts-left-work left-work) (let ((xmtn-conflicts-left-work left-work)
(xmtn-conflicts-right-work right-work) (xmtn-conflicts-right-work right-work)
(xmtn-conflicts-left-branch (or left-branch (xmtn-conflicts-left-branch left-branch)
(xmtn--tree-default-branch left-work))) (xmtn-conflicts-right-branch right-branch)
(xmtn-conflicts-right-branch (or right-branch (xmtn-conflicts-left-author (xmtn--rev-author left-work left-rev))
(xmtn--tree-default-branch right-work)))) (xmtn-conflicts-right-author (xmtn--rev-author right-work right-rev)))
(dvc-save-state (list 'xmtn-conflicts-left-work (dvc-save-state (list 'xmtn-conflicts-left-work
'xmtn-conflicts-left-branch 'xmtn-conflicts-left-branch
'xmtn-conflicts-left-author
'xmtn-conflicts-right-work 'xmtn-conflicts-right-work
'xmtn-conflicts-right-branch) 'xmtn-conflicts-right-branch
'xmtn-conflicts-right-author)
(concat (file-name-as-directory right-work) xmtn-conflicts-opts-file)) (concat (file-name-as-directory right-work) xmtn-conflicts-opts-file))
)) ))
@ -1244,132 +1231,88 @@ root where options file is stored."
;; When reviewing conflicts after a merge is complete, the options file is not present ;; When reviewing conflicts after a merge is complete, the options file is not present
(message "%s options file not found" opts-file)))) (message "%s options file not found" opts-file))))
(defun xmtn-conflicts-1 (left-work left-rev right-work right-rev) (defun xmtn-conflicts-load-file ()
"Load _MTN/conflicts for default-directory."
(dvc-switch-to-buffer-maybe (dvc-get-buffer-create 'xmtn 'conflicts default-directory))
(setq buffer-read-only nil)
(set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file))
(insert-file-contents "_MTN/conflicts" t nil nil t))
(defun xmtn-conflicts-1 (left-work left-rev right-work right-rev &optional left-branch right-branch)
"List conflicts between LEFT-REV and RIGHT-REV "List conflicts between LEFT-REV and RIGHT-REV
revisions (monotone revision specs; if nil, defaults to heads of revisions (monotone revision specs; if nil, defaults to heads of
respective workspace branches) in LEFT-WORK and RIGHT-WORK respective workspace branches) in LEFT-WORK and RIGHT-WORK
workspaces (strings). Allow specifying resolutions, propagating workspaces (strings). Allow specifying resolutions, propagating
to right. Stores conflict file in RIGHT-WORK/_MTN." to right. Stores conflict file in RIGHT-WORK/_MTN."
(let ((default-directory right-work)) (let ((default-directory right-work))
(xmtn-conflicts-save-opts left-work right-work) (xmtn-conflicts-save-opts left-work right-work left-branch right-branch left-rev right-rev)
(dvc-run-dvc-async (xmtn-automate-command-output-file
'xmtn default-directory
(list "conflicts" "store" left-rev right-rev) "_MTN/conflicts"
:finished (lambda (output error status arguments) (list "show_conflicts" left-rev right-rev))
(xmtn-conflicts-review default-directory)) (xmtn-conflicts-load-file)))
:error (lambda (output error status arguments) (defun xmtn-conflicts-review (left-work left-rev right-work right-rev left-branch right-branch show)
(pop-to-buffer error)) "Review conflicts between LEFT-WORK (a directory), rev LEFT-REV,
))) and RIGHT-WORK, rev RIGHT-REV. If LEFT_WORK/_MTN/conflicts
exists and is current, display it. Otherwise generate a new
RIGHT_WORK/_MTN/conflicts file and display that. Return the
conflicts buffer."
(let ((default-directory right-work)
(dvc-switch-to-buffer-first show))
(if (file-exists-p "_MTN/conflicts")
(progn
(xmtn-conflicts-load-file)
(if (not (and (string-equal xmtn-conflicts-left-revision left-rev)
(string-equal xmtn-conflicts-left-work left-work)
(string-equal xmtn-conflicts-right-revision right-rev)
(string-equal xmtn-conflicts-right-work right-work)))
;; file not current; regenerate
(xmtn-conflicts-1 left-work left-rev right-work right-rev left-branch right-branch)))
(defun xmtn-check-workspace-for-propagate (work cached-branch) ;; else generate new file
"Check that workspace WORK is ready for propagate. (xmtn-conflicts-1 left-work left-rev right-work right-rev left-branch right-branch)))
It must be merged, and should be at the head revision, and have no local changes." (current-buffer))
(let* ((default-directory work)
(heads (xmtn--heads default-directory cached-branch))
(base (xmtn--get-base-revision-hash-id-or-null default-directory)))
(message "checking %s for multiple heads, base not head" work) (defun xmtn-conflicts-status (buffer left-work left-rev right-work right-rev left-branch right-branch)
"Return '(status buffer), where status is one of 'need-resolve
| 'need-review-resolve-internal | 'resolved | 'none for
BUFFER. Regenerate conflicts if not current. Conflicts stored in
RIGHT-WORK."
(if (buffer-live-p buffer)
;; check if buffer still current
(with-current-buffer buffer
(let ((revs-current
(and (string= left-rev xmtn-conflicts-left-revision)
(string= right-rev xmtn-conflicts-right-revision))))
(if revs-current
(progn
(xmtn-conflicts-update-counts)
(save-buffer))
;; else reload or regenerate
(save-excursion
(setq buffer
(xmtn-conflicts-review
left-work left-rev right-work right-rev left-branch right-branch nil))))))
(if (> 1 (length heads)) ;; else reload or regenerate
(error "%s has multiple heads; can't propagate" work)) (save-excursion
(setq buffer
(xmtn-conflicts-review
left-work left-rev right-work right-rev left-branch right-branch nil))))
(if (not (string= base (nth 0 heads))) ;; compute status
(error "Aborting due to %s not at head" work)) (with-current-buffer buffer
(case xmtn-conflicts-total-count
;; check for local changes (0 (list buffer 'none))
(message "checking %s for local changes" work) (t
(cond
(dvc-run-dvc-sync ((= xmtn-conflicts-total-count xmtn-conflicts-resolved-count)
'xmtn (if (> xmtn-conflicts-resolved-internal-count 0)
(list "status") (list buffer 'need-review-resolve-internal)
:finished (lambda (output error status arguments) (list buffer 'resolved)))
;; we don't get an error status for not up-to-date, (t
;; so parse the output. (list buffer 'need-resolve)))))))
;; FIXME: add option to automate inventory to just return status; can return on first change
;; FIXME: 'patch' may be internationalized.
(set-buffer output)
(goto-char (point-min))
(if (search-forward "patch" (point-max) t)
(if (not (yes-or-no-p (format "%s has local changes; really show conflicts? " work)))
(error "aborting due to local changes"))))
:error (lambda (output error status arguments)
(pop-to-buffer error))))
)
(defun xmtn-check-propagate-needed (left-work right-work)
"Throw error unless branch in workspace LEFT-WORK needs to be propagated to RIGHT-WORK."
;; We assume xmtn-check-workspace-for-propagate has already been run
;; on left-work, right-work, so just check if they have the same
;; base revision, or the target (right) base revision is a
;; descendant of the source.
(message "checking if propagate needed")
(let ((left-base (xmtn--get-base-revision-hash-id-or-null left-work))
(right-base (xmtn--get-base-revision-hash-id-or-null right-work)))
(if (string= left-base right-base)
(error "don't need to propagate")
;; check for right descendant of left
(let ((descendents (xmtn-automate-simple-command-output-lines left-work (list "descendents" left-base))))
(while descendents
(if (string= right-base (car descendents))
(error "don't need to propagate"))
(setq descendents (cdr descendents)))))
))
;;;###autoload
(defun xmtn-conflicts-propagate (left-work right-work)
"List conflicts for a propagate from LEFT-WORK to RIGHT-WORK workspace branch head revisions.
Allow specifying resolutions. LEFT-WORK and RIGHT-WORK are strings giving
workspace directories; prompted if nil. Review is done in RIGHT-WORK
workspace."
(interactive "i\ni")
(setq left-work (dvc-read-project-tree-maybe "Propagate from (workspace directory): " left-work))
(setq right-work (dvc-read-project-tree-maybe "to (workspace directory): " right-work))
(let ((left-branch (xmtn--tree-default-branch left-work))
(right-branch (xmtn--tree-default-branch right-work)))
(xmtn-check-workspace-for-propagate left-work left-branch)
(xmtn-check-workspace-for-propagate right-work right-branch)
(xmtn-check-propagate-needed left-work right-work)
(message "computing conflicts")
(xmtn-conflicts-1 left-work
(car (xmtn--heads left-work left-branch))
right-work
(car (xmtn--heads right-work right-branch)))))
;;;###autoload
(defun xmtn-conflicts-merge ()
"List conflicts between current head revisions."
(interactive)
(let ((default-directory
(dvc-read-project-tree-maybe "Review conflicts in (workspace directory): ")))
(xmtn-conflicts-1 default-directory nil default-directory nil)))
;;;###autoload
(defun xmtn-conflicts-review (&optional workspace)
"Review conflicts for WORKSPACE (a directory; default prompt)."
(interactive)
(let ((default-directory
(dvc-read-project-tree-maybe "Review conflicts for (workspace directory): "
(when workspace (expand-file-name workspace))))
(file-name "_MTN/conflicts"))
(if (not (file-exists-p file-name))
(error "conflicts file not found"))
(let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory)))
(dvc-switch-to-buffer-maybe conflicts-buffer)
(setq buffer-read-only nil)
(xmtn-conflicts-load-opts)
(set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file))
(insert-file-contents "_MTN/conflicts" t nil nil t))))
;;;###autoload ;;;###autoload
(defun xmtn-conflicts-clean (&optional workspace) (defun xmtn-conflicts-clean (&optional workspace)

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

@ -1,6 +1,6 @@
;;; xmtn-dvc.el --- DVC backend for monotone ;;; xmtn-dvc.el --- DVC backend for monotone
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler ;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -95,35 +95,17 @@
"_MTN/log")) "_MTN/log"))
(defun xmtn--toposort (root revision-hash-ids) (defun xmtn--toposort (root revision-hash-ids)
(xmtn-automate-simple-command-output-lines root (xmtn-automate-command-output-lines root
`("toposort" `("toposort"
,@revision-hash-ids))) ,@revision-hash-ids)))
(add-to-list 'format-alist
'(xmtn--log-file
"This format automatically removes xmtn's log edit hints from
the file before saving."
nil
xmtn--log-file-format-from-fn
xmtn--log-file-format-to-fn
t
nil
nil))
(defun xmtn--log-file-format-from-fn (begin end)
(xmtn--assert-nil))
(defun xmtn--log-file-format-to-fn (begin end buffer)
(dvc-log-flush-commit-file-list))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-log-edit (root other-frame no-init) (defun xmtn-dvc-log-edit (root other-frame no-init)
(if no-init (if no-init
(dvc-dvc-log-edit root other-frame no-init) (dvc-dvc-log-edit root other-frame no-init)
(progn (progn
(dvc-dvc-log-edit root other-frame nil) (dvc-dvc-log-edit root other-frame nil)
(setq buffer-file-coding-system 'xmtn--monotone-normal-form) ;; FIXME: move this into dvc-get-buffer-create? (setq buffer-file-coding-system 'xmtn--monotone-normal-form)
(add-to-list 'buffer-file-format 'xmtn--log-file) ;; FIXME: generalize to dvc--log-file
))) )))
(defun xmtn-dvc-log-message () (defun xmtn-dvc-log-message ()
@ -158,7 +140,6 @@ the file before saving."
(if session (xmtn-automate--close-session session))) (if session (xmtn-automate--close-session session)))
(read-from-minibuffer "branch: " (xmtn--tree-default-branch root))) (read-from-minibuffer "branch: " (xmtn--tree-default-branch root)))
(xmtn--tree-default-branch root)))) (xmtn--tree-default-branch root))))
;; Saving the buffer will automatically delete any log edit hints.
(save-buffer) (save-buffer)
(dvc-save-some-buffers root) (dvc-save-some-buffers root)
@ -230,6 +211,48 @@ the file before saving."
(message "%s... " progress-message)) (message "%s... " progress-message))
(set-window-configuration dvc-pre-commit-window-configuration))) (set-window-configuration dvc-pre-commit-window-configuration)))
(defun xmtn-show-commit ()
"Show commit command for use on command line"
(interactive)
(let ((excluded-files
(with-current-buffer dvc-partner-buffer
(xmtn--normalize-file-names default-directory (dvc-fileinfo-excluded-files)))))
(save-buffer)
(dvc-save-some-buffers default-directory)
;; check that the first line says something; it should be a summary of the rest
(goto-char (point-min))
(forward-line)
(if (= (point) (1+ (point-min)))
(error "Please put a summary comment on the first line"))
(message
(concat
"mtn commit "
(xmtn-dvc-log-message)
" "
(if excluded-files
(mapconcat (lambda (file) (concat "--exclude=" file)) excluded-files " "))))
(pop-to-buffer "*Messages*")))
;; Add xmtn-show-commit to dvc-log-edit menu
(defvar xmtn-log-edit-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [(control ?c) (control ?s)] 'xmtn-show-commit)
map))
(easy-menu-define xmtn-log-edit-mode-menu xmtn-log-edit-mode-map
"Mtn specific log-edit menu."
`("DVC-Mtn"
["Show commit command" xmtn-show-commit t]
))
(define-derived-mode xmtn-log-edit-mode dvc-log-edit-mode "xmtn-log-edit"
"Add back-end-specific commands for dvc-log-edit.")
(dvc-add-uniquify-directory-mode 'xmtn-log-edit-mode)
;; The term "normalization" here has nothing to do with Unicode ;; The term "normalization" here has nothing to do with Unicode
;; normalization. ;; normalization.
(defun xmtn--normalize-file-name (root file-name) (defun xmtn--normalize-file-name (root file-name)
@ -356,20 +379,6 @@ the file before saving."
(message "Tree %s has no base revision" root)))) (message "Tree %s has no base revision" root))))
;;;###autoload
(defun xmtn-dvc-search-file-in-diff (file)
(re-search-forward
(let ((quoted-file (regexp-quote file)))
(concat "^\\(\\("
"\\+\\+\\+ " quoted-file
"\\)\\|\\("
;; FIXME: What `dvc-diff-diff-or-list' does doesn't work
;; for this case, since `diff-hunk-next' doesn't recognize
;; mtn's output for this case as a diff hunk.
"# " quoted-file " is binary"
"\\)\\)$"))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-diff (&optional rev path dont-switch) (defun xmtn-dvc-diff (&optional rev path dont-switch)
;; If rev is an ancestor of base-rev of path, then rev is from, path ;; If rev is an ancestor of base-rev of path, then rev is from, path
@ -383,7 +392,7 @@ the file before saving."
(if (string= rev-string base) (if (string= rev-string base)
;; local changes in workspace are 'to' ;; local changes in workspace are 'to'
(xmtn-dvc-delta rev workspace dont-switch) (xmtn-dvc-delta rev workspace dont-switch)
(let ((descendents (xmtn-automate-simple-command-output-lines path (list "descendents" base))) (let ((descendents (xmtn-automate-command-output-lines path (list "descendents" base)))
(done nil)) (done nil))
(while descendents (while descendents
(if (string= rev-string (car descendents)) (if (string= rev-string (car descendents))
@ -396,45 +405,14 @@ the file before saving."
;; rev is ancestor of workspace; workspace is 'to' ;; rev is ancestor of workspace; workspace is 'to'
(xmtn-dvc-delta rev workspace dont-switch)))))) (xmtn-dvc-delta rev workspace dont-switch))))))
(defvar xmtn-diff-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "CM" 'xmtn-conflicts-merge)
(define-key map "CP" 'xmtn-conflicts-propagate)
(define-key map "CR" 'xmtn-conflicts-review)
(define-key map "CC" 'xmtn-conflicts-clean)
(define-key map "MH" 'xmtn-view-heads-revlist)
(define-key map "MP" 'xmtn-propagate-from)
map))
;; items added here should probably also be added to xmtn-revlist-mode-menu, -map in xmtn-revlist.el
(easy-menu-define xmtn-diff-mode-menu xmtn-diff-mode-map
"Mtn specific diff menu."
`("DVC-Mtn"
["View Heads" xmtn-view-heads-revlist t]
["Show propagate conflicts" xmtn-conflicts-propagate t]
["Review conflicts" xmtn-conflicts-review t]
["Propagate branch" xmtn-propagate-from t]
["Clean conflicts resolutions" xmtn-conflicts-clean t]
))
(define-derived-mode xmtn-diff-mode dvc-diff-mode "xmtn-diff"
"Add back-end-specific commands for dvc-diff.")
(dvc-add-uniquify-directory-mode 'xmtn-diff-mode)
(defun xmtn--rev-to-option (resolved from) (defun xmtn--rev-to-option (resolved from)
"Return a string contaiing the mtn diff command-line option for RESOLVED-REV. "Return a string contaiing the mtn diff command-line option for RESOLVED.
If FROM is non-nil, RESOLVED-REV is assumed older than workspace; If FROM is non-nil, RESOLVED is assumed older than workspace;
otherwise newer." otherwise newer."
(ecase (car resolved) (ecase (car resolved)
('local-tree ('local-tree
(if from (if from
(progn "--reverse"
;; FIXME: --reverse is not in mtn 0.44; bump overall
;; required version on new mtn release
(let ((xmtn--minimum-required-command-version '(0 45)))
(xmtn--check-cached-command-version)
"--reverse"))
"")) ""))
('revision (concat "--revision=" (cadr resolved))))) ('revision (concat "--revision=" (cadr resolved)))))
@ -466,32 +444,6 @@ otherwise newer."
;; The call site in `dvc-revlist-diff' needs this return value. ;; The call site in `dvc-revlist-diff' needs this return value.
diff-buffer))) diff-buffer)))
(defvar xmtn-status-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "CM" 'xmtn-conflicts-merge)
(define-key map "CP" 'xmtn-conflicts-propagate)
(define-key map "CR" 'xmtn-conflicts-review)
(define-key map "CC" 'xmtn-conflicts-clean)
(define-key map "MP" 'xmtn-propagate-from)
(define-key map "MH" 'xmtn-view-heads-revlist)
map))
(easy-menu-define xmtn-status-mode-menu xmtn-status-mode-map
"Mtn specific status menu."
`("DVC-Mtn"
["View Heads" xmtn-view-heads-revlist t]
["Show merge conflicts" xmtn-conflicts-merge t]
["Show propagate conflicts" xmtn-conflicts-propagate t]
["Review conflicts" xmtn-conflicts-review t]
["Propagate branch" xmtn-propagate-from t]
["Clean conflicts resolutions" xmtn-conflicts-clean t]
))
(define-derived-mode xmtn-status-mode dvc-status-mode "xmtn-status"
"Add back-end-specific commands for dvc-status.")
(add-to-list 'uniquify-list-buffers-directory-modes 'xmtn-status-mode)
(defun xmtn--remove-content-hashes-from-diff () (defun xmtn--remove-content-hashes-from-diff ()
;; Hack: Remove mtn's file content hashes from diff headings since ;; Hack: Remove mtn's file content hashes from diff headings since
;; `dvc-diff-diff-or-list' and `dvc-diff-find-file-name' gets ;; `dvc-diff-diff-or-list' and `dvc-diff-find-file-name' gets
@ -514,16 +466,6 @@ otherwise newer."
(defun xmtn-dvc-command-version () (defun xmtn-dvc-command-version ()
(fourth (xmtn--command-version xmtn-executable))) (fourth (xmtn--command-version xmtn-executable)))
(defvar xmtn-dvc-automate-version nil
"Cached value of mtn automate interface version.")
(defun xmtn-dvc-automate-version ()
"Return mtn automate version as a number."
(if xmtn-dvc-automate-version
xmtn-dvc-automate-version
(setq xmtn-dvc-automate-version
(string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))
(defun xmtn--changes-image (change) (defun xmtn--changes-image (change)
(ecase change (ecase change
(content "content") (content "content")
@ -702,7 +644,6 @@ otherwise newer."
(dvc-status-prepare-buffer (dvc-status-prepare-buffer
'xmtn 'xmtn
root root
;; FIXME: just pass header
;; base-revision ;; base-revision
(if base-revision (format "%s" base-revision) "none") (if base-revision (format "%s" base-revision) "none")
;; branch ;; branch
@ -746,8 +687,7 @@ otherwise newer."
:text (concat " no changes in workspace"))) :text (concat " no changes in workspace")))
(ewoc-refresh dvc-fileinfo-ewoc))))) (ewoc-refresh dvc-fileinfo-ewoc)))))
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
;; FIXME: need `dvc-status-error-in-process', or change name. (dvc-diff-error-in-process ;; correct for status-mode as well
(dvc-diff-error-in-process
status-buffer status-buffer
(format "Error running mtn with arguments %S" arguments) (format "Error running mtn with arguments %S" arguments)
output error)) output error))
@ -929,7 +869,6 @@ otherwise newer."
(1 (format "%s" (first normalized-file-names))) (1 (format "%s" (first normalized-file-names)))
(t (format "%s files/directories" (t (format "%s files/directories"
(length normalized-file-names)))))) (length normalized-file-names))))))
;; FIXME: confirm should be in upper level DVC code.
(when (or (not dvc-confirm-ignore) (when (or (not dvc-confirm-ignore)
(y-or-n-p (format "Ignore %s in monotone tree %s? " msg root))) (y-or-n-p (format "Ignore %s in monotone tree %s? " msg root)))
(xmtn--add-patterns-to-mtnignore (xmtn--add-patterns-to-mtnignore
@ -970,7 +909,7 @@ otherwise newer."
(xmtn--add-files (dvc-tree-root) files)) (xmtn--add-files (dvc-tree-root) files))
;; Appears redundant, given that there is `xmtn-dvc-add-files'. But ;; Appears redundant, given that there is `xmtn-dvc-add-files'. But
;; it's part of the DVC API. FIXME. ;; it's part of the DVC API.
;;;###autoload ;;;###autoload
(defun xmtn-dvc-add (file) (defun xmtn-dvc-add (file)
(xmtn--add-files (dvc-tree-root) (list file))) (xmtn--add-files (dvc-tree-root) (list file)))
@ -1156,7 +1095,9 @@ finished."
nil) nil)
(defun xmtn-propagate-from (other &optional cached-branch) (defun xmtn-propagate-from (other &optional cached-branch)
"Propagate from OTHER branch to local tree branch." "Propagate from OTHER branch to CACHED-BRANCH (default local tree branch).
Conflict resolution taken from `default-directory', which must be
a workspace for CACHED-BRANCH."
(interactive "MPropagate from branch: ") (interactive "MPropagate from branch: ")
(let* (let*
((root (dvc-tree-root)) ((root (dvc-tree-root))
@ -1232,7 +1173,7 @@ finished."
;; mtn progress messages are put to stderr, and there is typically ;; mtn progress messages are put to stderr, and there is typically
;; nothing written to stdout from this command, so put both in the ;; nothing written to stdout from this command, so put both in the
;; same buffer. ;; same buffer.
;; FIXME: this output is not useful; need to use automation ;; This output is not useful; xmtn-sync, xmtn-sync-review is much better
(xmtn--run-command-async root `("pull" ,other) (xmtn--run-command-async root `("pull" ,other)
:output-buffer name :output-buffer name
:error-buffer name :error-buffer name
@ -1475,7 +1416,7 @@ finished."
(defun xmtn--file-contents-as-string (root content-hash-id) (defun xmtn--file-contents-as-string (root content-hash-id)
(check-type content-hash-id xmtn--hash-id) (check-type content-hash-id xmtn--hash-id)
(xmtn-automate-simple-command-output-string (xmtn-automate-command-output-string
root `("get_file" ,content-hash-id))) root `("get_file" ,content-hash-id)))
<<<<<<< TREE <<<<<<< TREE

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

@ -1,6 +1,6 @@
;;; xmtn-ids.el --- Resolver routines for xmtn revision ids ;;; xmtn-ids.el --- Resolver routines for xmtn revision ids
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -145,7 +145,7 @@ See file commentary for details."
(defun xmtn--get-parent-revision-hash-id (root hash-id local-branch) (defun xmtn--get-parent-revision-hash-id (root hash-id local-branch)
(check-type hash-id xmtn--hash-id) (check-type hash-id xmtn--hash-id)
(let ((parents (xmtn-automate-simple-command-output-lines root `("parents" (let ((parents (xmtn-automate-command-output-lines root `("parents"
,hash-id)))) ,hash-id))))
(case (length parents) (case (length parents)
(0 (error "Revision has no parents: %s" hash-id)) (0 (error "Revision has no parents: %s" hash-id))
@ -192,7 +192,7 @@ See file commentary for details."
nil) nil)
(defun xmtn--expand-selector (root selector) (defun xmtn--expand-selector (root selector)
(xmtn-automate-simple-command-output-lines root `("select" ,selector))) (xmtn-automate-command-output-lines root `("select" ,selector)))
(defun xmtn--branch-of (root hash-id) (defun xmtn--branch-of (root hash-id)
(let ((certs (xmtn--list-parsed-certs root hash-id)) (let ((certs (xmtn--list-parsed-certs root hash-id))
@ -227,7 +227,7 @@ must be a workspace."
result)) result))
(defun xmtn--get-base-revision-hash-id-or-null (root) (defun xmtn--get-base-revision-hash-id-or-null (root)
(let ((hash-id (xmtn-automate-simple-command-output-line (let ((hash-id (xmtn-automate-command-output-line
root `("get_base_revision_id")))) root `("get_base_revision_id"))))
(when (equal hash-id "") (setq hash-id nil)) (when (equal hash-id "") (setq hash-id nil))
(assert (typep hash-id '(or xmtn--hash-id null))) (assert (typep hash-id '(or xmtn--hash-id null)))

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

@ -1,6 +1,6 @@
;;; xmtn-status.el --- manage actions for multiple projects ;;; xmtn-status.el --- manage actions for multiple projects
;; Copyright (C) 2009 - 2010 Stephen Leake ;; Copyright (C) 2009 - 2011 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -44,9 +44,9 @@ The elements must all be of class xmtn-status-data.")
(defstruct (xmtn-status-data (:copier nil)) (defstruct (xmtn-status-data (:copier nil))
work ; workspace directory name relative to xmtn-status-root work ; workspace directory name relative to xmtn-status-root
branch ; branch name (all workspaces have same branch; assumed never changes) branch ; GDS branch name (all workspaces have same branch; assumed never changes)
need-refresh ; nil | t : if an async process was started that invalidates state data need-refresh ; nil | t : if an async process was started that invalidates state data
head-rev ; nil | mtn rev string : current head revision, nil if multiple heads head-revs ; either current head revision or (left, right) if multiple heads
conflicts-buffer ; *xmtn-conflicts* buffer for merge conflicts-buffer ; *xmtn-conflicts* buffer for merge
status-buffer ; *xmtn-status* buffer for commit status-buffer ; *xmtn-status* buffer for commit
heads ; 'need-scan | 'at-head | 'need-update | 'need-merge heads ; 'need-scan | 'at-head | 'need-update | 'need-merge
@ -80,7 +80,7 @@ The elements must all be of class xmtn-status-data.")
(insert (dvc-face-add " need refresh\n" 'dvc-conflict)) (insert (dvc-face-add " need refresh\n" 'dvc-conflict))
(ecase (xmtn-status-data-local-changes data) (ecase (xmtn-status-data-local-changes data)
(need-scan (insert " local changes unknown\n")) (need-scan (insert " local changes not checked\n"))
(need-commit (insert (dvc-face-add " need commit\n" 'dvc-header))) (need-commit (insert (dvc-face-add " need commit\n" 'dvc-header)))
(ok nil)) (ok nil))
@ -122,12 +122,14 @@ The elements must all be of class xmtn-status-data.")
(if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
(with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer)))) (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer))))
(defun xmtn-status-clean-1 (data) (defun xmtn-status-clean-1 (data save-conflicts)
"Clean DATA workspace." "Clean DATA workspace, kill associated automate session.
If SAVE-CONFLICTS non-nil, don't delete conflicts files."
(xmtn-automate-kill-session (xmtn-status-work data)) (xmtn-automate-kill-session (xmtn-status-work data))
(xmtn-status-kill-conflicts-buffer data) (xmtn-status-kill-conflicts-buffer data)
(xmtn-status-kill-status-buffer data) (xmtn-status-kill-status-buffer data)
(xmtn-conflicts-clean (xmtn-status-work data))) (unless save-conflicts
(xmtn-conflicts-clean (xmtn-status-work data))))
(defun xmtn-status-clean () (defun xmtn-status-clean ()
"Clean current workspace, delete from ewoc" "Clean current workspace, delete from ewoc"
@ -135,14 +137,13 @@ The elements must all be of class xmtn-status-data.")
(let* ((elem (ewoc-locate xmtn-status-ewoc)) (let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)) (data (ewoc-data elem))
(inhibit-read-only t)) (inhibit-read-only t))
(xmtn-status-clean-1 data) (xmtn-status-clean-1 data nil)
(ewoc-delete xmtn-status-ewoc elem))) (ewoc-delete xmtn-status-ewoc elem)))
(defun xmtn-status-quit () (defun xmtn-status-clean-all (&optional save-conflicts)
"Clean all remaining workspaces, kill automate sessions, kill buffer." "Clean all remaining workspaces."
(interactive) (interactive)
(ewoc-map 'xmtn-status-clean-1 xmtn-status-ewoc) (ewoc-map 'xmtn-status-clean-1 xmtn-status-ewoc save-conflicts))
(kill-buffer))
(defun xmtn-status-cleanp () (defun xmtn-status-cleanp ()
"Non-nil if clean & quit is appropriate for current workspace." "Non-nil if clean & quit is appropriate for current workspace."
@ -186,13 +187,21 @@ The elements must all be of class xmtn-status-data.")
(and (not (xmtn-status-data-need-refresh data)) (and (not (xmtn-status-data-need-refresh data))
(eq 'need-update (xmtn-status-data-heads data))))) (eq 'need-update (xmtn-status-data-heads data)))))
(defun xmtn-status-update-preview ()
"Preview update for current workspace."
(interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem))
(default-directory (xmtn-status-work data)))
(xmtn-dvc-missing)))
(defun xmtn-status-resolve-conflicts () (defun xmtn-status-resolve-conflicts ()
"Resolve conflicts for current workspace." "Resolve conflicts for current workspace."
(interactive) (interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc)) (let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-status-need-refresh elem data nil) (xmtn-status-need-refresh elem data nil)
(setf (xmtn-status-data-conflicts data) 'resolved) (setf (xmtn-status-data-conflicts data) 'need-scan)
(pop-to-buffer (xmtn-status-data-conflicts-buffer data)))) (pop-to-buffer (xmtn-status-data-conflicts-buffer data))))
(defun xmtn-status-resolve-conflictsp () (defun xmtn-status-resolve-conflictsp ()
@ -229,18 +238,18 @@ The elements must all be of class xmtn-status-data.")
(member (xmtn-status-data-local-changes data) (member (xmtn-status-data-local-changes data)
'(need-scan need-commit))))) '(need-scan need-commit)))))
(defun xmtn-status-review-update () (defun xmtn-status-update-review ()
"Review last update for current workspace." "Review last update for current workspace."
(interactive) (interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc)) (let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
;; assume they are adding FIXMEs ;; assume they are adding fixmes
(xmtn-status-need-refresh elem data 'need-scan) (xmtn-status-need-refresh elem data 'need-scan)
(setf (xmtn-status-data-update-review data) 'done) (setf (xmtn-status-data-update-review data) 'done)
(xmtn-review-update (xmtn-status-work data)))) (xmtn-update-review (xmtn-status-work data))))
(defun xmtn-status-review-updatep () (defun xmtn-status-update-reviewp ()
"Non-nil if xmtn-status-review-update is appropriate for current workspace." "Non-nil if xmtn-status-update-review is appropriate for current workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
(and (not (xmtn-status-data-need-refresh data)) (and (not (xmtn-status-data-need-refresh data))
(eq 'need-review (xmtn-status-data-update-review data))))) (eq 'need-review (xmtn-status-data-update-review data)))))
@ -252,7 +261,16 @@ The elements must all be of class xmtn-status-data.")
(data (ewoc-data elem)) (data (ewoc-data elem))
(default-directory (xmtn-status-work data))) (default-directory (xmtn-status-work data)))
(xmtn-status-save-conflicts-buffer data) (xmtn-status-save-conflicts-buffer data)
(xmtn-dvc-merge-1 default-directory nil) (xmtn--run-command-sync
default-directory
(list
"explicit_merge"
(nth 0 (xmtn-status-data-head-revs data))
(nth 1 (xmtn-status-data-head-revs data))
(xmtn--tree-default-branch default-directory)
(if (file-exists-p "_MTN/conflicts")
"--resolve-conflicts-file=_MTN/conflicts")
(xmtn-dvc-log-message)))
(xmtn-status-refresh-one data nil) (xmtn-status-refresh-one data nil)
(ewoc-invalidate xmtn-status-ewoc elem))) (ewoc-invalidate xmtn-status-ewoc elem)))
@ -271,6 +289,13 @@ The elements must all be of class xmtn-status-data.")
(and (not (xmtn-status-data-need-refresh data)) (and (not (xmtn-status-data-need-refresh data))
(eq 'need-merge (xmtn-status-data-heads data))))) (eq 'need-merge (xmtn-status-data-heads data)))))
(defun xmtn-status-quit-save ()
"Quit, but save conflicts files for later resume."
(interactive)
(remove-hook 'kill-buffer-hook 'xmtn-status-clean-all t)
(xmtn-status-clean-all t)
(kill-buffer))
(defvar xmtn-status-actions-map (defvar xmtn-status-actions-map
(let ((map (make-sparse-keymap "actions"))) (let ((map (make-sparse-keymap "actions")))
(define-key map [?c] '(menu-item "c) clean/delete" (define-key map [?c] '(menu-item "c) clean/delete"
@ -282,9 +307,12 @@ The elements must all be of class xmtn-status-data.")
(define-key map [?i] '(menu-item "i) ignore local changes" (define-key map [?i] '(menu-item "i) ignore local changes"
xmtn-status-status-ok xmtn-status-status-ok
:visible (xmtn-status-statusp))) :visible (xmtn-status-statusp)))
(define-key map [?5] '(menu-item "5) review update" (define-key map [?6] '(menu-item "6) preview update"
xmtn-status-review-update xmtn-status-update-preview
:visible (xmtn-status-review-updatep))) :visible (xmtn-status-updatep)))
(define-key map [?5] '(menu-item "5) update review"
xmtn-status-update-review
:visible (xmtn-status-update-reviewp)))
(define-key map [?4] '(menu-item "4) update" (define-key map [?4] '(menu-item "4) update"
xmtn-status-update xmtn-status-update
:visible (xmtn-status-updatep))) :visible (xmtn-status-updatep)))
@ -310,12 +338,25 @@ The elements must all be of class xmtn-status-data.")
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map "\M-d" xmtn-status-actions-map) (define-key map "\M-d" xmtn-status-actions-map)
(define-key map [?g] 'xmtn-status-refresh) (define-key map [?g] 'xmtn-status-refresh)
(define-key map [?m] 'xmtn-status-update-preview)
(define-key map [?n] 'xmtn-status-next) (define-key map [?n] 'xmtn-status-next)
(define-key map [?p] 'xmtn-status-prev) (define-key map [?p] 'xmtn-status-prev)
(define-key map [?q] 'xmtn-status-quit) (define-key map [?r] 'xmtn-status-update-review)
(define-key map [?s] 'xmtn-status-quit-save)
(define-key map [?q] 'dvc-buffer-quit)
map) map)
"Keymap used in `xmtn-multiple-status-mode'.") "Keymap used in `xmtn-multiple-status-mode'.")
(easy-menu-define xmtn-multiple-status-mode-menu xmtn-multiple-status-mode-map
"Mtn specific status menu."
`("DVC-Mtn"
["Do the right thing" xmtn-status-actions-map t]
["Quit, clean conflicts" dvc-buffer-quit t]
["Quit, save conflicts" xmtn-status-quit-save t]
["Preview update" xmtn-status-update-preview t]
["Review update" xmtn-status-update-review t]
))
(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status" (define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status"
"Major mode to show status of multiple workspaces." "Major mode to show status of multiple workspaces."
(setq dvc-buffer-current-active-dvc 'xmtn) (setq dvc-buffer-current-active-dvc 'xmtn)
@ -326,6 +367,7 @@ The elements must all be of class xmtn-status-data.")
(set (make-local-variable 'write-file-functions) nil) (set (make-local-variable 'write-file-functions) nil)
(dvc-install-buffer-menu) (dvc-install-buffer-menu)
(add-hook 'kill-buffer-hook 'xmtn-status-clean-all nil t)
(setq buffer-read-only t) (setq buffer-read-only t)
(buffer-disable-undo) (buffer-disable-undo)
@ -333,35 +375,18 @@ The elements must all be of class xmtn-status-data.")
(defun xmtn-status-conflicts (data) (defun xmtn-status-conflicts (data)
"Return value for xmtn-status-data-conflicts for DATA." "Return value for xmtn-status-data-conflicts for DATA."
(let* ((work (xmtn-status-work data)) ;; only called if need merge; two items in head-revs
(default-directory work)) (let ((result (xmtn-conflicts-status
(xmtn-status-data-conflicts-buffer data) ; buffer
(if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) (xmtn-status-work data) ; left-work
(kill-buffer (xmtn-status-data-conflicts-buffer data))) (car (xmtn-status-data-head-revs data)) ; left-rev
(xmtn-status-work data) ; right-work
;; create conflicts file (cadr (xmtn-status-data-head-revs data)) ; right-rev
(xmtn-conflicts-clean work) (xmtn-status-data-branch data) ; left-branch
(xmtn-conflicts-save-opts work work (xmtn-status-data-branch data) (xmtn-status-data-branch data)) (xmtn-status-data-branch data) ; right-branch
(dvc-run-dvc-sync )))
'xmtn (setf (xmtn-status-data-conflicts-buffer data) (car result))
(list "conflicts" "store") (cadr result)))
:error (lambda (output error status arguments)
(pop-to-buffer error)))
;; create conflicts buffer
(setf (xmtn-status-data-conflicts-buffer data)
(save-excursion
(let ((dvc-switch-to-buffer-first nil))
(xmtn-conflicts-review work)
(current-buffer))))
(with-current-buffer (xmtn-status-data-conflicts-buffer data)
(case xmtn-conflicts-total-count
(0 'none)
(t
(if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-internal-count)
'need-review-resolve-internal
'need-resolve))))))
(defun xmtn-status-refresh-one (data refresh-local-changes) (defun xmtn-status-refresh-one (data refresh-local-changes)
"Refresh DATA." "Refresh DATA."
@ -373,29 +398,21 @@ The elements must all be of class xmtn-status-data.")
(base-rev (xmtn--get-base-revision-hash-id-or-null work))) (base-rev (xmtn--get-base-revision-hash-id-or-null work)))
(case (length heads) (case (length heads)
(1 (1
(setf (xmtn-status-data-head-rev data) (nth 0 heads)) (setf (xmtn-status-data-head-revs data) (nth 0 heads))
(setf (xmtn-status-data-conflicts data) 'none) (setf (xmtn-status-data-conflicts data) 'none)
(if (string= (xmtn-status-data-head-rev data) base-rev) (if (string= (xmtn-status-data-head-revs data) base-rev)
(setf (xmtn-status-data-heads data) 'at-head) (setf (xmtn-status-data-heads data) 'at-head)
(setf (xmtn-status-data-heads data) 'need-update))) (setf (xmtn-status-data-heads data) 'need-update)))
(t (t
(setf (xmtn-status-data-head-rev data) nil) (setf (xmtn-status-data-head-revs data) (list (nth 0 heads) (nth 1 heads)))
(setf (xmtn-status-data-heads data) 'need-merge) (setf (xmtn-status-data-heads data) 'need-merge))))
(case (xmtn-status-data-conflicts data)
(resolved
;; Assume the resolution was just completed, so don't erase it!
nil)
(t
(setf (xmtn-status-data-conflicts data) 'need-scan))))))
(message "") (message "")
(if refresh-local-changes (if refresh-local-changes
(progn (progn
(setf (xmtn-status-data-local-changes data) 'need-scan) (setf (xmtn-status-data-local-changes data) 'need-scan)
(case (xmtn-status-data-update-review data) (setf (xmtn-status-data-update-review data) 'need-review)))
('done (setf (xmtn-status-data-update-review data) 'need-review))
(t nil))))
(case (xmtn-status-data-local-changes data) (case (xmtn-status-data-local-changes data)
(need-scan (need-scan
@ -411,11 +428,14 @@ The elements must all be of class xmtn-status-data.")
(xmtn-status-data-local-changes data) (cadr result))) )) (xmtn-status-data-local-changes data) (cadr result))) ))
(t nil)) (t nil))
(case (xmtn-status-data-conflicts data) (case (xmtn-status-data-heads data)
(need-scan (need-merge
(setf (xmtn-status-data-conflicts data) (setf (xmtn-status-data-conflicts data)
(xmtn-status-conflicts data))) (xmtn-status-conflicts data)))
(t nil)) (t
(xmtn-status-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-status-work data))
(setf (xmtn-status-data-conflicts data) 'none)))
(setf (xmtn-status-data-need-refresh data) nil)) (setf (xmtn-status-data-need-refresh data) nil))
@ -487,7 +507,7 @@ The elements must all be of class xmtn-status-data.")
(xmtn-status-next)) (xmtn-status-next))
;;;###autoload ;;;###autoload
(defun xmtn-status-one-1 (root name head-rev status-buffer heads local-changes) (defun xmtn-status-one-1 (root name head-revs status-buffer heads local-changes)
"Create an xmtn-multi-status buffer from xmtn-propagate." "Create an xmtn-multi-status buffer from xmtn-propagate."
(pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
(setq default-directory (concat root "/" name)) (setq default-directory (concat root "/" name))
@ -500,7 +520,7 @@ The elements must all be of class xmtn-status-data.")
:work (file-name-nondirectory (directory-file-name default-directory)) :work (file-name-nondirectory (directory-file-name default-directory))
:branch (xmtn--tree-default-branch default-directory) :branch (xmtn--tree-default-branch default-directory)
:need-refresh nil :need-refresh nil
:head-rev head-rev :head-revs head-revs
:conflicts-buffer nil :conflicts-buffer nil
:status-buffer status-buffer :status-buffer status-buffer
:heads heads :heads heads

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

@ -1,6 +1,6 @@
;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone ;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone
;; Copyright (C) 2009 - 2010 Stephen Leake ;; Copyright (C) 2009 - 2011 Stephen Leake
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -56,8 +56,8 @@ The elements must all be of class xmtn-propagate-data.")
from-branch ; branch name (assumed never changes) from-branch ; branch name (assumed never changes)
to-branch ; to-branch ;
need-refresh ; nil | t; if an async process was started that invalidates state data need-refresh ; nil | t; if an async process was started that invalidates state data
from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads from-head-revs ; mtn rev string; current head revision or (left right) if multiple heads
to-head-rev ; to-head-revs ;
conflicts-buffer ; *xmtn-conflicts* buffer for this propagation conflicts-buffer ; *xmtn-conflicts* buffer for this propagation
from-status-buffer ; *xmtn-status* buffer for commit in from from-status-buffer ; *xmtn-status* buffer for commit in from
to-status-buffer ; *xmtn-status* buffer for commit in to to-status-buffer ; *xmtn-status* buffer for commit in to
@ -69,7 +69,7 @@ The elements must all be of class xmtn-propagate-data.")
(to-local-changes (to-local-changes
'need-scan) ; 'need-scan) ;
(conflicts (conflicts
'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'ok 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none
; for propagate ; for propagate
) )
@ -105,14 +105,14 @@ The elements must all be of class xmtn-propagate-data.")
(insert (dvc-face-add " need refresh\n" 'dvc-conflict)) (insert (dvc-face-add " need refresh\n" 'dvc-conflict))
(ecase (xmtn-propagate-data-from-local-changes data) (ecase (xmtn-propagate-data-from-local-changes data)
(need-scan (insert " local changes unknown " (xmtn-propagate-data-from-name data) "\n")) (need-scan (insert " local changes not checked " (xmtn-propagate-data-from-name data) "\n"))
(need-commit (need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-from-name data) "\n") (insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-from-name data) "\n")
'dvc-header))) 'dvc-header)))
(ok nil)) (ok nil))
(ecase (xmtn-propagate-data-to-local-changes data) (ecase (xmtn-propagate-data-to-local-changes data)
(need-scan (insert " local changes unknown " (xmtn-propagate-data-to-name data) "\n")) (need-scan (insert " local changes not checked " (xmtn-propagate-data-to-name data) "\n"))
(need-commit (need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-to-name data) "\n") (insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-to-name data) "\n")
'dvc-header))) 'dvc-header)))
@ -124,7 +124,7 @@ The elements must all be of class xmtn-propagate-data.")
(insert (dvc-face-add (concat " need update " (xmtn-propagate-data-from-name data) "\n") (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-from-name data) "\n")
'dvc-conflict))) 'dvc-conflict)))
(need-merge (need-merge
(insert (dvc-face-add (concat " need merge " (xmtn-propagate-data-from-name data) "\n") (insert (dvc-face-add (concat " need status for merge " (xmtn-propagate-data-from-name data) "\n")
'dvc-conflict)))) 'dvc-conflict))))
(ecase (xmtn-propagate-data-to-heads data) (ecase (xmtn-propagate-data-to-heads data)
@ -133,7 +133,7 @@ The elements must all be of class xmtn-propagate-data.")
(insert (dvc-face-add (concat " need update " (xmtn-propagate-data-to-name data) "\n") (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-to-name data) "\n")
'dvc-conflict))) 'dvc-conflict)))
(need-merge (need-merge
(insert (dvc-face-add (concat " need merge " (xmtn-propagate-data-to-name data) "\n") (insert (dvc-face-add (concat " need status for merge " (xmtn-propagate-data-to-name data) "\n")
'dvc-conflict)))) 'dvc-conflict))))
(if (xmtn-propagate-data-propagate-needed data) (if (xmtn-propagate-data-propagate-needed data)
@ -148,7 +148,7 @@ The elements must all be of class xmtn-propagate-data.")
(need-review-resolve-internal (need-review-resolve-internal
(insert (dvc-face-add " need review resolve internal\n" 'dvc-header)) (insert (dvc-face-add " need review resolve internal\n" 'dvc-header))
(insert (dvc-face-add " need propagate\n" 'dvc-conflict))) (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))
(ok ((resolved none)
(insert (dvc-face-add " need propagate\n" 'dvc-conflict))))) (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
(if (eq 'at-head (xmtn-propagate-data-to-heads data)) (if (eq 'at-head (xmtn-propagate-data-to-heads data))
@ -169,29 +169,15 @@ The elements must all be of class xmtn-propagate-data.")
(defun xmtn-propagate-create-to-status-buffer (data) (defun xmtn-propagate-create-to-status-buffer (data)
"Create to-status buffer for DATA" "Create to-status buffer for DATA"
(if (buffer-live-p (xmtn-propagate-data-to-status-buffer data)) (let ((result (xmtn--status-inventory-sync (xmtn-propagate-to-work data))))
(with-current-buffer (xmtn-propagate-data-to-status-buffer data) (setf (xmtn-propagate-data-to-status-buffer data) (car result)
(xmtn-dvc-status) (xmtn-propagate-data-to-local-changes data) (cadr result))))
(setf (xmtn-propagate-data-to-local-changes data)
(if (not (ewoc-locate dvc-fileinfo-ewoc))
'ok
'need-commit)))
(let ((result (xmtn--status-inventory-sync (xmtn-propagate-to-work data))))
(setf (xmtn-propagate-data-to-status-buffer data) (car result)
(xmtn-propagate-data-to-local-changes data) (cadr result))) ))
(defun xmtn-propagate-create-from-status-buffer (data) (defun xmtn-propagate-create-from-status-buffer (data)
"Create from-status buffer for DATA" "Create from-status buffer for DATA"
(if (buffer-live-p (xmtn-propagate-data-from-status-buffer data)) (let ((result (xmtn--status-inventory-sync (xmtn-propagate-from-work data))))
(with-current-buffer (xmtn-propagate-data-from-status-buffer data) (setf (xmtn-propagate-data-from-status-buffer data) (car result)
(xmtn-dvc-status) (xmtn-propagate-data-from-local-changes data) (cadr result))))
(setf (xmtn-propagate-data-from-local-changes data)
(if (not (ewoc-locate dvc-fileinfo-ewoc))
'ok
'need-commit)))
(let ((result (xmtn--status-inventory-sync (xmtn-propagate-from-work data))))
(setf (xmtn-propagate-data-from-status-buffer data) (car result)
(xmtn-propagate-data-from-local-changes data) (cadr result))) ))
(defun xmtn-propagate-kill-status-buffers (data) (defun xmtn-propagate-kill-status-buffers (data)
(if (buffer-live-p (xmtn-propagate-data-from-status-buffer data)) (if (buffer-live-p (xmtn-propagate-data-from-status-buffer data))
@ -199,29 +185,30 @@ The elements must all be of class xmtn-propagate-data.")
(if (buffer-live-p (xmtn-propagate-data-to-status-buffer data)) (if (buffer-live-p (xmtn-propagate-data-to-status-buffer data))
(kill-buffer (xmtn-propagate-data-to-status-buffer data)))) (kill-buffer (xmtn-propagate-data-to-status-buffer data))))
(defun xmtn-propagate-clean-1 (data) (defun xmtn-propagate-clean-1 (data save-conflicts)
"Clean DATA workspace" "Clean DATA workspace, kill associated automate session.
If SAVE-CONFLICTS non-nil, don't delete conflicts files."
(xmtn-automate-kill-session (xmtn-propagate-from-work data)) (xmtn-automate-kill-session (xmtn-propagate-from-work data))
(xmtn-automate-kill-session (xmtn-propagate-to-work data)) (xmtn-automate-kill-session (xmtn-propagate-to-work data))
(xmtn-propagate-kill-conflicts-buffer data) (xmtn-propagate-kill-conflicts-buffer data)
(xmtn-propagate-kill-status-buffers data) (xmtn-propagate-kill-status-buffers data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))) (unless save-conflicts
(xmtn-conflicts-clean (xmtn-propagate-to-work data))))
(defun xmtn-propagate-clean () (defun xmtn-propagate-clean ()
"Clean current workspace, delete from ewoc" "Clean current workspace, delete from ewoc."
(interactive) (interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc)) (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-clean-1 data) (xmtn-propagate-clean-1 data nil)
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(ewoc-delete xmtn-propagate-ewoc elem)))) (ewoc-delete xmtn-propagate-ewoc elem))))
(defun xmtn-propagate-quit () (defun xmtn-propagate-clean-all (&optional save-conflicts)
"Clean all remaining workspaces, kill automate sessions, kill buffer." "Clean all remaining workspaces."
(interactive) (interactive)
(ewoc-map 'xmtn-propagate-clean-1 xmtn-propagate-ewoc) (ewoc-map 'xmtn-propagate-clean-1 xmtn-propagate-ewoc save-conflicts))
(kill-buffer))
(defun xmtn-propagate-cleanp () (defun xmtn-propagate-cleanp ()
"Non-nil if clean is appropriate for current workspace." "Non-nil if clean is appropriate for current workspace."
@ -256,7 +243,12 @@ The elements must all be of class xmtn-propagate-data.")
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
<<<<<<< TREE <<<<<<< TREE
<<<<<<< TREE
======= =======
=======
;; assume the commit is successful
(setf (xmtn-propagate-data-to-local-changes data) 'ok)
>>>>>>> MERGE-SOURCE
(if (not (buffer-live-p (xmtn-propagate-data-to-status-buffer data))) (if (not (buffer-live-p (xmtn-propagate-data-to-status-buffer data)))
(xmtn-propagate-create-to-status-buffer data)) (xmtn-propagate-create-to-status-buffer data))
>>>>>>> MERGE-SOURCE >>>>>>> MERGE-SOURCE
@ -275,7 +267,12 @@ The elements must all be of class xmtn-propagate-data.")
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
<<<<<<< TREE <<<<<<< TREE
<<<<<<< TREE
======= =======
=======
;; assume the commit is successful
(setf (xmtn-propagate-data-from-local-changes data) 'ok)
>>>>>>> MERGE-SOURCE
(if (not (buffer-live-p (xmtn-propagate-data-from-status-buffer data))) (if (not (buffer-live-p (xmtn-propagate-data-from-status-buffer data)))
(xmtn-propagate-create-from-status-buffer data)) (xmtn-propagate-create-from-status-buffer data))
>>>>>>> MERGE-SOURCE >>>>>>> MERGE-SOURCE
@ -294,7 +291,7 @@ The elements must all be of class xmtn-propagate-data.")
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
(xmtn--update (xmtn-propagate-to-work data) (xmtn--update (xmtn-propagate-to-work data)
(xmtn-propagate-data-to-head-rev data) (xmtn-propagate-data-to-head-revs data)
nil t) nil t)
(xmtn-propagate-refresh-one data nil) (xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem))) (ewoc-invalidate xmtn-propagate-ewoc elem)))
@ -306,6 +303,25 @@ The elements must all be of class xmtn-propagate-data.")
(eq (xmtn-propagate-data-to-heads data) (eq (xmtn-propagate-data-to-heads data)
'need-update)))) 'need-update))))
(defun xmtn-propagate-update-from ()
"Update current `from' workspace."
(interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data)
(xmtn--update (xmtn-propagate-from-work data)
(xmtn-propagate-data-from-head-revs data)
nil t)
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-update-fromp ()
"Non-nil if update is appropriate for current `from' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(eq (xmtn-propagate-data-from-heads data)
'need-update))))
(defun xmtn-propagate-propagate () (defun xmtn-propagate-propagate ()
"Propagate current workspace." "Propagate current workspace."
(interactive) (interactive)
@ -315,12 +331,17 @@ The elements must all be of class xmtn-propagate-data.")
(if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))) (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
;; user deleted conflicts buffer after resolving conflicts; get it back ;; user deleted conflicts buffer after resolving conflicts; get it back
(setf (xmtn-propagate-data-conflicts-buffer data) (xmtn-propagate-conflicts data))
(xmtn-propagate-conflicts-buffer data)))
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(let ((xmtn-confirm-operation nil)) (let ((xmtn-confirm-operation nil))
(xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data)))) (save-some-buffers t); log buffer
;; save-some-buffers does not save the conflicts buffer, which is the current buffer
(save-buffer)
(xmtn-propagate-from
(xmtn-propagate-data-from-branch data) ; = left
(xmtn-propagate-data-to-branch data) ; = right
)))
(xmtn-propagate-refresh-one data nil) (xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem))) (ewoc-invalidate xmtn-propagate-ewoc elem)))
@ -332,7 +353,7 @@ The elements must all be of class xmtn-propagate-data.")
(eq 'at-head (xmtn-propagate-data-from-heads data)) (eq 'at-head (xmtn-propagate-data-from-heads data))
(eq 'at-head (xmtn-propagate-data-to-heads data)) (eq 'at-head (xmtn-propagate-data-to-heads data))
(member (xmtn-propagate-data-conflicts data) (member (xmtn-propagate-data-conflicts data)
'(ok need-review-resolve-internal))))) '(need-review-resolve-internal resolved none)))))
(defun xmtn-propagate-resolve-conflicts () (defun xmtn-propagate-resolve-conflicts ()
"Resolve conflicts for current workspace." "Resolve conflicts for current workspace."
@ -392,7 +413,7 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-status-one-1 (xmtn-status-one-1
xmtn-propagate-to-root xmtn-propagate-to-root
(xmtn-propagate-data-to-work data) (xmtn-propagate-data-to-work data)
(xmtn-propagate-data-to-head-rev data) (xmtn-propagate-data-to-head-revs data)
(xmtn-propagate-data-to-status-buffer data) (xmtn-propagate-data-to-status-buffer data)
(xmtn-propagate-data-to-heads data) (xmtn-propagate-data-to-heads data)
(xmtn-propagate-data-to-local-changes data)) (xmtn-propagate-data-to-local-changes data))
@ -419,7 +440,7 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-status-one-1 (xmtn-status-one-1
xmtn-propagate-from-root xmtn-propagate-from-root
(xmtn-propagate-data-from-work data) (xmtn-propagate-data-from-work data)
(xmtn-propagate-data-from-head-rev data) (xmtn-propagate-data-from-head-revs data)
(xmtn-propagate-data-from-status-buffer data) (xmtn-propagate-data-from-status-buffer data)
(xmtn-propagate-data-from-heads data) (xmtn-propagate-data-from-heads data)
(xmtn-propagate-data-from-local-changes data)) (xmtn-propagate-data-from-local-changes data))
@ -434,6 +455,13 @@ The elements must all be of class xmtn-propagate-data.")
'(need-update need-merge)) '(need-update need-merge))
(eq (xmtn-propagate-data-from-local-changes data) 'need-commit))))) (eq (xmtn-propagate-data-from-local-changes data) 'need-commit)))))
(defun xmtn-propagate-quit-save ()
"Quit, but save conflicts files for later resume."
(interactive)
(remove-hook 'kill-buffer-hook 'xmtn-propagate-clean-all t)
(xmtn-propagate-clean-all t)
(kill-buffer))
(defvar xmtn-propagate-actions-map (defvar xmtn-propagate-actions-map
(let ((map (make-sparse-keymap "actions"))) (let ((map (make-sparse-keymap "actions")))
(define-key map [?c] '(menu-item "c) clean/delete" (define-key map [?c] '(menu-item "c) clean/delete"
@ -442,15 +470,18 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?g] '(menu-item "g) refresh" (define-key map [?g] '(menu-item "g) refresh"
xmtn-propagate-do-refresh-one xmtn-propagate-do-refresh-one
:visible (xmtn-propagate-refreshp))) :visible (xmtn-propagate-refreshp)))
(define-key map [?8] '(menu-item (concat "8) update " (xmtn-propagate-to-name)) (define-key map [?9] '(menu-item (concat "9) status " (xmtn-propagate-to-name))
xmtn-propagate-status-to
:visible (xmtn-propagate-status-top)))
(define-key map [?8] '(menu-item (concat "8) status " (xmtn-propagate-from-name))
xmtn-propagate-status-from
:visible (xmtn-propagate-status-fromp)))
(define-key map [?7] '(menu-item (concat "7) update " (xmtn-propagate-to-name))
xmtn-propagate-update-to xmtn-propagate-update-to
:visible (xmtn-propagate-update-top))) :visible (xmtn-propagate-update-top)))
(define-key map [?7] '(menu-item (concat "7) commit " (xmtn-propagate-to-name)) (define-key map [?6] '(menu-item (concat "6) update " (xmtn-propagate-from-name))
xmtn-propagate-commit-to xmtn-propagate-update-from
:visible (xmtn-propagate-commit-top))) :visible (xmtn-propagate-update-fromp)))
(define-key map [?6] '(menu-item (concat "6) commit " (xmtn-propagate-from-name))
xmtn-propagate-commit-from
:visible (xmtn-propagate-commit-fromp)))
(define-key map [?5] '(menu-item "5) propagate" (define-key map [?5] '(menu-item "5) propagate"
xmtn-propagate-propagate xmtn-propagate-propagate
:visible (xmtn-propagate-propagatep))) :visible (xmtn-propagate-propagatep)))
@ -463,12 +494,12 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?2] '(menu-item (concat "2) ignore local changes " (xmtn-propagate-from-name)) (define-key map [?2] '(menu-item (concat "2) ignore local changes " (xmtn-propagate-from-name))
xmtn-propagate-local-changes-from-ok xmtn-propagate-local-changes-from-ok
:visible (xmtn-propagate-local-changes-fromp))) :visible (xmtn-propagate-local-changes-fromp)))
(define-key map [?1] '(menu-item (concat "1) status " (xmtn-propagate-to-name)) (define-key map [?1] '(menu-item (concat "1) commit " (xmtn-propagate-to-name))
xmtn-propagate-status-to xmtn-propagate-commit-to
:visible (xmtn-propagate-status-top))) :visible (xmtn-propagate-commit-top)))
(define-key map [?0] '(menu-item (concat "0) status " (xmtn-propagate-from-name)) (define-key map [?0] '(menu-item (concat "0) commit " (xmtn-propagate-from-name))
xmtn-propagate-status-from xmtn-propagate-commit-from
:visible (xmtn-propagate-status-fromp))) :visible (xmtn-propagate-commit-fromp)))
map) map)
"Keyboard menu keymap used to manage propagates.") "Keyboard menu keymap used to manage propagates.")
@ -481,10 +512,19 @@ The elements must all be of class xmtn-propagate-data.")
(define-key map [?g] 'xmtn-propagate-refresh) (define-key map [?g] 'xmtn-propagate-refresh)
(define-key map [?n] 'xmtn-propagate-next) (define-key map [?n] 'xmtn-propagate-next)
(define-key map [?p] 'xmtn-propagate-prev) (define-key map [?p] 'xmtn-propagate-prev)
(define-key map [?q] 'xmtn-propagate-quit) (define-key map [?s] 'xmtn-propagate-quit-save)
(define-key map [?q] 'dvc-buffer-quit)
map) map)
"Keymap used in `xmtn-propagate-mode'.") "Keymap used in `xmtn-propagate-mode'.")
(easy-menu-define xmtn-propagate-mode-menu xmtn-propagate-mode-map
"Mtn specific status menu."
`("DVC-Mtn"
["Do the right thing" xmtn-status-actions-map t]
["Quit, clean conflicts" dvc-buffer-quit t]
["Quit, save conflicts" xmtn-propagate-quit-save t]
))
(define-derived-mode xmtn-propagate-mode nil "xmtn-propagate" (define-derived-mode xmtn-propagate-mode nil "xmtn-propagate"
"Major mode to propagate multiple workspaces." "Major mode to propagate multiple workspaces."
(setq dvc-buffer-current-active-dvc 'xmtn) (setq dvc-buffer-current-active-dvc 'xmtn)
@ -495,6 +535,7 @@ The elements must all be of class xmtn-propagate-data.")
(set (make-local-variable 'write-file-functions) nil) (set (make-local-variable 'write-file-functions) nil)
(dvc-install-buffer-menu) (dvc-install-buffer-menu)
(add-hook 'kill-buffer-hook 'xmtn-propagate-clean-all nil t)
(setq buffer-read-only t) (setq buffer-read-only t)
(buffer-disable-undo) (buffer-disable-undo)
(set-buffer-modified-p nil) (set-buffer-modified-p nil)
@ -505,21 +546,22 @@ The elements must all be of class xmtn-propagate-data.")
"t if DATA needs propagate." "t if DATA needs propagate."
(let ((result t) (let ((result t)
(from-work (xmtn-propagate-from-work data)) (from-work (xmtn-propagate-from-work data))
(from-head-rev (xmtn-propagate-data-from-head-rev data)) (from-head-rev (xmtn-propagate-data-from-head-revs data))
(to-head-rev (xmtn-propagate-data-to-head-rev data))) (to-head-rev (xmtn-propagate-data-to-head-revs data)))
(if (or (not from-head-rev) (if (or (listp from-head-rev)
(not to-head-rev)) (listp to-head-rev))
;; multiple heads; can't propagate ;; multiple heads; can't propagate
(setq result nil) (setq result nil)
;; cases:
;; 1) to branched off earlier, and propagate is needed ;; 1) to branched off earlier, and propagate is needed
;; 2) propagate was just done but required no changes; no propagate needed ;; 2) propagate was just done but required no changes; no propagate needed
;; ;;
(if (string= from-head-rev to-head-rev) (if (string= from-head-rev to-head-rev)
;; case 2 ;; case 2
(setq result nil) (setq result nil)
(let ((descendents (xmtn-automate-simple-command-output-lines from-work (list "descendents" from-head-rev))) (let ((descendents (xmtn-automate-command-output-lines from-work (list "descendents" from-head-rev)))
done) done)
(if (not descendents) (if (not descendents)
;; case 1 ;; case 1
@ -533,6 +575,7 @@ The elements must all be of class xmtn-propagate-data.")
result result
)) ))
<<<<<<< TREE
(defun xmtn-propagate-conflicts-buffer (data) (defun xmtn-propagate-conflicts-buffer (data)
"Return a conflicts buffer for FROM-WORK, TO-WORK (absolute paths)." "Return a conflicts buffer for FROM-WORK, TO-WORK (absolute paths)."
(let ((from-work (xmtn-propagate-from-work data)) (let ((from-work (xmtn-propagate-from-work data))
@ -562,39 +605,23 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-conflicts-review to-work) (xmtn-conflicts-review to-work)
(current-buffer))))))) (current-buffer)))))))
=======
>>>>>>> MERGE-SOURCE
(defun xmtn-propagate-conflicts (data) (defun xmtn-propagate-conflicts (data)
"Return value for xmtn-propagate-data-conflicts for DATA." "Return value for xmtn-propagate-data-conflicts for DATA."
;; Only called if neither side needs merge. See
(if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))) ;; xmtn-propagate-propagate for assignment of 'left' = 'from'.
;; user may have deleted conflicts buffer after resolving (let ((result (xmtn-conflicts-status
;; conflicts; don't throw that away. (xmtn-propagate-data-conflicts-buffer data) ; buffer
(setf (xmtn-propagate-data-conflicts-buffer data) (xmtn-propagate-from-work data) ; left-work
(xmtn-propagate-conflicts-buffer data))) (xmtn-propagate-data-from-head-revs data) ; left-rev
(xmtn-propagate-to-work data) ; right-work
(let ((revs-current (xmtn-propagate-data-to-head-revs data) ; right-rev
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (xmtn-propagate-data-from-branch data) ; left-branch
(and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision) (xmtn-propagate-data-to-branch data) ; right-branch
(string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision))))) )))
(if revs-current (setf (xmtn-propagate-data-conflicts-buffer data) (car result))
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (cadr result)))
(xmtn-conflicts-update-counts)
(save-buffer))
;; else recreate conflicts
(xmtn-propagate-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
(setf (xmtn-propagate-data-conflicts-buffer data)
(xmtn-propagate-conflicts-buffer data))
)
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-count)
(if (< 0 xmtn-conflicts-resolved-internal-count)
'need-review-resolve-internal
'ok)
'need-resolve))))
(defun xmtn-propagate-refresh-one (data refresh-local-changes) (defun xmtn-propagate-refresh-one (data refresh-local-changes)
"Refresh DATA." "Refresh DATA."
@ -607,24 +634,24 @@ The elements must all be of class xmtn-propagate-data.")
(from-base-rev (xmtn--get-base-revision-hash-id-or-null from-work))) (from-base-rev (xmtn--get-base-revision-hash-id-or-null from-work)))
(case (length heads) (case (length heads)
(1 (1
(setf (xmtn-propagate-data-from-head-rev data) (nth 0 heads)) (setf (xmtn-propagate-data-from-head-revs data) (nth 0 heads))
(if (string= (xmtn-propagate-data-from-head-rev data) from-base-rev) (if (string= (xmtn-propagate-data-from-head-revs data) from-base-rev)
(setf (xmtn-propagate-data-from-heads data) 'at-head) (setf (xmtn-propagate-data-from-heads data) 'at-head)
(setf (xmtn-propagate-data-from-heads data) 'need-update))) (setf (xmtn-propagate-data-from-heads data) 'need-update)))
(t (t
(setf (xmtn-propagate-data-from-head-rev data) nil) (setf (xmtn-propagate-data-from-head-revs data) (list (nth 0 heads) (nth 1 heads)))
(setf (xmtn-propagate-data-from-heads data) 'need-merge)))) (setf (xmtn-propagate-data-from-heads data) 'need-merge))))
(let ((heads (xmtn--heads to-work (xmtn-propagate-data-to-branch data))) (let ((heads (xmtn--heads to-work (xmtn-propagate-data-to-branch data)))
(to-base-rev (xmtn--get-base-revision-hash-id-or-null to-work))) (to-base-rev (xmtn--get-base-revision-hash-id-or-null to-work)))
(case (length heads) (case (length heads)
(1 (1
(setf (xmtn-propagate-data-to-head-rev data) (nth 0 heads)) (setf (xmtn-propagate-data-to-head-revs data) (nth 0 heads))
(if (string= (xmtn-propagate-data-to-head-rev data) to-base-rev) (if (string= (xmtn-propagate-data-to-head-revs data) to-base-rev)
(setf (xmtn-propagate-data-to-heads data) 'at-head) (setf (xmtn-propagate-data-to-heads data) 'at-head)
(setf (xmtn-propagate-data-to-heads data) 'need-update))) (setf (xmtn-propagate-data-to-heads data) 'need-update)))
(t (t
(setf (xmtn-propagate-data-to-head-rev data) nil) (setf (xmtn-propagate-data-to-head-revs data) (list (nth 0 heads) (nth 1 heads)))
(setf (xmtn-propagate-data-to-heads data) 'need-merge)))) (setf (xmtn-propagate-data-to-heads data) 'need-merge))))
(setf (xmtn-propagate-data-propagate-needed data) (setf (xmtn-propagate-data-propagate-needed data)
@ -635,19 +662,15 @@ The elements must all be of class xmtn-propagate-data.")
(setf (xmtn-propagate-data-from-local-changes data) 'need-scan) (setf (xmtn-propagate-data-from-local-changes data) 'need-scan)
(setf (xmtn-propagate-data-to-local-changes data) 'need-scan))) (setf (xmtn-propagate-data-to-local-changes data) 'need-scan)))
(if (or refresh-local-changes (ecase (xmtn-propagate-data-from-local-changes data)
(xmtn-propagate-data-propagate-needed data)) (need-scan
;; these checks are slow, so don't do them if they probably are not needed. (xmtn-propagate-create-from-status-buffer data))
(progn (t nil))
(ecase (xmtn-propagate-data-from-local-changes data)
(need-scan
(xmtn-propagate-create-from-status-buffer data))
(t nil))
(ecase (xmtn-propagate-data-to-local-changes data) (ecase (xmtn-propagate-data-to-local-changes data)
(need-scan (need-scan
(xmtn-propagate-create-to-status-buffer data)) (xmtn-propagate-create-to-status-buffer data))
(t nil)))) (t nil))
(if (xmtn-propagate-data-propagate-needed data) (if (xmtn-propagate-data-propagate-needed data)
(progn (progn

232
dvc/lisp/xmtn-revlist.el
View File

@ -1,6 +1,6 @@
;;; xmtn-revlist.el --- Interactive display of revision histories for monotone ;;; xmtn-revlist.el --- Interactive display of revision histories for monotone
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -74,9 +74,7 @@ arg; root. Result is of the form:
authors authors
dates dates
changelogs changelogs
tags tags)
parent-hash-ids
child-hash-ids)
;;;###autoload ;;;###autoload
(defun xmtn-revision-refresh-maybe () (defun xmtn-revision-refresh-maybe ()
@ -91,17 +89,9 @@ arg; root. Result is of the form:
(defun xmtn-revision-list-entry-patch-printer (patch) (defun xmtn-revision-list-entry-patch-printer (patch)
(let ((entry (dvc-revlist-entry-patch-struct patch))) (let ((entry (dvc-revlist-entry-patch-struct patch)))
(assert (typep entry 'xmtn--revlist-entry)) (assert (typep entry 'xmtn--revlist-entry))
(insert (format " %s %s%s\n" (insert (format " %s %s\n"
(if (dvc-revlist-entry-patch-marked patch) "*" " ") (if (dvc-revlist-entry-patch-marked patch) "*" " ")
(xmtn--revlist-entry-revision-hash-id entry) (xmtn--revlist-entry-revision-hash-id entry)))
(let ((head-p
(endp (xmtn--revlist-entry-child-hash-ids entry)))
(root-p
(endp (xmtn--revlist-entry-parent-hash-ids entry))))
(cond ((and head-p root-p) " (head, root)")
(head-p " (head)")
(root-p " (root)")
(t "")))))
(dolist (tag (xmtn--revlist-entry-tags entry)) (dolist (tag (xmtn--revlist-entry-tags entry))
(insert (format " Tag: %s\n" tag))) (insert (format " Tag: %s\n" tag)))
(let ((authors (xmtn--revlist-entry-authors entry)) (let ((authors (xmtn--revlist-entry-authors entry))
@ -117,7 +107,7 @@ arg; root. Result is of the form:
(eql (length dates) len) (eql (length dates) len)
(eql (length changelogs) len))) (eql (length changelogs) len)))
(loop (loop
;; FIXME: Matching the k-th author cert with the k-th date cert ;; Matching the k-th author cert with the k-th date cert
;; and the k-th changelog cert, like we do here, is unlikely to ;; and the k-th changelog cert, like we do here, is unlikely to
;; be correct in general. That the relationship between date, ;; be correct in general. That the relationship between date,
;; message and author of a commit is lost appears to be a ;; message and author of a commit is lost appears to be a
@ -145,9 +135,12 @@ arg; root. Result is of the form:
(insert (format " %s\n" line)))))))))) (insert (format " %s\n" line))))))))))
(defun xmtn--revlist-setup-ewoc (root ewoc header footer revision-hash-ids last-n) (defun xmtn--revlist-setup-ewoc (root ewoc header footer revision-hash-ids last-n)
(assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids))
(ewoc-set-hf ewoc header footer) (ewoc-set-hf ewoc header footer)
(ewoc-filter ewoc (lambda (x) nil)) ; Clear it. (ewoc-filter ewoc (lambda (x) nil)) ; Clear it.
;; FIXME: setup should not modify order; this should be a waste of
;; time or wrong. This was here historically; see
;; xmtn--log-generator for comment on why I have not removed it. I
;; have not investigated order problems with other revlists.
(setq revision-hash-ids (xmtn--toposort root revision-hash-ids)) (setq revision-hash-ids (xmtn--toposort root revision-hash-ids))
(if last-n (if last-n
(let ((len (length revision-hash-ids))) (let ((len (length revision-hash-ids)))
@ -159,8 +152,6 @@ arg; root. Result is of the form:
(1 "Setting up revlist buffer (1 revision)...") (1 "Setting up revlist buffer (1 revision)...")
(t (format "Setting up revlist buffer (%s revisions)..." (t (format "Setting up revlist buffer (%s revisions)..."
(length revision-hash-ids)))) (length revision-hash-ids))))
;; Maybe also show parents and children? (Could add toggle
;; commands to show/hide these.)
(lexical-let ((rev (aref revision-hash-ids i)) (lexical-let ((rev (aref revision-hash-ids i))
(branches (list)) (branches (list))
(authors (list)) (authors (list))
@ -189,36 +180,21 @@ arg; root. Result is of the form:
changelogs (nreverse changelogs) changelogs (nreverse changelogs)
branches (nreverse branches) branches (nreverse branches)
tags (nreverse tags)) tags (nreverse tags))
(let ((parent-hash-ids (ewoc-enter-last ewoc
(xmtn-automate-simple-command-output-lines root `("parents" ;; Creating a list `(entry-patch
,rev))) ;; ,instance-of-dvc-revlist-entry-patch) seems
(child-hash-ids ;; to be part of DVC's API.
(xmtn-automate-simple-command-output-lines root `("children" `(entry-patch
,rev)))) ,(make-dvc-revlist-entry-patch
(xmtn--assert-optional (every #'stringp authors)) :dvc 'xmtn
(xmtn--assert-optional (every #'stringp dates)) :rev-id `(xmtn (revision ,rev))
(xmtn--assert-optional (every #'stringp changelogs)) :struct (xmtn--make-revlist-entry
(xmtn--assert-optional (every #'stringp branches)) :revision-hash-id rev
(xmtn--assert-optional (every #'stringp tags)) :branches branches
(xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids)) :authors authors
(xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids)) :dates dates
(ewoc-enter-last ewoc :changelogs changelogs
;; Creating a list `(entry-patch :tags tags))))))
;; ,instance-of-dvc-revlist-entry-patch) seems
;; to be part of DVC's API.
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'xmtn
:rev-id `(xmtn (revision ,rev))
:struct (xmtn--make-revlist-entry
:revision-hash-id rev
:branches branches
:authors authors
:dates dates
:changelogs changelogs
:tags tags
:parent-hash-ids parent-hash-ids
:child-hash-ids child-hash-ids)))))))
nil) nil)
(defun xmtn-revision-st-message (entry) (defun xmtn-revision-st-message (entry)
@ -226,11 +202,21 @@ arg; root. Result is of the form:
(defun xmtn--revlist-refresh () (defun xmtn--revlist-refresh ()
(let ((root default-directory)) (let ((root default-directory))
<<<<<<< TREE
(destructuring-bind (merge-destination-branch (destructuring-bind (merge-destination-branch
header-lines footer-lines revision-hash-ids) header-lines footer-lines revision-hash-ids)
=======
(destructuring-bind (header-lines footer-lines revs)
>>>>>>> MERGE-SOURCE
(funcall xmtn--revlist-*info-generator-fn* root) (funcall xmtn--revlist-*info-generator-fn* root)
<<<<<<< TREE
(setq xmtn--revlist-*merge-destination-branch* merge-destination-branch) (setq xmtn--revlist-*merge-destination-branch* merge-destination-branch)
(let ((ewoc dvc-revlist-cookie)) (let ((ewoc dvc-revlist-cookie))
=======
(let ((ewoc dvc-revlist-cookie)
(count (length revs))
(last-n dvc-revlist-last-n))
>>>>>>> MERGE-SOURCE
(xmtn--revlist-setup-ewoc root ewoc (xmtn--revlist-setup-ewoc root ewoc
(with-temp-buffer (with-temp-buffer
(dolist (line header-lines) (dolist (line header-lines)
@ -238,7 +224,16 @@ arg; root. Result is of the form:
(insert ?\n) (insert ?\n)
(insert line ?\n))) (insert line ?\n)))
(when header-lines (insert ?\n)) (when header-lines (insert ?\n))
(buffer-string)) (insert
(cond
((= 0 count) "No revisions")
((= 1 count) "1 revision:")
((or (null last-n)
(> last-n count))
(format "%d of %d revisions:" count count))
(t (format "%d of %d revisions:" last-n count))))
(insert ?\n)
(buffer-string))
(with-temp-buffer (with-temp-buffer
(when footer-lines (insert ?\n)) (when footer-lines (insert ?\n))
(dolist (line footer-lines) (dolist (line footer-lines)
@ -246,7 +241,7 @@ arg; root. Result is of the form:
(insert ?\n) (insert ?\n)
(insert line ?\n))) (insert line ?\n)))
(buffer-string)) (buffer-string))
revision-hash-ids revs
dvc-revlist-last-n) dvc-revlist-last-n)
(if (null (ewoc-nth ewoc 0)) (if (null (ewoc-nth ewoc 0))
(goto-char (point-max)) (goto-char (point-max))
@ -284,6 +279,7 @@ arg; root. Result is of the form:
;;;###autoload ;;;###autoload
(defun xmtn-dvc-changelog (&optional path) (defun xmtn-dvc-changelog (&optional path)
<<<<<<< TREE
(xmtn--log-helper (dvc-tree-root) path nil nil)) (xmtn--log-helper (dvc-tree-root) path nil nil))
(defun xmtn--log-helper (root path first-line-only-p last-n) (defun xmtn--log-helper (root path first-line-only-p last-n)
@ -367,6 +363,41 @@ arg; root. Result is of the form:
(length difference))))) (length difference)))))
'() '()
difference))) difference)))
=======
(xmtn--setup-revlist
(dvc-tree-root)
'xmtn--log-generator
path
nil ;; first-line-only-p
nil ;; last-n
))
(defun xmtn--log-generator (root)
(let ((branch (xmtn--tree-default-branch root)))
(let
((header
(list (format "Log for branch %s" branch)))
(options
;; FIXME: this gives most the recent date first, we want
;; that last. See mtn issue 118 for why we can't fix that
;; with more options. The 'toposort' in
;; xmtn--revlist-setup-ewoc puts it in the desired date
;; order. In general, it would be better if revlist-setup
;; did not alter the order.
(if dvc-revlist-last-n
(list "last" (format "%d" dvc-revlist-last-n))))
(command
(if xmtn--revlist-*path*
(list "log" xmtn--revlist-*path*)
(list "log")))
)
;; See xmtn--revlist-*info-generator-fn* for result format
(list header
'() ;; footer
(xmtn-automate-command-output-lines ;; revisions
root
(cons options command))))))
>>>>>>> MERGE-SOURCE
(defun xmtn-revlist-show-conflicts () (defun xmtn-revlist-show-conflicts ()
"If point is on a revision that has two parents, show conflicts "If point is on a revision that has two parents, show conflicts
@ -396,59 +427,40 @@ from the merge."
(setq right-rev (substring changelog start end))) (setq right-rev (substring changelog start end)))
((string= (substring changelog 0 5) "merge") ((or
(string= (substring changelog 0 5) "merge")
(string= (substring changelog 0 14) "explicit merge"))
(setq start (+ 4 (string-match "of" changelog))) (setq start (+ 4 (string-match "of" changelog)))
(setq end (string-match "'" changelog start)) (setq end (string-match "'" changelog start))
(setq left-rev (substring changelog start (1- end))) (setq left-rev (substring changelog start end))
(setq start (+ 5 (string-match "and" changelog start))) (setq start (+ 5 (string-match "and" changelog start)))
(setq end (string-match "'" changelog start)) (setq end (string-match "'" changelog start))
(setq right-rev (substring changelog start (1- end)))) (setq right-rev (substring changelog start end)))
(t (t
(error "not on a two parent revision"))) (error "not on a two parent revision")))
(xmtn-conflicts-save-opts (xmtn-conflicts-review
(read-file-name "left work: ") default-directory ; left-work
(read-file-name "right work: ") left-rev
default-directory ; right-work
right-rev
left-branch left-branch
right-branch) right-branch
t)))
(dvc-run-dvc-async
'xmtn
(list "conflicts" "store" left-rev right-rev)
:finished (lambda (output error status arguments)
(let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory)))
(pop-to-buffer conflicts-buffer)
(xmtn-conflicts-load-opts)
(set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file))
(insert-file-contents "_MTN/conflicts" t)))
:error (lambda (output error status arguments)
(pop-to-buffer error)))))
;;;###autoload ;;;###autoload
(defvar xmtn-revlist-mode-map (defvar xmtn-revlist-mode-map
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map "CM" 'xmtn-conflicts-merge)
(define-key map "CP" 'xmtn-conflicts-propagate)
(define-key map "CR" 'xmtn-conflicts-review)
(define-key map "CC" 'xmtn-conflicts-clean)
(define-key map "MH" 'xmtn-view-heads-revlist)
(define-key map "MP" 'xmtn-propagate-from)
(define-key map "MC" 'xmtn-revlist-show-conflicts) (define-key map "MC" 'xmtn-revlist-show-conflicts)
(define-key map "CC" 'xmtn-conflicts-clean)
map)) map))
;; items added here should probably also be added to xmtn-diff-mode-menu, -map in xmtn-dvc.el
(easy-menu-define xmtn-revlist-mode-menu xmtn-revlist-mode-map (easy-menu-define xmtn-revlist-mode-menu xmtn-revlist-mode-map
"Mtn specific revlist menu." "Mtn specific revlist menu."
`("DVC-Mtn" `("DVC-Mtn"
["View Heads" xmtn-view-heads-revlist t]
["Show merge conflicts before merge" xmtn-conflicts-merge t]
["Show merge conflicts after merge" xmtn-revlist-show-conflicts t] ["Show merge conflicts after merge" xmtn-revlist-show-conflicts t]
["Show propagate conflicts" xmtn-conflicts-propagate t]
["Review conflicts" xmtn-conflicts-review t]
["Propagate branch" xmtn-propagate-from t]
["Clean conflicts resolutions" xmtn-conflicts-clean t] ["Clean conflicts resolutions" xmtn-conflicts-clean t]
)) ))
@ -463,9 +475,26 @@ from the merge."
(let ((root (dvc-tree-root))) (let ((root (dvc-tree-root)))
(xmtn--setup-revlist (xmtn--setup-revlist
root root
<<<<<<< TREE
'xmtn--revlist--missing-get-info 'xmtn--revlist--missing-get-info
;; Passing nil as first-line-only-p is arbitrary here. ;; Passing nil as first-line-only-p is arbitrary here.
;; ;;
=======
(lambda (root)
(let ((revs
(xmtn-automate-command-output-lines
root
(cons (list "from" "h:" "to" "w:") (list "log")))))
(list
(list ;; header
(format "workspace %s" root)
nil ;; blank line
"Revisions that are not in base revision")
'() ;; footer
revs)))
nil ;; path
nil ;; first-line-only-p
>>>>>>> MERGE-SOURCE
;; When the missing revs are due to a propagate, there can be a ;; When the missing revs are due to a propagate, there can be a
;; lot of them, but we only really need to see the revs since the ;; lot of them, but we only really need to see the revs since the
;; propagate. So dvc-log-last-n is appropriate. We use ;; propagate. So dvc-log-last-n is appropriate. We use
@ -475,12 +504,28 @@ from the merge."
nil) nil)
;;;###autoload ;;;###autoload
(defun xmtn-review-update (root) (defun xmtn-update-review (root)
"Review revisions in last update of ROOT workspace." "Review revisions in last update of ROOT workspace."
(interactive "D") (interactive "D")
(xmtn--setup-revlist (xmtn--setup-revlist
root root
<<<<<<< TREE
'xmtn--revlist--review-update-info 'xmtn--revlist--review-update-info
=======
(lambda (root)
(let ((revs
(xmtn-automate-command-output-lines
root
(cons (list "from" "w:" "to" "u:") (list "log")))))
(list
(list ;; header
(format "workspace %s" root)
nil ;; blank line
"Revisions in last update")
'() ;; footer
revs)))
nil ;; path
>>>>>>> MERGE-SOURCE
nil ;; first-line-only-p nil ;; first-line-only-p
dvc-log-last-n) dvc-log-last-n)
nil) nil)
@ -494,9 +539,9 @@ from the merge."
root root
(lambda (root) (lambda (root)
(let* ((branch (xmtn--tree-default-branch root)) (let* ((branch (xmtn--tree-default-branch root))
(head-revision-hash-ids (xmtn--heads root branch)) (head-revision-hash-ids (xmtn--heads root branch)))
(head-count (length head-revision-hash-ids)))
(list (list
<<<<<<< TREE
branch branch
(list (format "Tree %s" root) (list (format "Tree %s" root)
(format "Branch %s" branch) (format "Branch %s" branch)
@ -505,6 +550,12 @@ from the merge."
(1 "1 head revision:") (1 "1 head revision:")
(t (format "%s head revisions: " head-count)))) (t (format "%s head revisions: " head-count))))
'() '()
=======
(list ; header
(format "workspace %s" root)
"Head revisions")
'() ; footer
>>>>>>> MERGE-SOURCE
head-revision-hash-ids))) head-revision-hash-ids)))
;; Passing nil as first-line-only-p, last-n is arbitrary here. ;; Passing nil as first-line-only-p, last-n is arbitrary here.
nil nil)) nil nil))
@ -566,6 +617,7 @@ to the base revision of the current tree."
(revision-hash-ids (xmtn--expand-selector root selector)) (revision-hash-ids (xmtn--expand-selector root selector))
(count (length revision-hash-ids))) (count (length revision-hash-ids)))
(list (list
<<<<<<< TREE
branch branch
(list (format "Tree %s" root) (list (format "Tree %s" root)
(format "Default branch %s" branch) (format "Default branch %s" branch)
@ -579,6 +631,16 @@ to the base revision of the current tree."
(t (format "%s revisions matching selector: " (t (format "%s revisions matching selector: "
count)))) count))))
'() '()
=======
(list ; header
(format "workspace %s" root)
(if (with-syntax-table (standard-syntax-table)
(string-match "\\`\\s *\\'" selector))
"Blank selector"
(format "Selector %s" selector))
"Revisions matching selector")
'() ; footer
>>>>>>> MERGE-SOURCE
revision-hash-ids))) revision-hash-ids)))
;; Passing nil as first-line-only-p is arbitrary here. ;; Passing nil as first-line-only-p is arbitrary here.
nil nil

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

@ -1,6 +1,6 @@
;;; xmtn-run.el --- Functions for runnning monotone commands ;;; xmtn-run.el --- Functions for runnning monotone commands
;; Copyright (C) 2008 - 2010 Stephen Leake ;; Copyright (C) 2008 - 2011 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler ;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler ;; Author: Christian M. Ohler
@ -43,6 +43,11 @@
(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix) (define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix)
(defun xmtn-dvc-prepare-environment (env)
"Prepare the environment to run mtn."
;; DVC expects monotone messages in the C locale
(cons "LC_MESSAGES=C" env))
(defun* xmtn--run-command-sync (root arguments) (defun* xmtn--run-command-sync (root arguments)
(xmtn--check-cached-command-version) (xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory)))) (let ((default-directory (file-truename (or root default-directory))))
@ -71,6 +76,7 @@
,@arguments) ,@arguments)
dvc-run-keys))) dvc-run-keys)))
<<<<<<< TREE
(defun xmtn--command-output-lines (root arguments) (defun xmtn--command-output-lines (root arguments)
"Run mtn in ROOT with ARGUMENTS and return its output as a list of strings." "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings."
(xmtn--check-cached-command-version) (xmtn--check-cached-command-version)
@ -107,6 +113,9 @@ Signals an error if more (or fewer) than one line is output."
(first lines))) (first lines)))
(defconst xmtn--minimum-required-command-version '(0 46)) (defconst xmtn--minimum-required-command-version '(0 46))
=======
(defconst xmtn--minimum-required-command-version '(0 99))
>>>>>>> MERGE-SOURCE
;; see also xmtn-sync.el xmtn-sync-required-command-version ;; see also xmtn-sync.el xmtn-sync-required-command-version
(defconst xmtn--required-automate-format-version "2") (defconst xmtn--required-automate-format-version "2")
@ -139,10 +148,11 @@ Sets cache if not already set."
(defun xmtn--command-version (executable) (defun xmtn--command-version (executable)
"Return EXECUTABLE's version as a list (MAJOR MINOR REVISION VERSION-STRING). "Return EXECUTABLE's version as a list (MAJOR MINOR REVISION VERSION-STRING).
VERSION-STRING is the string printed by mtn --version (with no VERSION-STRING is the string printed by `mtn version' (with no
trailing newline). MAJOR and MINOR are integers, a parsed trailing newline). MAJOR and MINOR are integers, a parsed
representation of the version number. REVISION is the revision representation of the version number. REVISION is the revision
id." id."
<<<<<<< TREE
(let ( (let (
;; Cache a fake version number to avoid infinite mutual ;; Cache a fake version number to avoid infinite mutual
;; recursion. ;; recursion.
@ -163,6 +173,28 @@ id."
(minor (parse-integer string (match-beginning 2) (match-end 2))) (minor (parse-integer string (match-beginning 2) (match-end 2)))
(revision (match-string 4 string))) (revision (match-string 4 string)))
(list major minor revision string))))) (list major minor revision string)))))
=======
(let ((version-string))
(dvc-run-dvc-sync
'xmtn
'("version")
:finished
(lambda (output error status arguments)
(with-current-buffer output
(setq version-string (buffer-substring-no-properties (point-min) (1- (point-max)))))))
(unless (string-match
(concat "\\`monotone \\([0-9]+\\)\\.\\([0-9]+\\)\\(\\.[0-9]+\\)?\\(dev\\)?"
" (base revision: \\(unknown\\|\\([0-9a-f]\\{40\\}\\)\\))\\'")
version-string)
(error (concat "Version output from monotone version"
" did not match expected pattern: %S")
version-string))
(let ((major (parse-integer version-string (match-beginning 1) (match-end 1)))
(minor (parse-integer version-string (match-beginning 2) (match-end 2)))
(revision (match-string 4 version-string)))
(list major minor revision version-string))))
>>>>>>> MERGE-SOURCE
(defun xmtn--check-cached-command-version () (defun xmtn--check-cached-command-version ()
(let ((minimum-version xmtn--minimum-required-command-version) (let ((minimum-version xmtn--minimum-required-command-version)

253
dvc/lisp/xmtn-sync.el
View File

@ -1,6 +1,6 @@
;;; xmtn-sync.el --- database sync handling for DVC backend for monotone ;;; xmtn-sync.el --- database sync handling for DVC backend for monotone
;; ;;
;; Copyright (C) 2010 Stephen Leake ;; Copyright (C) 2010, 2011 Stephen Leake
;; ;;
;; Author: Stephen Leake ;; Author: Stephen Leake
;; Keywords: tools ;; Keywords: tools
@ -47,6 +47,12 @@
(defvar xmtn-sync-config "xmtn-sync-config" (defvar xmtn-sync-config "xmtn-sync-config"
"File to store `xmtn-sync-branch-alist' and `xmtn-sync-remote-exec-alist'; relative to `dvc-config-directory'.") "File to store `xmtn-sync-branch-alist' and `xmtn-sync-remote-exec-alist'; relative to `dvc-config-directory'.")
(defvar xmtn-sync-sort nil
"User-supplied function to sort branches.
Called with a string containing the mtn branch name; return
'(node key) where node is the ewoc node to insert before (nil to
insert at end), key is the sort-key. Sync buffer is current.")
;;; Internal variables ;;; Internal variables
<<<<<<< TREE <<<<<<< TREE
(defconst xmtn-sync-required-command-version '(0 46) (defconst xmtn-sync-required-command-version '(0 46)
@ -119,10 +125,80 @@ All xmtn-sync functions operate on this ewoc.
The elements must all be of type xmtn-sync-sync.") The elements must all be of type xmtn-sync-sync.")
(make-variable-buffer-local 'xmtn-sync-ewoc) (make-variable-buffer-local 'xmtn-sync-ewoc)
<<<<<<< TREE
=======
(defstruct (xmtn-sync-branch
(:copier nil))
;; ewoc element; data for a branch that was received
name ;; monotone branch name
rev-alist ;; alist of '(revid (date author changelog)) for received revs
send-count ;; integer count of sent revs
print-mode ;; 'summary | 'brief | 'full | 'started
sort-key ;; for use by xmtn-sync-sort
)
(defun xmtn-sync-print-rev (rev print-mode)
"Print a REV (element of branch rev-alist) according to PRINT-MODE ('brief or 'full)."
(let ((date (nth 0 (cadr rev)))
(author (nth 1 (cadr rev)))
(changelog (nth 2 (cadr rev))))
(insert (dvc-face-add (format "\n %s %s\n" date author) 'dvc-header))
(ecase print-mode
(brief
(insert (substring changelog 0 (string-match "\n" changelog))))
(full
(insert changelog)))))
(defun xmtn-sync-printer (branch)
"Print an ewoc element; BRANCH must be of type xmtn-sync-branch."
;; sometimes mtn will allow a revision with no branch!
(if (xmtn-sync-branch-name branch)
(insert (dvc-face-add (xmtn-sync-branch-name branch) 'dvc-keyword))
(insert (dvc-face-add "<no branch>" 'dvc-keyword)))
(insert (format " rx %d tx %d\n"
(length (xmtn-sync-branch-rev-alist branch))
(xmtn-sync-branch-send-count branch)))
(ecase (xmtn-sync-branch-print-mode branch)
(summary nil)
((brief full)
(loop for rev in (xmtn-sync-branch-rev-alist branch) do
(xmtn-sync-print-rev rev (xmtn-sync-branch-print-mode branch))))
(started
(insert " started\n")))
)
(defun xmtn-sync-brief ()
"Set display mode for current item to brief."
(interactive)
(let* ((elem (ewoc-locate xmtn-sync-ewoc))
(data (ewoc-data elem)))
(setf (xmtn-sync-branch-print-mode data) 'brief)
(ewoc-invalidate xmtn-sync-ewoc elem)))
(defun xmtn-sync-full ()
"Set display mode for current item to full."
(interactive)
(let* ((elem (ewoc-locate xmtn-sync-ewoc))
(data (ewoc-data elem)))
(setf (xmtn-sync-branch-print-mode data) 'full)
(ewoc-invalidate xmtn-sync-ewoc elem)))
(defun xmtn-sync-summary ()
"Set display mode for current item to summary."
(interactive)
(let* ((elem (ewoc-locate xmtn-sync-ewoc))
(data (ewoc-data elem)))
(setf (xmtn-sync-branch-print-mode data) 'summary)
(ewoc-invalidate xmtn-sync-ewoc elem)))
>>>>>>> MERGE-SOURCE
(defun xmtn-sync-status () (defun xmtn-sync-status ()
"Start xmtn-status-one for current ewoc element." "Start xmtn-status-one for current ewoc element."
(let* ((data (ewoc-data (ewoc-locate xmtn-sync-ewoc))) (let* ((data (ewoc-data (ewoc-locate xmtn-sync-ewoc)))
(branch (xmtn-sync-branch-name data)) (branch (xmtn-sync-branch-name data))
<<<<<<< TREE
(work (assoc branch xmtn-sync-branch-alist))) (work (assoc branch xmtn-sync-branch-alist)))
(if (not work) (if (not work)
(progn (progn
@ -134,21 +210,105 @@ The elements must all be of type xmtn-sync-sync.")
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map [?0] '(menu-item "0) status" (define-key map [?0] '(menu-item "0) status"
'xmtn-sync-status)) 'xmtn-sync-status))
=======
save-work
(work (or
(cadr (assoc branch xmtn-sync-branch-alist))
(if (functionp xmtn-sync-guess-workspace)
(funcall xmtn-sync-guess-workspace branch))
(prog1
(read-directory-name (format "workspace root for %s: " branch))
(setq save-work t))
)))
(setf (xmtn-sync-branch-print-mode data) 'started) ; indicate we've started work on it
(ewoc-invalidate xmtn-sync-ewoc elem)
(condition-case err
(xmtn-status-one work)
('error
(if (and (not save-work) (functionp xmtn-sync-guess-workspace))
;; xmtn-sync-guess-workspace guessed wrong; prompt and try again
(progn
(setq work (read-directory-name (format "workspace root for %s: " branch)))
(setq save-work t)
(xmtn-status-one work)))))
;; don't save the workspace association until it is validated by xmtn-status-one
(if save-work
(progn
(push (list branch work) xmtn-sync-branch-alist)
(dvc-save-state
(list 'xmtn-sync-branch-alist)
(expand-file-name xmtn-sync-branch-file dvc-config-directory))))))
(defun xmtn-sync-update ()
"Start xmtn-status-on for current ewoc element, do update if possible."
(interactive)
(xmtn-sync-status)
(if (xmtn-status-updatep)
(xmtn-status-update)))
(defun xmtn-sync-clean ()
"Clean and delete current ewoc element."
(interactive)
(let* ((elem (ewoc-locate xmtn-sync-ewoc))
(status-buffer (get-buffer-create "*xmtn-multi-status*"))
(inhibit-read-only t))
(if (buffer-live-p status-buffer)
(kill-buffer status-buffer))
(ewoc-delete xmtn-sync-ewoc elem)))
(dvc-make-ewoc-next xmtn-sync-next xmtn-sync-ewoc)
(dvc-make-ewoc-prev xmtn-sync-prev xmtn-sync-ewoc)
(defvar xmtn-sync-kbd-map
(let ((map (make-sparse-keymap "action")))
;; last defined is first in displayed menu
(define-key map [?c] '(menu-item "c) clean" xmtn-sync-clean))
(define-key map [?f] '(menu-item "f) full" xmtn-sync-full))
(define-key map [?b] '(menu-item "b) brief" xmtn-sync-brief))
(define-key map [?s] '(menu-item "s) status" xmtn-sync-status))
(define-key map [?u] '(menu-item "u) update" xmtn-sync-update))
>>>>>>> MERGE-SOURCE
map) map)
"Keyboard menu keymap for xmtn-sync-ewoc.") "Keyboard menu keymap for xmtn-sync-ewoc.")
(defvar xmtn-sync-mode-map (defvar xmtn-sync-mode-map
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
<<<<<<< TREE
(define-key map [?q] 'dvc-buffer-quit) (define-key map [?q] 'dvc-buffer-quit)
(define-key map "\M-d" xmtn-sync-ewoc-map) (define-key map "\M-d" xmtn-sync-ewoc-map)
=======
(define-key map "\M-d" xmtn-sync-kbd-map)
(define-key map [?b] 'xmtn-sync-brief)
(define-key map [?c] 'xmtn-sync-clean)
(define-key map [?f] 'xmtn-sync-full)
(define-key map [?n] 'xmtn-sync-next)
(define-key map [?p] 'xmtn-sync-prev)
(define-key map [?q] 'dvc-buffer-quit)
(define-key map [?s] 'xmtn-sync-status)
(define-key map [?u] 'xmtn-sync-update)
(define-key map [?S] 'xmtn-sync-save)
>>>>>>> MERGE-SOURCE
map) map)
"Keymap used in `xmtn-sync-mode'.") "Keymap used in `xmtn-sync-mode'.")
(easy-menu-define xmtn-sync-mode-menu xmtn-sync-mode-map (easy-menu-define xmtn-sync-mode-menu xmtn-sync-mode-map
"`xmtn-sync' menu" "`xmtn-sync' menu"
`("Xmtn-sync" `("Xmtn-sync"
<<<<<<< TREE
["Do the right thing" xmtn-sync-ewoc-map t] ["Do the right thing" xmtn-sync-ewoc-map t]
["Quit" dvc-buffer-quit t] ["Quit" dvc-buffer-quit t]
=======
;; first item is top in display
["Status" xmtn-sync-status t]
["Update" xmtn-sync-update t]
["Brief display" xmtn-sync-brief t]
["Full display" xmtn-sync-full t]
["Clean/delete" xmtn-sync-clean t]
["Save" xmtn-sync-save t]
["Save and Quit" (lambda () (kill-buffer (current-buffer))) t]
>>>>>>> MERGE-SOURCE
)) ))
;; derive from nil causes no keymap to be used, but still have self-insert keys ;; derive from nil causes no keymap to be used, but still have self-insert keys
@ -160,12 +320,21 @@ The elements must all be of type xmtn-sync-sync.")
(setq xmtn-sync-ewoc (ewoc-create 'xmtn-sync-printer)) (setq xmtn-sync-ewoc (ewoc-create 'xmtn-sync-printer))
(setq dvc-buffer-refresh-function nil) (setq dvc-buffer-refresh-function nil)
(dvc-install-buffer-menu) (dvc-install-buffer-menu)
<<<<<<< TREE
<<<<<<< TREE <<<<<<< TREE
(setq buffer-read-only t) (setq buffer-read-only t)
(buffer-disable-undo) (buffer-disable-undo)
(set-buffer-modified-p nil)) (set-buffer-modified-p nil))
======= =======
(buffer-disable-undo)) (buffer-disable-undo))
=======
(add-hook 'kill-buffer-hook 'xmtn-sync-save nil t)
(buffer-disable-undo)
(unless xmtn-sync-branch-alist
(let ((branch-file (expand-file-name xmtn-sync-branch-file dvc-config-directory)))
(if (file-exists-p branch-file)
(load branch-file)))))
>>>>>>> MERGE-SOURCE
(defun xmtn-sync-parse-revision-certs (direction) (defun xmtn-sync-parse-revision-certs (direction)
"Parse certs associated with a revision; return (branch changelog date author)." "Parse certs associated with a revision; return (branch changelog date author)."
@ -226,21 +395,29 @@ The elements must all be of type xmtn-sync-sync.")
xmtn-sync-ewoc) xmtn-sync-ewoc)
(if (not old-branch) (if (not old-branch)
(ewoc-enter-last (let*
xmtn-sync-ewoc ((node-key (and (functionp xmtn-sync-sort)
(ecase direction (funcall xmtn-sync-sort branch)))
('receive (data
(make-xmtn-sync-branch (ecase direction
:name branch ('receive
:rev-alist (list (list revid (list date author changelog))) (make-xmtn-sync-branch
:send-count 0 :name branch
:print-mode 'summary)) :rev-alist (list (list revid (list date author changelog)))
('send :send-count 0
(make-xmtn-sync-branch :print-mode 'summary
:name branch :sort-key (nth 1 node-key)))
:rev-alist nil ('send
:send-count 1 (make-xmtn-sync-branch
:print-mode 'summary))))))) :name branch
:rev-alist nil
:send-count 1
:print-mode 'summary
:sort-key (nth 1 node-key))))))
(if (nth 0 node-key)
(ewoc-enter-before xmtn-sync-ewoc (nth 0 node-key) data)
(ewoc-enter-last xmtn-sync-ewoc data))
))))
(defun xmtn-sync-parse-revisions (direction) (defun xmtn-sync-parse-revisions (direction)
"Parse revisions with associated certs." "Parse revisions with associated certs."
@ -260,7 +437,6 @@ The elements must all be of type xmtn-sync-sync.")
(defun xmtn-sync-parse-certs (direction) (defun xmtn-sync-parse-certs (direction)
"Parse certs not associated with revisions." "Parse certs not associated with revisions."
;; The only case we care about is a new branch created from an existing revision.
(let ((keyword (ecase direction (let ((keyword (ecase direction
('receive "receive_cert") ('receive "receive_cert")
('send "send_cert"))) ('send "send_cert")))
@ -269,12 +445,14 @@ The elements must all be of type xmtn-sync-sync.")
branch branch
(date "") (date "")
(author "") (author "")
(changelog "create branch\n") (changelog "create or propagate branch\n")
old-branch) old-branch)
(while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value))) (while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value)))
(cond (cond
((string= cert-label "branch") ((string= cert-label "branch")
;; This happens when a new branch is created, or a branch is
;; propagated without any conflicts.
(xmtn-basic-io-check-line "value" (setq branch (cadar value))) (xmtn-basic-io-check-line "value" (setq branch (cadar value)))
(xmtn-basic-io-skip-line "key") (xmtn-basic-io-skip-line "key")
(xmtn-basic-io-check-line "revision" (setq revid (cadar value))) (xmtn-basic-io-check-line "revision" (setq revid (cadar value)))
@ -300,7 +478,8 @@ The elements must all be of type xmtn-sync-sync.")
(while (xmtn-basic-io-optional-skip-line keyword)))) (while (xmtn-basic-io-optional-skip-line keyword))))
(defun xmtn-sync-parse (begin) (defun xmtn-sync-parse (begin)
"Parse current buffer starting at BEGIN, fill in `xmtn-sync-ewoc' in current buffer, erase parsed text." "Parse current buffer starting at BEGIN, fill in `xmtn-sync-ewoc' in current buffer, erase parsed text.
Return non-nil if anything parsed."
(set-syntax-table xmtn-basic-io--*syntax-table*) (set-syntax-table xmtn-basic-io--*syntax-table*)
(goto-char begin) (goto-char begin)
@ -358,7 +537,9 @@ The elements must all be of type xmtn-sync-sync.")
(xmtn-sync-parse-revisions 'send) (xmtn-sync-parse-revisions 'send)
(xmtn-sync-parse-keys 'send) (xmtn-sync-parse-keys 'send)
(delete-region begin (point)) (let ((result (not (= begin (point)))))
(delete-region begin (point))
result)
) )
(defun xmtn-sync-load-file (&optional noerror) (defun xmtn-sync-load-file (&optional noerror)
@ -371,10 +552,14 @@ The elements must all be of type xmtn-sync-sync.")
(setq buffer-read-only nil) (setq buffer-read-only nil)
(dolist (data stuff) (ewoc-enter-last xmtn-sync-ewoc data)) (dolist (data stuff) (ewoc-enter-last xmtn-sync-ewoc data))
(setq buffer-read-only t) (setq buffer-read-only t)
<<<<<<< TREE
(set-buffer-modified-p nil)) (set-buffer-modified-p nil))
(unless noerror (unless noerror
(error "%s file not found" save-file))))) (error "%s file not found" save-file)))))
>>>>>>> MERGE-SOURCE >>>>>>> MERGE-SOURCE
=======
(set-buffer-modified-p nil)))))
>>>>>>> MERGE-SOURCE
;;;###autoload ;;;###autoload
(defun xmtn-sync-sync (local-db remote-host remote-db) (defun xmtn-sync-sync (local-db remote-host remote-db)
@ -463,10 +648,6 @@ Remote-db should include branch pattern in URI syntax."
(setq buffer-read-only t) (setq buffer-read-only t)
(set-buffer-modified-p nil) (set-buffer-modified-p nil)
(xmtn-sync-save) (xmtn-sync-save)
(unless xmtn-sync-branch-alist
(let ((branch-file (expand-file-name xmtn-sync-branch-file dvc-config-directory)))
(if (file-exists-p branch-file)
(load branch-file))))
)) ))
(defun xmtn-sync-save () (defun xmtn-sync-save ()
@ -492,14 +673,18 @@ Remote-db should include branch pattern in URI syntax."
"Display sync results in FILE (defaults to `xmtn-sync-review-file'), appended to content of `xmtn-sync-save-file'. "Display sync results in FILE (defaults to `xmtn-sync-review-file'), appended to content of `xmtn-sync-save-file'.
FILE should be output of 'automate sync'. (external sync handles tickers better)." FILE should be output of 'automate sync'. (external sync handles tickers better)."
(interactive) (interactive)
;; first load xmtn-sync-save-file (if (buffer-live-p (get-buffer "*xmtn-sync*"))
(pop-to-buffer (get-buffer-create "*xmtn-sync*")) (progn
(setq buffer-read-only nil) (pop-to-buffer "*xmtn-sync*")
(delete-region (point-min) (point-max)) (xmtn-sync-save))
(xmtn-sync-mode) ;; else create
(xmtn-sync-load-file) (pop-to-buffer (get-buffer-create "*xmtn-sync*"))
(setq buffer-read-only nil)
(delete-region (point-min) (point-max))
(xmtn-sync-mode)
(xmtn-sync-load-file file))
;; now add file ;; now add FILE
(setq file (or file (setq file (or file
(expand-file-name xmtn-sync-review-file dvc-config-directory))) (expand-file-name xmtn-sync-review-file dvc-config-directory)))
(if (file-exists-p file) (if (file-exists-p file)
@ -507,8 +692,12 @@ FILE should be output of 'automate sync'. (external sync handles tickers better)
(goto-char (point-min)) (goto-char (point-min))
(setq buffer-read-only nil) (setq buffer-read-only nil)
(insert-file-contents-literally file) (insert-file-contents-literally file)
(xmtn-sync-parse (point-min))
;; user may have run several syncs, dumping each output into FILE; loop thru each.
(while (xmtn-sync-parse (point-min)))
(setq buffer-read-only t) (setq buffer-read-only t)
(set-buffer-modified-p nil)
(xmtn-sync-save)
(delete-file file)))) (delete-file file))))
>>>>>>> MERGE-SOURCE >>>>>>> MERGE-SOURCE

4
dvc/texinfo/Makefile.in
View File

@ -50,7 +50,11 @@ uninstall:
info: dvc.info dvc-intro.info info: dvc.info dvc-intro.info
<<<<<<< TREE
alldeps = $(srcdir)/dvc.texinfo dvc-version.texinfo alldeps = $(srcdir)/dvc.texinfo dvc-version.texinfo
=======
alldeps = $(srcdir)/dvc.texinfo dvc-version.texinfo $(srcdir)/dvc-intro.texinfo
>>>>>>> MERGE-SOURCE
dvc.info: $(alldeps) dvc.info: $(alldeps)
$(MAKEINFO) $(srcdir)/dvc.texinfo $(MAKEINFO) $(srcdir)/dvc.texinfo

137
dvc/texinfo/dvc-intro.texinfo
View File

@ -14,7 +14,7 @@ distributed version control systems.
@smallexample @smallexample
@group @group
Copyright (C) 2007, 2008, 2009, 2010 Stephen Leake Copyright (C) 2007 - 2011 Stephen Leake
Permission is granted to copy, distribute and/or modify this document Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.2 under the terms of the GNU Free Documentation License, Version 1.2
or any later version published by the Free Software Foundation; or any later version published by the Free Software Foundation;
@ -48,6 +48,10 @@ Invoking
* xmtn-status-one:: * xmtn-status-one::
* xmtn-propagate-one:: * xmtn-propagate-one::
<<<<<<< TREE
=======
* xmtn-sync-review::
>>>>>>> MERGE-SOURCE
Key bindings Key bindings
@ -102,6 +106,9 @@ and managing branches require command line operations.
This manual describes the DVC user interface, and gives examples of This manual describes the DVC user interface, and gives examples of
some required command line operations, using the monotone backend. some required command line operations, using the monotone backend.
It also describes some DVC extensions that are specific to the
monotone backend.
@menu @menu
* Basic DVC:: * Basic DVC::
* Compare to CVS:: * Compare to CVS::
@ -116,7 +123,7 @@ use DVC, and providing common terminology.
Each backend will have its own documentation, and terminology that Each backend will have its own documentation, and terminology that
differs from this. The terms here are taken mostly from the monotone differs from this. The terms here are taken mostly from the monotone
backend, since it has the most readable user manual. backend.
Let's start with some definitions: Let's start with some definitions:
@ -144,9 +151,10 @@ The user interacts with the remote database in order to retrieve other
user's files, or deliver files to them. user's files, or deliver files to them.
@item revision @item revision
A set of changes to files that are applied together. Most operations The state of the entire workspace, usually including the set of
on the database involve revisions, and all changes to files are part changes to the workspace that transform it from the previous
of a revision. revision. Most operations on the database involve revisions, and all
changes to files are part of a revision.
@item branch @item branch
A label for distinct trees of revisions. There are two main uses for A label for distinct trees of revisions. There are two main uses for
@ -159,7 +167,7 @@ A database can store any number of branches.
@item heads @item heads
The revisions that are the leaves of the history tree on a single The revisions that are the leaves of the history tree on a single
branch. In monotone, there can be any number of heads (see branch. In monotone, there can be any number of heads on a branch (see
@ref{Merging}). @ref{Merging}).
@item merge @item merge
@ -190,7 +198,7 @@ The name of the buffer is not literally @dfn{*dvc-status*}; instead,
@dfn{*dvc-status*}. @dfn{*dvc-status*}.
@item *dvc-diff* buffer @item *dvc-diff* buffer
Another main user interface buffer. It shows the files involved in a Another main user interface buffer. It shows the files changed in a
particular revision, together with the diffs of the changes. Single particular revision, together with the diffs of the changes. Single
keystrokes invoke various operations. keystrokes invoke various operations.
@ -284,31 +292,40 @@ Similar to @command{xmtn-status-one}, but shows all workspaces
immediately under a root directory. immediately under a root directory.
@item xmtn-propagate-one @item xmtn-propagate-one
Summarizes the status of several workspaces Supervises propagating one workspace.
@item xmtn-propagate-multiple @item xmtn-propagate-multiple
Supervises propagating several workspaces Supervises propagating several workspaces.
<<<<<<< TREE <<<<<<< TREE
======= =======
@item xmtn-sync-sync @item xmtn-sync-sync
Syncs a local database with a remote database, displays branches that Syncs the local database with a remote database, then runs
have been transferred. xmtn-sync-review.
@item xmtn-sync-review @item xmtn-sync-review
Reviews saved output of an external @command{mtn automate sync}, Reviews saved output of a command-line @command{mtn automate sync},
displays branches that have been transferred. This is useful for syncs displays branches that have been transferred. This is useful for syncs
<<<<<<< TREE
that take a long time, because external commands display the tickers that take a long time, because external commands display the tickers
much better than DVC does. much better than DVC does.
The external sync should redirect stdout to @file{~/.dvc/sync.basic_io}. The external sync should redirect stdout to @file{~/.dvc/sync.basic_io}.
>>>>>>> MERGE-SOURCE
=======
that take a long time, because the command-line displays progress
tickers.
>>>>>>> MERGE-SOURCE >>>>>>> MERGE-SOURCE
@end table @end table
@menu @menu
* xmtn-status-one:: * xmtn-status-one::
* xmtn-propagate-one:: * xmtn-propagate-one::
<<<<<<< TREE
=======
* xmtn-sync-review::
>>>>>>> MERGE-SOURCE
@end menu @end menu
@node xmtn-status-one @node xmtn-status-one
@ -344,9 +361,13 @@ Perform the merge, using the conflict resolutions.
@item update @item update
Update the workspace to the current head revision (must be merged). Update the workspace to the current head revision (must be merged).
@item review update @item update preview
Open an @dfn{*xmtn-revlist*} buffer to review the revisions in the Open an @dfn{*xmtn-revlist*} buffer to review the revisions that will
most recent update. be included in the next update.
@item update review
Open an @dfn{*xmtn-revlist*} buffer to review the revisions that were
included in the most recent update.
@item ignore local changes @item ignore local changes
Don't show @dfn{commit}. Don't show @dfn{commit}.
@ -374,10 +395,6 @@ propagation of all workspaces immediately under two root
directories. This is useful when several related projects branch directories. This is useful when several related projects branch
together. together.
Before displaying actions, each branch pair is examined to see if
propagate is necessary. If it is not, the workspace is not examined
for changes (since that can take a long time).
In the list of actions, ``from'' stands for the name of the source In the list of actions, ``from'' stands for the name of the source
branch, ``to'' the name of the destination branch. branch, ``to'' the name of the destination branch.
@ -388,18 +405,18 @@ The possible actions are:
@item status ``from'' @item status ``from''
@itemx status ``to'' @itemx status ``to''
Start an @dfn{xmtn-multi-status} buffer for the specified workspace, Start an @dfn{xmtn-multi-status} buffer for the specified workspace,
to allow commit, update followed by update review, or merge with to allow commit, update preview, or merge with
conflict resolution. conflict resolution.
@itemx update ``to'' @itemx update ``to''
Update the specified workspace to the current head revision (must be Update the specified workspace to the current head revision (must be
merged). This bypasses the @dfn{xmtn-multi-status} buffer, and merged). This bypasses the @dfn{xmtn-multi-status} buffer, and
therefore does not provide for update review. Useful when you don't therefore does not provide for update preview. It does allow for
need to review the changes, which is the typical case for propagate. update review.
@item ignore local changes ``from'' @item ignore local changes ``from''
@item ignore local changes ``to'' @item ignore local changes ``to''
Don't show @dfn{local changes unknown}; assume the workspace is Don't show @dfn{need commit}; assume the workspace is
committed. Useful when you know that any local changes won't interfere committed. Useful when you know that any local changes won't interfere
with the propagate. with the propagate.
@ -420,6 +437,80 @@ the workspace from the display.
@end table @end table
<<<<<<< TREE
=======
@node xmtn-sync-review
@section xmtn-sync-review
@command{xmtn-sync-review} supervises the process of updating local
workspaces after a command line operation that synchronizes the local
and remote databases.
The command line operation should redirect stdout to
@file{~/.dvc/sync.basic_io}. Most users will want to define shell
functions to invoke common syncs. For example:
@example
mtn --db ~/monotone-dbs/gds.db automate sync --ticker=count "ssh:user@@host/gds.db?*" >> ~/.dvc/sync.basic_io
@end example
The @command{xmtn-sync-review} display shows each branch that was
transferred, with a count of how many revisions were sent and
received.
The user may set the variable @code{xmtn-sync-sort} to a function that
indicates how to order the branches in the display.
Actions on branches are invoked with @key{M-d}.
The possible branch actions are:
@table @command
@item status
Start an @dfn{xmtn-multi-status} buffer for the workspace assoicated
with the specified branch, to allow commit, update preview, update
followed by update review, or merge with conflict resolution.
The user may set the variable @code{xmtn-sync-guess-workspace} to a
function that returns a workspace given a branch. Otherwise, the user
is prompted for the workspace location; the location is cached for
future use.
@item update
Start an @dfn{xmtn-multi-status} buffer for the workspace assoicated
with the specified branch, then perform @command{update} (if
appropriate). This is often convenient when you know the workspace has
no local changes.
@itemx brief
Show the first line of the changelog for each revision received.
@itemx full
Show the complete changelog for each revision received.
@item clean
Delete the branch from the display.
Branches that are not cleaned are cached; they will reappear the next
time @code{xmtn-sync-review} is run.
@end table
In addition, there are global actions:
@table @command
@item next
Move to the next branch
@item prev
Move to the previous branch
@item save-quit
Save the displayed branches, quit.
@item save
Save the displayed branches.
@end table
>>>>>>> MERGE-SOURCE
@node Status Display @node Status Display
@chapter Status Display @chapter Status Display