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

updating elisp-vcs

Browse Source
This commit is contained in:
Kai Tetzlaff 2009-10-12 08:43:16 +02:00
parent d05cf8cddb
commit 4addd60521
13 changed files with 508 additions and 341 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dvc/Makefile
View File

@ -8,7 +8,7 @@ AUTOCONF = autoconf
TAR = tar TAR = tar
RM = @RM@ RM = @RM@
prefix = /usr/local prefix = /usr/local
datarootdir= ${prefix}/share datarootdir= /c/kt/.emacs.d
info_dir = ${datarootdir}/info info_dir = ${datarootdir}/info
srcdir = . srcdir = .
lispdir= /c/kt/.emacs.d/lisp/dvc lispdir= /c/kt/.emacs.d/lisp/dvc

4
dvc/lisp/Makefile
View File

@ -9,13 +9,13 @@ prefix = /usr/local
RM = @RM@ RM = @RM@
ETAGS = etags ETAGS = etags
MKDIR_P = /bin/mkdir -p MKDIR_P = /bin/mkdir -p
INSTALL = /bin/install -c INSTALL = /c/Tools/gnuwin32/bin/ginstall -c
INSTALL_DATA = ${INSTALL} -m 644 INSTALL_DATA = ${INSTALL} -m 644
top_srcdir = .. top_srcdir = ..
srcdir = . srcdir = .
datarootdir= ${prefix}/share datarootdir= /c/kt/.emacs.d
lispdir = /c/kt/.emacs.d/lisp/dvc lispdir = /c/kt/.emacs.d/lisp/dvc
EMACS_PROG = emacs EMACS_PROG = emacs

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

@ -827,7 +827,7 @@ workspace version)."
(diff-buffer (dvc-prepare-changes-buffer (diff-buffer (dvc-prepare-changes-buffer
base base
modified modified
'file-diff file 'bzr)) 'file-diff file dvc))
(base-buffer (base-buffer
(dvc-revision-get-file-in-buffer file base)) (dvc-revision-get-file-in-buffer file base))
(modified-buffer (modified-buffer

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

@ -203,9 +203,7 @@ conflicts, and/or ediff current files."
(dvc-fileinfo-add-log-entry prefix)) (dvc-fileinfo-add-log-entry prefix))
((deleted rename-source rename-target) ((deleted rename-source rename-target)
;; typically nothing to do; just need commit (dvc-status-ediff))
(ding)
(dvc-fileinfo-next))
(missing (missing
;; File is in database, but not in workspace ;; File is in database, but not in workspace

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

@ -257,6 +257,21 @@
(defvar xmtn-automate--*sessions* '()) (defvar xmtn-automate--*sessions* '())
(defun xmtn-automate-cache-session (root)
"Create a mtn automate session for workspace ROOT, store it in
session cache, return it (for later kill)."
(let* ((default-directory (file-name-as-directory root))
(key (file-truename default-directory))
(session (xmtn-automate--make-session root key)))
(setq xmtn-automate--*sessions*
(acons key session xmtn-automate--*sessions*))
session))
(defun xmtn-automate-get-cached-session (key)
"Return a session from the cache, or nil."
;; separate function so we can debug it
(cdr (assoc key xmtn-automate--*sessions*)))
(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key) (defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key)
&body body) &body body)
"Call BODY, after ensuring an automate session for ROOT-FORM is active." "Call BODY, after ensuring an automate session for ROOT-FORM is active."
@ -276,7 +291,7 @@
(thunk (gensym))) (thunk (gensym)))
`(let* ((,root (file-name-as-directory ,root-form)) `(let* ((,root (file-name-as-directory ,root-form))
(,key (file-truename ,root)) (,key (file-truename ,root))
(,session (cdr (assoc ,key xmtn-automate--*sessions*))) (,session (xmtn-automate-get-cached-session ,key))
(,thunk (lambda () (,thunk (lambda ()
(let ((,session-var ,session)) (let ((,session-var ,session))
,@body)))) ,@body))))
@ -286,6 +301,10 @@
(progn (progn
(setq ,session (xmtn-automate--make-session ,root ,key)) (setq ,session (xmtn-automate--make-session ,root ,key))
(let ((xmtn-automate--*sessions* (let ((xmtn-automate--*sessions*
;; note the let-binding here; these sessions are _not_
;; available for later commands. use
;; xmtn-automate-cache-session to get a persistent
;; session.
(acons ,key ,session xmtn-automate--*sessions*))) (acons ,key ,session xmtn-automate--*sessions*)))
(funcall ,thunk))) (funcall ,thunk)))
(when ,session (xmtn-automate--close-session ,session))))))) (when ,session (xmtn-automate--close-session ,session)))))))
@ -446,6 +465,7 @@ Signals an error if output contains zero lines or more than one line."
nil) nil)
(defun xmtn-automate--make-session (root key) (defun xmtn-automate--make-session (root key)
(dvc-trace "new session %s" key)
(let* ((name (format "xmtn automate session for %s" key))) (let* ((name (format "xmtn automate session for %s" key)))
(let ((session (xmtn-automate--%make-raw-session))) (let ((session (xmtn-automate--%make-raw-session)))
(xmtn-automate--initialize-session session :root root :name name) (xmtn-automate--initialize-session session :root root :name name)
@ -479,8 +499,7 @@ Signals an error if output contains zero lines or more than one line."
;; Process died for some reason - most likely 'mtn not found in ;; Process died for some reason - most likely 'mtn not found in
;; path'. Don't warn if buffer hasn't been deleted; that ;; path'. Don't warn if buffer hasn't been deleted; that
;; obscures the real error message ;; obscures the real error message
;; FIXME: if that is the reason, this assert fails. Disable assertions for now, fix later nil)
(xmtn--assert-optional (null (xmtn-automate--session-buffer session))))
((ecase (process-status process) ((ecase (process-status process)
(run nil) (run nil)
(exit t) (exit t)
@ -576,7 +595,7 @@ Signals an error if output contains zero lines or more than one line."
(exit nil) (exit nil)
(signal nil)) (signal nil))
(accept-process-output process)) (accept-process-output process))
;;(dvc-trace "Process in root %s terminated" root) (dvc-trace "Process in root %s terminated" root)
)) ))
(xmtn-automate--initialize-session (xmtn-automate--initialize-session
session session

15
dvc/lisp/xmtn-base.el
View File

@ -59,11 +59,22 @@ A list of strings.")
(save-match-data (save-match-data
(string-match "\\`[0-9a-f]\\{40\\}\\'" thing)))) (string-match "\\`[0-9a-f]\\{40\\}\\'" thing))))
(defun xmtn--filter-non-dir (dir)
"Return list of all directories in DIR, excluding '.', '..'."
(let ((default-directory dir)
(subdirs (directory-files dir)))
(setq subdirs
(mapcar (lambda (filename)
(if (and (file-directory-p filename)
(not (string= "." filename))
(not (string= ".." filename)))
filename))
subdirs))
(delq nil subdirs)))
(defvar xmtn--*enable-assertions* nil (defvar xmtn--*enable-assertions* nil
"Effective at macroexpansion time.") "Effective at macroexpansion time.")
;; (setq xmtn--*enable-assertions* t)
(defmacro xmtn--assert-for-effect (form &rest more-assert-args) (defmacro xmtn--assert-for-effect (form &rest more-assert-args)
(if xmtn--*enable-assertions* (if xmtn--*enable-assertions*
`(assert ,form ,@more-assert-args) `(assert ,form ,@more-assert-args)

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

@ -66,8 +66,10 @@
(defmacro xmtn--set-process-query-on-exit-flag (process value) (defmacro xmtn--set-process-query-on-exit-flag (process value)
(if (fboundp 'set-process-query-on-exit-flag) (if (fboundp 'set-process-query-on-exit-flag)
;; emacs 22.2 and greater
`(set-process-query-on-exit-flag ,process ,value) `(set-process-query-on-exit-flag ,process ,value)
`(progn `(progn
;; emacs 22.1
(process-kill-without-query ,process ,value) (process-kill-without-query ,process ,value)
,value))) ,value)))

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

@ -250,8 +250,8 @@ header."
(setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count)) (setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count))
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal))) (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal)))
((string= "resolved_user_left" symbol) ((string= "resolved_user" symbol)
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_left_user (cadar value)))) (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user (cadar value))))
(t (t
(error "found %s" symbol))))))) (error "found %s" symbol)))))))
@ -495,7 +495,8 @@ header."
"Write EWOC-BUFFER header info in basic-io format to current buffer." "Write 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))
(xmtn-basic-io-write-id "ancestor" (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision)) (if xmtn-conflicts-ancestor-revision
(xmtn-basic-io-write-id "ancestor" (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision)))
) )
(defun xmtn-conflicts-write-content (conflict) (defun xmtn-conflicts-write-content (conflict)
@ -522,7 +523,7 @@ header."
(insert "resolved_keep_left \n")) (insert "resolved_keep_left \n"))
(resolved_user (resolved_user
(xmtn-basic-io-write-str "resolved_user_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict)))) (xmtn-basic-io-write-str "resolved_user" (cadr (xmtn-conflicts-conflict-left_resolution conflict))))
)))) ))))
(defun xmtn-conflicts-write-duplicate_name (conflict) (defun xmtn-conflicts-write-duplicate_name (conflict)
@ -852,19 +853,25 @@ header."
(setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_drop)) (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_drop))
(ewoc-invalidate xmtn-conflicts-ewoc elem))) (ewoc-invalidate xmtn-conflicts-ewoc elem)))
(defun xmtn-conflicts-resolve-user (side) (defun xmtn-conflicts-resolve-user (resolve-side default-side)
"Resolve the current conflict by user_SIDE." "Resolve the current conflict by user_RESOLVE-SIDE. Default to file from DEFAULT-SIDE."
(interactive) (interactive)
;; Right is the target workspace in a propagate, and also the current
;; workspace in a merge. So default to right_name.
(let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) (let* ((elem (ewoc-locate xmtn-conflicts-ewoc))
(conflict (ewoc-data elem)) (conflict (ewoc-data elem))
(result-file (read-file-name "resolution file: " "./" nil t (result-file
(xmtn-conflicts-conflict-right_name conflict)))) (expand-file-name
(ecase side (read-file-name "resolution file: "
('left (ecase default-side
(left (file-name-as-directory xmtn-conflicts-left-work))
(right (file-name-as-directory xmtn-conflicts-right-work)))
nil t
(ecase default-side
(left (xmtn-conflicts-conflict-left_name conflict))
(right (xmtn-conflicts-conflict-right_name conflict)))))))
(ecase resolve-side
(left
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user result-file))) (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user result-file)))
('right (right
(setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user result-file))) (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user result-file)))
) )
(ewoc-invalidate xmtn-conflicts-ewoc elem))) (ewoc-invalidate xmtn-conflicts-ewoc elem)))
@ -987,32 +994,42 @@ header."
;; Don't need 'left' or 'right' in menu, since only one is ;; Don't need 'left' or 'right' in menu, since only one is
;; visible; then this works better for single file conflicts. ;; visible; then this works better for single file conflicts.
(define-key map [?9] '(menu-item "9) drop" (define-key map [?b] '(menu-item "b) drop"
xmtn-conflicts-resolve-drop_right xmtn-conflicts-resolve-drop_right
:visible (xmtn-conflicts-resolve-drop_rightp))) :visible (xmtn-conflicts-resolve-drop_rightp)))
(define-key map [?8] '(menu-item "8) rename" (define-key map [?a] '(menu-item "a) rename"
(lambda () (lambda ()
(interactive) (interactive)
(xmtn-conflicts-resolve-rename 'right)) (xmtn-conflicts-resolve-rename 'right))
:visible (xmtn-conflicts-resolve-rename_rightp))) :visible (xmtn-conflicts-resolve-rename_rightp)))
(define-key map [?7] '(menu-item "7) file" (define-key map [?9] '(menu-item "9) right file"
(lambda () (lambda ()
(interactive) (interactive)
(xmtn-conflicts-resolve-user 'right)) (xmtn-conflicts-resolve-user 'right 'right))
:visible (xmtn-conflicts-resolve-user_rightp))) :visible (xmtn-conflicts-resolve-user_rightp)))
(define-key map [?6] '(menu-item "6) keep" (define-key map [?8] '(menu-item "8) left file"
(lambda ()
(interactive)
(xmtn-conflicts-resolve-user 'right 'left))
:visible (xmtn-conflicts-resolve-user_rightp)))
(define-key map [?7] '(menu-item "7) keep"
xmtn-conflicts-resolve-keep_right xmtn-conflicts-resolve-keep_right
:visible (xmtn-conflicts-resolve-keep_rightp))) :visible (xmtn-conflicts-resolve-keep_rightp)))
(define-key map [?5] '(menu-item "5) ediff" (define-key map [?6] '(menu-item "6) ediff"
(lambda () (lambda ()
(interactive) (interactive)
(xmtn-conflicts-resolve-ediff 'right)) (xmtn-conflicts-resolve-ediff 'right))
:visible (xmtn-conflicts-resolve-user_rightp))) :visible (xmtn-conflicts-resolve-user_rightp)))
(define-key map [?4] '(menu-item "4) file" (define-key map [?5] '(menu-item "5) right file"
(lambda () (lambda ()
(interactive) (interactive)
(xmtn-conflicts-resolve-user 'left)) (xmtn-conflicts-resolve-user 'left 'right))
:visible (xmtn-conflicts-resolve-user_leftp)))
(define-key map [?4] '(menu-item "4) left file"
(lambda ()
(interactive)
(xmtn-conflicts-resolve-user 'left 'left))
:visible (xmtn-conflicts-resolve-user_leftp))) :visible (xmtn-conflicts-resolve-user_leftp)))
(define-key map [?3] '(menu-item "3) drop" (define-key map [?3] '(menu-item "3) drop"
xmtn-conflicts-resolve-drop_left xmtn-conflicts-resolve-drop_left
@ -1058,17 +1075,17 @@ non-nil, show log-edit buffer in other frame."
(insert ": ") (insert ": ")
)) ))
(defun xmtn-conflicts-do-propagate () (defun xmtn-conflicts-do-propagate (&optional cached-branch)
"Perform propagate on revisions in current conflict buffer." "Perform propagate on revisions in current conflict buffer."
(interactive) (interactive)
(save-some-buffers t); log buffer (save-some-buffers t); log buffer
(xmtn-propagate-from xmtn-conflicts-left-branch)) (xmtn-propagate-from xmtn-conflicts-left-branch cached-branch))
(defun xmtn-conflicts-do-merge () (defun xmtn-conflicts-do-merge ()
"Perform merge on revisions in current conflict buffer." "Perform merge on revisions in current conflict buffer."
(interactive) (interactive)
(save-some-buffers t); log buffer (save-some-buffers t); log buffer
(xmtn-dvc-merge)) (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."
@ -1105,6 +1122,7 @@ non-nil, show log-edit buffer in other frame."
"`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]
["Propagate" xmtn-conflicts-do-propagate t] ["Propagate" xmtn-conflicts-do-propagate t]
["Merge" xmtn-conflicts-do-merge t] ["Merge" xmtn-conflicts-do-merge t]
["Update" dvc-update t] ["Update" dvc-update t]
@ -1137,13 +1155,15 @@ 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) (defun xmtn-conflicts-save-opts (left-work right-work &optional left-branch right-branch)
"Store LEFT-WORK, RIGHT-WORK in `xmtn-conflicts-opts-file', for "Store LEFT-WORK, RIGHT-WORK in `xmtn-conflicts-opts-file', for
retrieval by `xmtn-conflicts-load-opts'." retrieval by `xmtn-conflicts-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 (xmtn--tree-default-branch left-work)) (xmtn-conflicts-left-branch (or left-branch
(xmtn-conflicts-right-branch (xmtn--tree-default-branch right-work))) (xmtn--tree-default-branch left-work)))
(xmtn-conflicts-right-branch (or right-branch
(xmtn--tree-default-branch right-work))))
(dvc-save-state (list 'xmtn-conflicts-left-work (dvc-save-state (list 'xmtn-conflicts-left-work
'xmtn-conflicts-left-branch 'xmtn-conflicts-left-branch
@ -1174,19 +1194,17 @@ to right. Stores conflict file in RIGHT-WORK/_MTN."
'xmtn 'xmtn
(list "conflicts" "store" left-rev right-rev) (list "conflicts" "store" left-rev right-rev)
:finished (lambda (output error status arguments) :finished (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(xmtn-conflicts-review default-directory)) (xmtn-conflicts-review default-directory))
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(pop-to-buffer error)) (pop-to-buffer error))
))) )))
(defun xmtn-check-workspace-for-propagate (work) (defun xmtn-check-workspace-for-propagate (work cached-branch)
"Check that workspace WORK is ready for propagate. "Check that workspace WORK is ready for propagate.
It must be merged, and should be at the head revision, and have no local changes." It must be merged, and should be at the head revision, and have no local changes."
(let* ((default-directory work) (let* ((default-directory work)
(heads (xmtn--heads default-directory nil)) (heads (xmtn--heads default-directory cached-branch))
(base (xmtn--get-base-revision-hash-id-or-null default-directory))) (base (xmtn--get-base-revision-hash-id-or-null default-directory)))
(message "checking %s for multiple heads, base not head" work) (message "checking %s for multiple heads, base not head" work)
@ -1250,17 +1268,20 @@ workspace."
(setq left-work (dvc-read-project-tree-maybe "Propagate from (workspace directory): " left-work)) (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)) (setq right-work (dvc-read-project-tree-maybe "to (workspace directory): " right-work))
(xmtn-check-workspace-for-propagate left-work) (let ((left-branch (xmtn--tree-default-branch left-work))
(xmtn-check-workspace-for-propagate right-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) (xmtn-check-propagate-needed left-work right-work)
(message "computing conflicts") (message "computing conflicts")
(xmtn-conflicts-1 left-work (xmtn-conflicts-1 left-work
(car (xmtn--heads left-work nil)) (car (xmtn--heads left-work left-branch))
right-work right-work
(car (xmtn--heads right-work nil)))) (car (xmtn--heads right-work right-branch)))))
;;;###autoload ;;;###autoload
(defun xmtn-conflicts-merge () (defun xmtn-conflicts-merge ()
@ -1304,6 +1325,8 @@ workspace."
(if (file-exists-p "_MTN/resolutions") (if (file-exists-p "_MTN/resolutions")
(dired-delete-file "_MTN/resolutions" 'always)) (dired-delete-file "_MTN/resolutions" 'always))
(message "conflicts cleaned")
)) ))
(provide 'xmtn-conflicts) (provide 'xmtn-conflicts)

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

@ -285,12 +285,6 @@ the file before saving."
(if (file-exists-p log-edit-file) (if (file-exists-p log-edit-file)
(concat "--message-file=" log-edit-file)))) (concat "--message-file=" log-edit-file))))
(defun xmtn-dvc-log-clean ()
"Delete xmtn log file."
(let ((log-edit-file "_MTN/log"))
(if (file-exists-p log-edit-file)
(delete-file log-edit-file))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-log-edit-done () (defun xmtn-dvc-log-edit-done ()
(let* ((root default-directory) (let* ((root default-directory)
@ -351,11 +345,9 @@ the file before saving."
"--depth=0" "--depth=0"
"--" normalized-files)))) "--" normalized-files))))
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(dvc-default-error-function output error (dvc-default-error-function output error
status arguments)) status arguments))
:killed (lambda (output error status arguments) :killed (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(dvc-default-killed-function output error (dvc-default-killed-function output error
status arguments)) status arguments))
:finished (lambda (output error status arguments) :finished (lambda (output error status arguments)
@ -363,13 +355,18 @@ the file before saving."
;; Monotone creates an empty log file when the ;; Monotone creates an empty log file when the
;; commit was successful. Let's not interfere with ;; commit was successful. Let's not interfere with
;; that. (Calling `dvc-log-close' would.) ;; that. (Calling `dvc-log-close' would.)
(xmtn-dvc-log-clean)
;; we'd like to delete log-edit-buffer here, but
;; we can't do that from a process sentinel
(dvc-diff-clear-buffers 'xmtn (dvc-diff-clear-buffers 'xmtn
default-directory default-directory
"* Just committed! Please refresh buffer" "* Just committed! Please refresh buffer"
(xmtn--status-header (xmtn--status-header
default-directory default-directory
(xmtn--get-base-revision-hash-id-or-null default-directory))))) (xmtn--get-base-revision-hash-id-or-null default-directory)))
))
;; Show message _after_ spawning command to override DVC's ;; Show message _after_ spawning command to override DVC's
;; debugging message. ;; debugging message.
(message "%s... " progress-message)) (message "%s... " progress-message))
@ -1224,22 +1221,25 @@ finished."
(check-type revision-hash-id xmtn--hash-id) (check-type revision-hash-id xmtn--hash-id)
(xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id))) (xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id)))
(defun xmtn--do-update (root target-revision-hash-id) (defun xmtn--do-update (root target-revision-hash-id post-update-p)
(check-type root string) (check-type root string)
(check-type target-revision-hash-id xmtn--hash-id) (check-type target-revision-hash-id xmtn--hash-id)
(lexical-let ((progress-message (format "Updating tree %s to revision %s" (lexical-let ((progress-message (format "Updating tree %s to revision %s"
root target-revision-hash-id))) root target-revision-hash-id))
(post-update-p post-update-p))
(let ((command `("update" "--move-conflicting-paths" ,(concat "--revision=" target-revision-hash-id))) (let ((command `("update" "--move-conflicting-paths" ,(concat "--revision=" target-revision-hash-id)))
(post-process (post-process
(lambda () (lambda ()
(message "%s... done" progress-message) (message "%s... done" progress-message)
(if post-update-p
(progn
(dvc-revert-some-buffers default-directory) (dvc-revert-some-buffers default-directory)
(dvc-diff-clear-buffers 'xmtn (dvc-diff-clear-buffers 'xmtn
default-directory default-directory
"* Just updated; please refresh buffer" "* Just updated; please refresh buffer"
(xmtn--status-header (xmtn--status-header
default-directory default-directory
(xmtn--get-base-revision-hash-id-or-null default-directory))))) (xmtn--get-base-revision-hash-id-or-null default-directory)))))))
) )
(message "%s..." progress-message) (message "%s..." progress-message)
@ -1248,28 +1248,32 @@ finished."
(funcall post-process)) (funcall post-process))
nil)) nil))
(defun xmtn--update (root target-revision-hash-id) (defun xmtn--update (root target-revision-hash-id check-id-p no-ding)
;; mtn will just give an innocuous message if already updated, which ;; mtn will just give an innocuous message if already updated, which
;; the user won't see. So check that here - it's fast. ;; the user won't see. So check that here - it's fast.
(when (equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id) ;; Don't throw an error; upper level might be doing other directories as well.
(error "Tree %s is already based on target revision %s" (if (and check-id-p
(equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id))
(progn
(unless no-ding (ding))
(message "Tree %s is already based on target revision %s"
root target-revision-hash-id)) root target-revision-hash-id))
(dvc-save-some-buffers root) (dvc-save-some-buffers root)
(xmtn--do-update root target-revision-hash-id)) (xmtn--do-update root target-revision-hash-id check-id-p)))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-update (&optional revision-id) (defun xmtn-dvc-update (&optional revision-id no-ding)
(let ((root (dvc-tree-root))) (let ((root (dvc-tree-root)))
(xmtn-automate-with-session (nil root) (xmtn-automate-with-session (nil root)
(if revision-id (if revision-id
(xmtn--update root (xmtn--revision-hash-id revision-id)) (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)
(let* ((branch (xmtn--tree-default-branch root)) (let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch))) (heads (xmtn--heads root branch)))
(case (length heads) (case (length heads)
(0 (assert nil)) (0 (assert nil))
(1 (1
(xmtn--update root (first heads))) (xmtn--update root (first heads) t no-ding))
(t (t
;; User can choose one head from a revlist, or merge them. ;; User can choose one head from a revlist, or merge them.
@ -1279,12 +1283,13 @@ finished."
branch (length heads)))))))) branch (length heads))))))))
nil) nil)
(defun xmtn-propagate-from (other) (defun xmtn-propagate-from (other &optional cached-branch)
"Propagate from OTHER branch to local tree branch." "Propagate from OTHER branch to local tree branch."
(interactive "MPropagate from branch: ") (interactive "MPropagate from branch: ")
(let* (let*
((root (dvc-tree-root)) ((root (dvc-tree-root))
(local-branch (xmtn--tree-default-branch root)) (local-branch (or cached-branch
(xmtn--tree-default-branch root)))
(resolve-conflicts (resolve-conflicts
(if (file-exists-p (concat root "/_MTN/conflicts")) (if (file-exists-p (concat root "/_MTN/conflicts"))
(progn (progn
@ -1318,31 +1323,35 @@ finished."
(xmtn--refresh-status-header display-buffer) (xmtn--refresh-status-header display-buffer)
(message "%s... done" msg))))))) (message "%s... done" msg)))))))
(defun xmtn-dvc-merge-1 (root refresh-status)
(lexical-let ((refresh-status refresh-status))
(xmtn-automate-with-session
(nil root)
(xmtn--run-command-async
root
(list
"merge"
(if (file-exists-p (concat root "/_MTN/conflicts"))
"--resolve-conflicts-file=_MTN/conflicts")
(xmtn-dvc-log-message))
:finished (lambda (output error status arguments)
(if refresh-status
(xmtn--refresh-status-header (current-buffer))))))))
;;;###autoload ;;;###autoload
(defun xmtn-dvc-merge (&optional other) (defun xmtn-dvc-merge (&optional other)
(if other (if other
(xmtn-propagate-from other) (xmtn-propagate-from other)
;; else merge heads ;; else merge heads
(let* ((root (dvc-tree-root)) (let* ((root (dvc-tree-root))
(resolve-conflicts (branch (xmtn--tree-default-branch root))
(if (file-exists-p (concat root "/_MTN/conflicts"))
(progn
"--resolve-conflicts-file=_MTN/conflicts"))))
(lexical-let
((display-buffer (current-buffer)))
(xmtn-automate-with-session
(nil root)
(let* ((branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch))) (heads (xmtn--heads root branch)))
(case (length heads) (case (length heads)
(0 (assert nil)) (0 (assert nil))
(1 (1
(message "already merged")) (message "already merged"))
(t (t
(xmtn--run-command-that-might-invoke-merger (xmtn-dvc-merge-1 root t)))))
root
(list "merge" resolve-conflicts (xmtn-dvc-log-message))
(lambda () (xmtn--refresh-status-header display-buffer))))))))))
nil) nil)
;;;###autoload ;;;###autoload

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

@ -152,9 +152,27 @@ See file commentary for details."
,base-revision-hash-id ,base-revision-hash-id
,(1- num)))))) ,(1- num))))))
(defun xmtn--get-parent-revision-hash-id (root hash-id local-branch)
(check-type hash-id xmtn--hash-id)
(let ((parents (xmtn-automate-simple-command-output-lines root `("parents"
,hash-id))))
(case (length parents)
(0 (error "Revision has no parents: %s" hash-id))
(1 (let ((parent (first parents)))
(assert (typep parent 'xmtn--hash-id))
parent))
(t
;; If this revision is the result of a propagate, there are two parents, one of which is on the local branch
(let ((first-parent-branch (xmtn--branch-of root (first parents))))
(if (equal local-branch first-parent-branch)
(first parents)
(second parents)))
))))
(defun xmtn--resolve--previous-revision (root backend-id num) (defun xmtn--resolve--previous-revision (root backend-id num)
(check-type num (integer 0 *)) (check-type num (integer 0 *))
(let ((resolved-id (xmtn--resolve-backend-id root backend-id))) (let ((local-branch (xmtn--tree-default-branch root))
(resolved-id (xmtn--resolve-backend-id root backend-id)))
(if (zerop num) (if (zerop num)
resolved-id resolved-id
(ecase (first resolved-id) (ecase (first resolved-id)
@ -170,7 +188,7 @@ See file commentary for details."
(check-type hash-id xmtn--hash-id) (check-type hash-id xmtn--hash-id)
(loop repeat num (loop repeat num
;; If two parents of this rev, use parent on same branch as rev. ;; If two parents of this rev, use parent on same branch as rev.
do (setq hash-id (xmtn--get-parent-revision-hash-id root hash-id t))) do (setq hash-id (xmtn--get-parent-revision-hash-id root hash-id local-branch)))
`(revision ,hash-id))))))) `(revision ,hash-id)))))))
(defun xmtn--error-unless-revision-exists (root hash-id) (defun xmtn--error-unless-revision-exists (root hash-id)
@ -216,31 +234,6 @@ must be a workspace."
))))) )))))
result)) result))
(defun xmtn--get-parent-revision-hash-id (root hash-id &optional multi-parent-use-local-branch)
(check-type hash-id xmtn--hash-id)
(let ((parents (xmtn-automate-simple-command-output-lines root `("parents"
,hash-id))))
(case (length parents)
(0 (error "Revision has no parents: %s" hash-id))
(1 (let ((parent (first parents)))
(assert (typep parent 'xmtn--hash-id))
parent))
(t
(if multi-parent-use-local-branch
;; If this revision is the result of a propagate, there are two parents, one of which is on the local branch
(let ((local-branch (xmtn--tree-default-branch root))
(first-parent-branch (xmtn--branch-of root (first parents))))
(if (equal local-branch first-parent-branch)
(first parents)
(second parents)))
;; Otherwise, just error. Depending on the context, we should
;; prompt which parent is desired, or operate on all of them.
;; This function is too low-level to decide what to do, though.
;; Need to wait for use cases.
(error "Revision has more than one parent (%s): %s"
(length parents)
hash-id))))))
(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-simple-command-output-line
root `("get_base_revision_id")))) root `("get_base_revision_id"))))

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

@ -26,19 +26,35 @@
(eval-when-compile (eval-when-compile
;; these have functions we use ;; these have functions we use
(require 'xmtn-base)
(require 'xmtn-conflicts)) (require 'xmtn-conflicts))
(defvar xmtn-propagate-from-root "" (defvar xmtn-propagate-from-root ""
"Buffer-local variable holding `from' root directory.") "Buffer-local variable holding `from' root directory.")
(make-variable-buffer-local 'xmtn-propagate-from-root) (make-variable-buffer-local 'xmtn-propagate-from-root)
(put 'xmtn-propagate-from-root 'permanent-local t)
(defvar xmtn-propagate-to-root "" (defvar xmtn-propagate-to-root ""
"Buffer-local variable holding `to' root directory.") "Buffer-local variable holding `to' root directory.")
(make-variable-buffer-local 'xmtn-propagate-to-root) (make-variable-buffer-local 'xmtn-propagate-to-root)
(put 'xmtn-propagate-to-root 'permanent-local t)
(defvar xmtn-propagate-ewoc nil
"Buffer-local ewoc for displaying propagations.
All xmtn-propagate functions operate on this ewoc.
The elements must all be of class xmtn-propagate-data.")
(make-variable-buffer-local 'xmtn-propagate-ewoc)
(put 'xmtn-propagate-ewoc 'permanent-local t)
(defstruct (xmtn-propagate-data (:copier nil)) (defstruct (xmtn-propagate-data (:copier nil))
from-work ; directory name relative to xmtn-propagate-from-root from-work ; directory name relative to xmtn-propagate-from-root
to-work ; directory name relative to xmtn-propagate-to-root to-work ; directory name relative to xmtn-propagate-to-root
from-name ; display name, in buffer and menus
to-name ;
from-branch ; branch name (assumed never changes)
to-branch ;
from-session ; mtn automate session
to-session ;
need-refresh ; nil | t; if an async process was started that invalidates state data need-refresh ; nil | t; if an async process was started that invalidates state data
from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads
to-head-rev ; to-head-rev ;
@ -47,9 +63,9 @@
from-heads ; 'at-head | 'need-update | 'need-merge) from-heads ; 'at-head | 'need-update | 'need-merge)
to-heads ; to-heads ;
(from-local-changes (from-local-changes
'need-scan) ; 'need-scan | 'need-status | 'ok 'need-scan) ; 'need-scan | 'need-commit | 'ok
(to-local-changes (to-local-changes
'need-scan) ; once these are changed from 'need-scan, no action changes it . '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 | 'ok
) )
@ -60,6 +76,14 @@
(defun xmtn-propagate-to-work (data) (defun xmtn-propagate-to-work (data)
(concat xmtn-propagate-to-root (xmtn-propagate-data-to-work data))) (concat xmtn-propagate-to-root (xmtn-propagate-data-to-work data)))
(defun xmtn-propagate-from-name ()
"Display name for current `from' workspace."
(xmtn-propagate-data-from-name (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(defun xmtn-propagate-to-name ()
"Display name for current `to' workspace."
(xmtn-propagate-data-to-name (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(defun xmtn-propagate-need-refresh (elem data) (defun xmtn-propagate-need-refresh (elem data)
(setf (xmtn-propagate-data-need-refresh data) t) (setf (xmtn-propagate-data-need-refresh data) t)
(ewoc-invalidate xmtn-propagate-ewoc elem)) (ewoc-invalidate xmtn-propagate-ewoc elem))
@ -77,28 +101,39 @@
(if (xmtn-propagate-data-need-refresh data) (if (xmtn-propagate-data-need-refresh data)
(insert (dvc-face-add " need refresh\n" 'dvc-conflict)) (insert (dvc-face-add " need refresh\n" 'dvc-conflict))
(if (xmtn-propagate-data-propagate-needed data)
(progn
(ecase (xmtn-propagate-data-from-local-changes data) (ecase (xmtn-propagate-data-from-local-changes data)
(need-scan (insert " from local changes unknown\n")) (need-scan (insert " local changes unknown " (xmtn-propagate-data-from-name data) "\n"))
(need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header))) (need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-from-name data) "\n")
'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 " to local changes unknown\n")) (need-scan (insert " local changes unknown " (xmtn-propagate-data-to-name data) "\n"))
(need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header))) (need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-to-name data) "\n")
'dvc-header)))
(ok nil)) (ok nil))
(ecase (xmtn-propagate-data-from-heads data) (ecase (xmtn-propagate-data-from-heads data)
(at-head nil) (at-head nil)
(need-update (insert (dvc-face-add " need dvc-missing from\n" 'dvc-conflict))) (need-update
(need-merge (insert (dvc-face-add " need xmtn-heads from\n" 'dvc-conflict)))) (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-from-name data) "\n")
'dvc-conflict)))
(need-merge
(insert (dvc-face-add (concat " need merge " (xmtn-propagate-data-from-name data) "\n")
'dvc-conflict))))
(ecase (xmtn-propagate-data-to-heads data) (ecase (xmtn-propagate-data-to-heads data)
(at-head nil) (at-head nil)
(need-update (insert (dvc-face-add " need dvc-missing to\n" 'dvc-conflict))) (need-update
(need-merge (insert (dvc-face-add " need xmtn-heads to\n" 'dvc-conflict)))) (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-to-name data) "\n")
'dvc-conflict)))
(need-merge
(insert (dvc-face-add (concat " need merge " (xmtn-propagate-data-to-name data) "\n")
'dvc-conflict))))
(if (xmtn-propagate-data-propagate-needed data)
(if (and (eq 'at-head (xmtn-propagate-data-from-heads data)) (if (and (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)))
@ -112,77 +147,81 @@
(insert (dvc-face-add " need propagate\n" 'dvc-conflict))) (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))
(ok (ok
(insert (dvc-face-add " need propagate\n" 'dvc-conflict))))) (insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
)
;; propagate not needed (if (eq 'at-head (xmtn-propagate-data-to-heads data))
(ecase (xmtn-propagate-data-from-local-changes data) (insert " need clean\n"))
(need-scan (insert " from local changes unknown\n")) ))
(need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header))) ;; ewoc ought to do this, but it doesn't
(ok nil)) (redisplay))
(ecase (xmtn-propagate-data-to-local-changes data) (defun xmtn-kill-conflicts-buffer (data)
(need-scan (insert " to local changes unknown\n")) (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
(need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header))) (let ((buffer (xmtn-propagate-data-conflicts-buffer data)))
(ok nil)) (with-current-buffer buffer (save-buffer))
(kill-buffer buffer))))
(ecase (xmtn-propagate-data-to-heads data)
(at-head nil)
(need-update (insert (dvc-face-add " need dvc-update to\n" 'dvc-conflict)))
(need-merge (insert (dvc-face-add " programmer error!\n" 'dvc-conflict))))
)))
(defvar xmtn-propagate-ewoc nil
"Buffer-local ewoc for displaying propagations.
All xmtn-propagate functions operate on this ewoc.
The elements must all be of class xmtn-propagate-data.")
(make-variable-buffer-local 'xmtn-propagate-ewoc)
(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)))
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-from-work data))) ;; only one conflicts file and buffer
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
(xmtn-kill-conflicts-buffer data)
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(ewoc-delete xmtn-propagate-ewoc elem)))) (ewoc-delete xmtn-propagate-ewoc elem))))
(defun xmtn-propagate-cleanp () (defun xmtn-propagate-cleanp ()
"Non-nil if clean is appropriate for current workspace." "Non-nil if clean is appropriate for current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) ;; don't check need-refresh here; allow deleting after just doing
;; final required action in another buffer. Or we've just started,
;; but the user knows it's ok.
(and (member (xmtn-propagate-data-from-local-changes data) '(need-scan ok))
(member (xmtn-propagate-data-to-local-changes data) '(need-scan ok))
(not (xmtn-propagate-data-propagate-needed data)) (not (xmtn-propagate-data-propagate-needed data))
(eq 'at-head (xmtn-propagate-data-to-heads data))))) (member (xmtn-propagate-data-to-heads data) '(need-scan at-head)))))
(defun xmtn-propagate-do-refresh-one () (defun xmtn-propagate-do-refresh-one ()
(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-refresh-one data) (xmtn-propagate-refresh-one data (or current-prefix-arg
(not (xmtn-propagate-data-need-refresh data))))
(ewoc-invalidate xmtn-propagate-ewoc elem))) (ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-refreshp () (defun xmtn-propagate-refreshp ()
"Non-nil if refresh is appropriate for current workspace." "Non-nil if refresh is appropriate for current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(xmtn-propagate-data-need-refresh data))) (or (xmtn-propagate-data-need-refresh data)
(eq 'need-scan (xmtn-propagate-data-from-local-changes data))
(eq 'need-scan (xmtn-propagate-data-to-local-changes data)))))
(defun xmtn-propagate-update () (defun xmtn-propagate-update-to ()
"Update current workspace." "Update current workspace."
(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-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (xmtn--update (xmtn-propagate-to-work data)
(xmtn-dvc-update)) (xmtn-propagate-data-to-head-rev data)
(xmtn-propagate-refresh-one data) nil t)
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem))) (ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-updatep () (defun xmtn-propagate-update-from ()
"Non-nil if update is appropriate for current workspace." "Update current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (interactive)
(and (not (xmtn-propagate-data-need-refresh data)) (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(not (xmtn-propagate-data-propagate-needed data)) (data (ewoc-data elem)))
(eq 'need-update (xmtn-propagate-data-to-heads data))))) (xmtn-propagate-need-refresh elem data)
(xmtn--update (xmtn-propagate-from-work data)
(xmtn-propagate-data-from-head-rev data)
nil t)
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-propagate () (defun xmtn-propagate-propagate ()
"Propagate current workspace." "Propagate current workspace."
@ -192,8 +231,8 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem 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-conflicts-do-propagate (xmtn-propagate-data-to-branch data))))
(xmtn-propagate-refresh-one data) (xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem))) (ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-propagatep () (defun xmtn-propagate-propagatep ()
@ -212,6 +251,7 @@ The elements must all be of class xmtn-propagate-data.")
(let* ((elem (ewoc-locate xmtn-propagate-ewoc)) (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
(setf (xmtn-propagate-data-conflicts data) 'ok)
(pop-to-buffer (xmtn-propagate-data-conflicts-buffer data)))) (pop-to-buffer (xmtn-propagate-data-conflicts-buffer data))))
(defun xmtn-propagate-resolve-conflictsp () (defun xmtn-propagate-resolve-conflictsp ()
@ -230,6 +270,12 @@ The elements must all be of class xmtn-propagate-data.")
(let* ((elem (ewoc-locate xmtn-propagate-ewoc)) (let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem))) (data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data) (xmtn-propagate-need-refresh elem data)
;; can't create log-edit buffer with both conflicts and status
;; buffer open, and we'll be killing this as part of the refresh
;; anyway.
(xmtn-kill-conflicts-buffer data)
(setf (xmtn-propagate-data-to-local-changes data) 'ok) (setf (xmtn-propagate-data-to-local-changes data) 'ok)
(xmtn-status (xmtn-propagate-to-work data)))) (xmtn-status (xmtn-propagate-to-work data))))
@ -246,7 +292,7 @@ The elements must all be of class xmtn-propagate-data.")
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(member (xmtn-propagate-data-to-local-changes data) (member (xmtn-propagate-data-to-local-changes data)
'(need-scan need-status))))) '(need-scan need-commit)))))
(defun xmtn-propagate-status-from () (defun xmtn-propagate-status-from ()
"Run xmtn-status on current `from' workspace." "Run xmtn-status on current `from' workspace."
@ -270,7 +316,7 @@ The elements must all be of class xmtn-propagate-data.")
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(member (xmtn-propagate-data-from-local-changes data) (member (xmtn-propagate-data-from-local-changes data)
'(need-scan need-status))))) '(need-scan need-commit)))))
(defun xmtn-propagate-missing-to () (defun xmtn-propagate-missing-to ()
"Run xmtn-missing on current `to' workspace." "Run xmtn-missing on current `to' workspace."
@ -284,7 +330,6 @@ The elements must all be of class xmtn-propagate-data.")
"Non-nil if xmtn-missing is appropriate for current `to' workspace." "Non-nil if xmtn-missing is appropriate for current `to' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-update (xmtn-propagate-data-to-heads data))))) (eq 'need-update (xmtn-propagate-data-to-heads data)))))
(defun xmtn-propagate-missing-from () (defun xmtn-propagate-missing-from ()
@ -299,7 +344,6 @@ The elements must all be of class xmtn-propagate-data.")
"Non-nil if xmtn-missing is appropriate for current `from' workspace." "Non-nil if xmtn-missing is appropriate for current `from' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-update (xmtn-propagate-data-from-heads data))))) (eq 'need-update (xmtn-propagate-data-from-heads data)))))
(defun xmtn-propagate-heads-to () (defun xmtn-propagate-heads-to ()
@ -315,7 +359,6 @@ The elements must all be of class xmtn-propagate-data.")
"Non-nil if xmtn-heads is appropriate for current `to' workspace." "Non-nil if xmtn-heads is appropriate for current `to' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-merge (xmtn-propagate-data-to-heads data))))) (eq 'need-merge (xmtn-propagate-data-to-heads data)))))
(defun xmtn-propagate-heads-from () (defun xmtn-propagate-heads-from ()
@ -331,7 +374,6 @@ The elements must all be of class xmtn-propagate-data.")
"Non-nil if xmtn-heads is appropriate for current `from' workspace." "Non-nil if xmtn-heads is appropriate for current `from' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data)) (and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-merge (xmtn-propagate-data-from-heads data))))) (eq 'need-merge (xmtn-propagate-data-from-heads data)))))
(defvar xmtn-propagate-actions-map (defvar xmtn-propagate-actions-map
@ -342,37 +384,40 @@ 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 [?a] '(menu-item "a) update" (define-key map [?b] '(menu-item "b) propagate"
xmtn-propagate-update
:visible (xmtn-propagate-updatep)))
(define-key map [?9] '(menu-item "9) propagate"
xmtn-propagate-propagate xmtn-propagate-propagate
:visible (xmtn-propagate-propagatep))) :visible (xmtn-propagate-propagatep)))
(define-key map [?8] '(menu-item "8) resolve conflicts" (define-key map [?a] '(menu-item "a) resolve conflicts"
xmtn-propagate-resolve-conflicts xmtn-propagate-resolve-conflicts
:visible (xmtn-propagate-resolve-conflictsp))) :visible (xmtn-propagate-resolve-conflictsp)))
(define-key map [?7] '(menu-item "7) ignore local changes to" (define-key map [?9] '(menu-item (concat "9) ignore local changes " (xmtn-propagate-to-name))
xmtn-propagate-status-to-ok xmtn-propagate-status-to-ok
:visible (xmtn-propagate-status-top))) :visible (xmtn-propagate-status-top)))
(define-key map [?6] '(menu-item "6) ignore local changes from" (define-key map [?8] '(menu-item (concat "8) ignore local changes " (xmtn-propagate-from-name))
xmtn-propagate-status-from-ok xmtn-propagate-status-from-ok
:visible (xmtn-propagate-status-fromp))) :visible (xmtn-propagate-status-fromp)))
(define-key map [?5] '(menu-item "5) status to" (define-key map [?7] '(menu-item (concat "7) dvc-missing " (xmtn-propagate-to-name))
xmtn-propagate-status-to
:visible (xmtn-propagate-status-top)))
(define-key map [?4] '(menu-item "4) status from"
xmtn-propagate-status-from
:visible (xmtn-propagate-status-fromp)))
(define-key map [?3] '(menu-item "3) dvc-missing to"
xmtn-propagate-missing-to xmtn-propagate-missing-to
:visible (xmtn-propagate-missing-top))) :visible (xmtn-propagate-missing-top)))
(define-key map [?2] '(menu-item "2) dvc-missing from" (define-key map [?6] '(menu-item (concat "6) dvc-missing " (xmtn-propagate-from-name))
xmtn-propagate-missing-from xmtn-propagate-missing-from
:visible (xmtn-propagate-missing-fromp))) :visible (xmtn-propagate-missing-fromp)))
(define-key map [?1] '(menu-item "1) xmtn-heads to" (define-key map [?5] '(menu-item (concat "5) update " (xmtn-propagate-to-name))
xmtn-propagate-update-to
:visible (xmtn-propagate-missing-top)))
(define-key map [?4] '(menu-item (concat "4) update " (xmtn-propagate-from-name))
xmtn-propagate-update-from
:visible (xmtn-propagate-missing-fromp)))
(define-key map [?3] '(menu-item (concat "3) commit " (xmtn-propagate-to-name))
xmtn-propagate-status-to
:visible (xmtn-propagate-status-top)))
(define-key map [?2] '(menu-item (concat "2) commit " (xmtn-propagate-from-name))
xmtn-propagate-status-from
:visible (xmtn-propagate-status-fromp)))
(define-key map [?1] '(menu-item (concat "1) xmtn-heads " (xmtn-propagate-to-name))
xmtn-propagate-heads-to xmtn-propagate-heads-to
:visible (xmtn-propagate-heads-top))) :visible (xmtn-propagate-heads-top)))
(define-key map [?0] '(menu-item "0) xmtn-heads from" (define-key map [?0] '(menu-item (concat "0) xmtn-heads " (xmtn-propagate-from-name))
xmtn-propagate-heads-from xmtn-propagate-heads-from
:visible (xmtn-propagate-heads-fromp))) :visible (xmtn-propagate-heads-fromp)))
map) map)
@ -395,7 +440,6 @@ The elements must all be of class xmtn-propagate-data.")
"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)
(setq buffer-read-only nil) (setq buffer-read-only nil)
(setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
;; don't do normal clean up stuff ;; don't do normal clean up stuff
(set (make-local-variable 'before-save-hook) nil) (set (make-local-variable 'before-save-hook) nil)
@ -404,12 +448,15 @@ The elements must all be of class xmtn-propagate-data.")
(dvc-install-buffer-menu) (dvc-install-buffer-menu)
(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)
(xmtn-propagate-refresh)
(xmtn-propagate-next nil t))
(defun xmtn-propagate-local-changes (work) (defun xmtn-propagate-local-changes (work)
"Value for xmtn-propagate-data-local-changes for WORK." "Value for xmtn-propagate-data-local-changes for WORK."
(message "checking %s for local changes" work) (message "checking %s for local changes" work)
(let ((default-directory work)) (let ((default-directory work)
result)
(dvc-run-dvc-sync (dvc-run-dvc-sync
'xmtn 'xmtn
@ -424,11 +471,28 @@ The elements must all be of class xmtn-propagate-data.")
(set-buffer output) (set-buffer output)
(goto-char (point-min)) (goto-char (point-min))
(if (search-forward "patch" (point-max) t) (if (search-forward "patch" (point-max) t)
'need-status (setq result 'need-commit)
'ok)) (setq result 'ok)))
:error (lambda (output error status arguments)
(pop-to-buffer error)))
(if (eq result 'ok)
;; check for unknown
(dvc-run-dvc-sync
'xmtn
(list "ls" "unknown")
:finished (lambda (output error status arguments)
(message "") ; clear minibuffer
(set-buffer output)
(if (not (= (point-min) (point-max)))
(setq result 'need-commit)
(setq result 'ok)))
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
(pop-to-buffer error)))) (pop-to-buffer error))))
result)
) )
(defun xmtn-propagate-needed (data) (defun xmtn-propagate-needed (data)
@ -438,7 +502,11 @@ The elements must all be of class xmtn-propagate-data.")
(from-head-rev (xmtn-propagate-data-from-head-rev data)) (from-head-rev (xmtn-propagate-data-from-head-rev data))
(to-head-rev (xmtn-propagate-data-to-head-rev data))) (to-head-rev (xmtn-propagate-data-to-head-rev data)))
;; If from has no descendants, then: (if (or (not from-head-rev)
(not to-head-rev))
;; multiple heads; can't propagate
(setq result nil)
;; 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
;; ;;
@ -455,33 +523,37 @@ The elements must all be of class xmtn-propagate-data.")
(progn (progn
(setq result nil) (setq result nil)
(setq done t))) (setq done t)))
(setq descendents (cdr descendents)))))) (setq descendents (cdr descendents)))))))
result result
)) ))
(defun xmtn-propagate-conflicts-buffer (from-work from-head-rev to-work to-head-rev) (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 ((conflicts-buffer (dvc-get-buffer 'xmtn 'conflicts to-work))) (let ((from-work (xmtn-propagate-from-work data))
(from-head-rev (xmtn-propagate-data-from-head-rev data))
(to-work (xmtn-propagate-to-work data))
(to-head-rev (xmtn-propagate-data-to-head-rev data)))
(or conflicts-buffer (or (dvc-get-buffer 'xmtn 'conflicts to-work)
(let ((default-directory to-work)) (let ((default-directory to-work))
(if (not (file-exists-p "_MTN/conflicts")) (if (not (file-exists-p "_MTN/conflicts"))
(progn (progn
;; create conflicts file ;; create conflicts file
(xmtn-conflicts-save-opts from-work to-work) (xmtn-conflicts-save-opts
from-work
to-work
(xmtn-propagate-data-from-branch data)
(xmtn-propagate-data-to-branch data))
(dvc-run-dvc-sync (dvc-run-dvc-sync
'xmtn 'xmtn
(list "conflicts" "store" from-head-rev to-head-rev) (list "conflicts" "store" from-head-rev to-head-rev)
:finished (lambda (output error status arguments)
(xmtn-dvc-log-clean)
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
(xmtn-dvc-log-clean) (pop-to-buffer error)))))
(pop-to-buffer error))))))
;; create conflicts buffer ;; create conflicts buffer
(save-excursion (save-excursion
(let ((dvc-switch-to-buffer-first nil)) (let ((dvc-switch-to-buffer-first nil))
(xmtn-conflicts-review default-directory) (xmtn-conflicts-review to-work)
(current-buffer))))))) (current-buffer)))))))
(defun xmtn-propagate-conflicts (data) (defun xmtn-propagate-conflicts (data)
@ -497,17 +569,12 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-conflicts-update-counts)) (xmtn-conflicts-update-counts))
;; recreate conflicts ;; recreate conflicts
(if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) (xmtn-kill-conflicts-buffer data)
(kill-buffer (xmtn-propagate-data-conflicts-buffer data)))
(xmtn-conflicts-clean (xmtn-propagate-to-work data)) (xmtn-conflicts-clean (xmtn-propagate-to-work data))
(setf (xmtn-propagate-data-conflicts-buffer data) (setf (xmtn-propagate-data-conflicts-buffer data)
(xmtn-propagate-conflicts-buffer (xmtn-propagate-conflicts-buffer data))
(xmtn-propagate-from-work data)
(xmtn-propagate-data-from-head-rev data)
(xmtn-propagate-to-work data)
(xmtn-propagate-data-to-head-rev data)))
) )
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
@ -517,12 +584,19 @@ The elements must all be of class xmtn-propagate-data.")
'ok) 'ok)
'need-resolve)))) 'need-resolve))))
(defun xmtn-propagate-refresh-one (data) (defun xmtn-propagate-refresh-one (data refresh-local-changes)
"Refresh DATA." "Refresh DATA."
(let ((from-work (xmtn-propagate-from-work data)) (let ((from-work (xmtn-propagate-from-work data))
(to-work (xmtn-propagate-to-work data))) (to-work (xmtn-propagate-to-work data)))
(let ((heads (xmtn--heads from-work nil)) (dvc-trace "xmtn-propagate-refresh-one: %s" from-work)
(if refresh-local-changes
(progn
(setf (xmtn-propagate-data-from-local-changes data) 'need-scan)
(setf (xmtn-propagate-data-to-local-changes data) 'need-scan)))
(let ((heads (xmtn--heads from-work (xmtn-propagate-data-from-branch 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
@ -534,7 +608,7 @@ The elements must all be of class xmtn-propagate-data.")
(setf (xmtn-propagate-data-from-head-rev data) nil) (setf (xmtn-propagate-data-from-head-rev data) nil)
(setf (xmtn-propagate-data-from-heads data) 'need-merge)))) (setf (xmtn-propagate-data-from-heads data) 'need-merge))))
(let ((heads (xmtn--heads to-work nil)) (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
@ -549,23 +623,25 @@ The elements must all be of class xmtn-propagate-data.")
(setf (xmtn-propagate-data-propagate-needed data) (setf (xmtn-propagate-data-propagate-needed data)
(xmtn-propagate-needed data)) (xmtn-propagate-needed data))
(if (xmtn-propagate-data-propagate-needed data) (if (or refresh-local-changes
(xmtn-propagate-data-propagate-needed data))
;; these checks are slow, so don't do them if they probably are not needed. ;; these checks are slow, so don't do them if they probably are not needed.
(progn (progn
(ecase (xmtn-propagate-data-from-local-changes data) (ecase (xmtn-propagate-data-from-local-changes data)
((need-scan need-status) ((need-scan need-commit)
(setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work))) (setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work)))
(ok nil)) (ok nil))
(ecase (xmtn-propagate-data-to-local-changes data) (ecase (xmtn-propagate-data-to-local-changes data)
((need-scan need-status) ((need-scan need-commit)
(setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work))) (setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work)))
(ok nil)) (ok nil))))
(if (xmtn-propagate-data-propagate-needed data)
;; can't compute conflicts if propagate not needed
(setf (xmtn-propagate-data-conflicts data) (setf (xmtn-propagate-data-conflicts data)
(xmtn-propagate-conflicts data))) (xmtn-propagate-conflicts data))
;; propagate not needed
(setf (xmtn-propagate-data-conflicts data) 'need-scan)) (setf (xmtn-propagate-data-conflicts data) 'need-scan))
(setf (xmtn-propagate-data-need-refresh data) nil)) (setf (xmtn-propagate-data-need-refresh data) nil))
@ -574,35 +650,53 @@ The elements must all be of class xmtn-propagate-data.")
t) t)
(defun xmtn-propagate-refresh () (defun xmtn-propagate-refresh ()
"Refresh status of each ewoc element." "Refresh status of each ewoc element. With prefix arg, reset local changes status to `unknown'."
(interactive) (interactive)
(ewoc-map 'xmtn-propagate-refresh-one xmtn-propagate-ewoc) (ewoc-map 'xmtn-propagate-refresh-one xmtn-propagate-ewoc current-prefix-arg)
;; leaves point at (point-min)
(xmtn-propagate-next t)
(message "done")) (message "done"))
(defun xmtn--filter-non-dir (dir) (defun xmtn-propagate-make-data (from-workspace to-workspace from-name to-name)
"Return list of all directories in DIR, excluding '.', '..'." "FROM-WORKSPACE, TO-WORKSPACE are relative names"
(let ((default-directory dir) (let* ((from-work (concat xmtn-propagate-from-root from-workspace))
(subdirs (directory-files dir))) ;; cached sessions not working (yet)
(setq subdirs ;;(from-session (xmtn-automate-cache-session from-work))
(mapcar (lambda (filename) (to-work (concat xmtn-propagate-to-root to-workspace))
(if (and (file-directory-p filename) ;;(to-session (xmtn-automate-cache-session to-work))
(not (string= "." filename)) )
(not (string= ".." filename)))
filename)) (ewoc-enter-last
subdirs)) xmtn-propagate-ewoc
(delq nil subdirs))) (make-xmtn-propagate-data
:from-work from-workspace
:to-work to-workspace
:from-name from-name
:to-name to-name
:from-branch (xmtn--tree-default-branch from-work)
:to-branch (xmtn--tree-default-branch to-work)
:from-session nil ;; from-session
:to-session nil ;; to-session
:need-refresh t))))
;;;###autoload ;;;###autoload
(defun xmtn-propagate-multiple (from-dir to-dir) (defun xmtn-propagate-multiple (from-dir to-dir &optional workspaces)
"Show all actions needed to propagate all projects under FROM-DIR to TO-DIR." "Show all actions needed to propagate projects under FROM-DIR
to TO-DIR. WORKSPACES (default nil) is a list of workspaces
common to from-dir and to-dir; if nil, the directories are
scanned and all common ones found are used."
(interactive "DPropagate all from (root directory): \nDto (root directory): ") (interactive "DPropagate all from (root directory): \nDto (root directory): ")
(let ((from-workspaces (xmtn--filter-non-dir from-dir)) (setq from-dir (substitute-in-file-name from-dir))
(to-workspaces (xmtn--filter-non-dir to-dir))) (setq to-dir (substitute-in-file-name to-dir))
(let ((from-workspaces (or workspaces
(xmtn--filter-non-dir from-dir)))
(to-workspaces (or workspaces
(xmtn--filter-non-dir to-dir))))
(pop-to-buffer (get-buffer-create "*xmtn-propagate*")) (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
(xmtn-propagate-mode)
(setq xmtn-propagate-from-root (file-name-as-directory from-dir)) (setq xmtn-propagate-from-root (file-name-as-directory from-dir))
(setq xmtn-propagate-to-root (file-name-as-directory to-dir)) (setq xmtn-propagate-to-root (file-name-as-directory to-dir))
(setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf (ewoc-set-hf
xmtn-propagate-ewoc xmtn-propagate-ewoc
@ -613,24 +707,27 @@ The elements must all be of class xmtn-propagate-data.")
"") "")
(dolist (workspace from-workspaces) (dolist (workspace from-workspaces)
(if (member workspace to-workspaces) (if (member workspace to-workspaces)
(ewoc-enter-last xmtn-propagate-ewoc (xmtn-propagate-make-data
(make-xmtn-propagate-data workspace
:to-work workspace workspace
:from-work workspace (file-name-nondirectory (directory-file-name xmtn-propagate-from-root))
:need-refresh t)))) (file-name-nondirectory (directory-file-name xmtn-propagate-to-root)))))
(redisplay)
(xmtn-propagate-refresh) (xmtn-propagate-mode)))
(xmtn-propagate-next)))
;;;###autoload ;;;###autoload
(defun xmtn-propagate-one (from-work to-work) (defun xmtn-propagate-one (from-work to-work)
"Show all actions needed to propagate FROM-WORK to TO-WORK." "Show all actions needed to propagate FROM-WORK to TO-WORK."
(interactive "DPropagate all from (workspace): \nDto (workspace): ") (interactive "DPropagate all from (workspace): \nDto (workspace): ")
(setq from-work (substitute-in-file-name from-work))
(setq to-work (substitute-in-file-name to-work))
(let ((default-directory to-work)
(from-session (xmtn-automate-cache-session from-work))
(to-session (xmtn-automate-cache-session to-work)))
(pop-to-buffer (get-buffer-create "*xmtn-propagate*")) (pop-to-buffer (get-buffer-create "*xmtn-propagate*"))
(xmtn-propagate-mode)
(setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../"))) (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))
(setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../"))) (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
(setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf (ewoc-set-hf
xmtn-propagate-ewoc xmtn-propagate-ewoc
@ -639,14 +736,12 @@ The elements must all be of class xmtn-propagate-data.")
(format " To root : %s\n" xmtn-propagate-to-root) (format " To root : %s\n" xmtn-propagate-to-root)
) )
"") "")
(ewoc-enter-last xmtn-propagate-ewoc (xmtn-propagate-make-data
(make-xmtn-propagate-data (file-name-nondirectory (directory-file-name from-work))
:from-work (file-name-nondirectory from-work) (file-name-nondirectory (directory-file-name to-work))
:to-work (file-name-nondirectory to-work) (file-name-nondirectory (directory-file-name from-work))
:need-refresh t)) (file-name-nondirectory (directory-file-name to-work)))
(xmtn-propagate-mode)))
(xmtn-propagate-refresh)
(xmtn-propagate-next))
(provide 'xmtn-propagate) (provide 'xmtn-propagate)

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

@ -349,30 +349,47 @@ arg; root. Result is of the form:
"If point is on a revision that has two parents, show conflicts "If point is on a revision that has two parents, show conflicts
from the merge." from the merge."
;; IMPROVEME: We just use the xmtn conflicts machinery for now. It ;; IMPROVEME: We just use the xmtn conflicts machinery for now. It
;; would be better if we had a read-only version of it. And a way to ;; would be better if we had a read-only version of it.
;; compare to the actual result.
(interactive) (interactive)
(let ((changelog (car (xmtn--revlist-entry-changelogs (dvc-revlist-entry-patch-struct (dvc-revlist-current-patch))))) (let ((changelog (car (xmtn--revlist-entry-changelogs (dvc-revlist-entry-patch-struct (dvc-revlist-current-patch)))))
left-start left-end left-rev right-start right-end right-rev) start end left-branch left-rev right-branch right-rev)
;; string-match does _not_ set up match-strings properly, so we do this instead ;; string-match does _not_ set up match-strings properly, so we do this instead
(cond (cond
((string= (substring changelog 0 9) "propagate") ((string= (substring changelog 0 9) "propagate")
(setq left-start (+ 6 (string-match "(head" changelog))) (setq start (+ 1 (string-match "'" changelog)))
(setq left-end (string-match ")" changelog left-start)) (setq end (string-match "'" changelog start))
(setq right-start (+ 6 (string-match "(head .*)" changelog left-start))) (setq left-branch (substring changelog start end))
(setq right-end (string-match ")" changelog right-start)))
(setq start (+ 6 (string-match "(head" changelog end)))
(setq end (string-match ")" changelog start))
(setq left-rev (substring changelog start end))
(setq start (+ 1 (string-match "'" changelog end)))
(setq end (string-match "'" changelog start))
(setq right-branch (substring changelog start end))
(setq start (+ 6 (string-match "(head .*)" changelog end)))
(setq end (string-match ")" changelog start))
(setq right-rev (substring changelog start end)))
((string= (substring changelog 0 5) "merge") ((string= (substring changelog 0 5) "merge")
(setq left-start (+ 4 (string-match "of" changelog))) (setq start (+ 4 (string-match "of" changelog)))
(setq left-end (string-match "'" changelog left-start)) (setq end (string-match "'" changelog start))
(setq right-start (+ 5 (string-match "and" changelog left-start))) (setq left-rev (substring changelog start (1- end)))
(setq right-end (string-match "'" changelog right-start)))
(setq start (+ 5 (string-match "and" changelog start)))
(setq end (string-match "'" changelog start))
(setq right-rev (substring changelog start (1- end))))
(t (t
(error "not on a two parent revision"))) (error "not on a two parent revision")))
(setq left-rev (substring changelog left-start (1- left-end))) (xmtn-conflicts-save-opts
(setq right-rev (substring changelog right-start (1- right-end))) (read-file-name "left work: ")
(read-file-name "right work: ")
left-branch
right-branch)
(dvc-run-dvc-async (dvc-run-dvc-async
'xmtn 'xmtn
@ -380,11 +397,11 @@ from the merge."
:finished (lambda (output error status arguments) :finished (lambda (output error status arguments)
(let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory))) (let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory)))
(pop-to-buffer conflicts-buffer) (pop-to-buffer conflicts-buffer)
(xmtn-conflicts-load-opts)
(set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file)) (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file))
(insert-file-contents "_MTN/conflicts" t))) (insert-file-contents "_MTN/conflicts" t)))
:error (lambda (output error status arguments) :error (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(pop-to-buffer error))))) (pop-to-buffer error)))))
;;;###autoload ;;;###autoload
@ -599,7 +616,7 @@ To be invoked from an xmtn revlist buffer."
(let* ((root (dvc-tree-root)) (let* ((root (dvc-tree-root))
(entry (dvc-revlist-current-patch-struct)) (entry (dvc-revlist-current-patch-struct))
(target-hash-id (xmtn--revlist-entry-revision-hash-id entry))) (target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))
(xmtn--update root target-hash-id))) (xmtn--update root target-hash-id nil nil)))
;; Being able to conveniently disapprove whole batches of revisions ;; Being able to conveniently disapprove whole batches of revisions
;; is going to be a lot of fun. ;; is going to be a lot of fun.

6
dvc/texinfo/Makefile
View File

@ -8,13 +8,13 @@ PACKAGE_VERSION = 0
# location of required programms # location of required programms
RM = @RM@ RM = @RM@
MKDIR_P = /bin/mkdir -p MKDIR_P = /bin/mkdir -p
INSTALL = /bin/install -c INSTALL = /c/Tools/gnuwin32/bin/ginstall -c
INSTALL_DATA = ${INSTALL} -m 644 INSTALL_DATA = ${INSTALL} -m 644
MAKEINFO = makeinfo MAKEINFO = makeinfo
TEXI2DVI = texi2dvi TEXI2DVI = texi2dvi
# Other settings # Other settings
datarootdir = ${prefix}/share datarootdir = /c/kt/.emacs.d
prefix = /usr/local prefix = /usr/local
info_dir = ${datarootdir}/info info_dir = ${datarootdir}/info
@ -33,7 +33,7 @@ Makefile: $(srcdir)/Makefile.in ../config.status
ii = install-info ii = install-info
install: uninstall info install: uninstall info
$(MKDIR_P) -m 0755 $(info_dir) echo $(MKDIR_P) -m 0755 $(info_dir)
@for i in dvc.info* ; do \ @for i in dvc.info* ; do \
echo Installing $$i ; \ echo Installing $$i ; \
$(INSTALL_DATA) $$i $(info_dir) ; \ $(INSTALL_DATA) $$i $(info_dir) ; \