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
RM = @RM@
prefix = /usr/local
datarootdir= ${prefix}/share
datarootdir= /c/kt/.emacs.d
info_dir = ${datarootdir}/info
srcdir = .
lispdir= /c/kt/.emacs.d/lisp/dvc

4
dvc/lisp/Makefile
View File

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

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

@ -827,7 +827,7 @@ workspace version)."
(diff-buffer (dvc-prepare-changes-buffer
base
modified
'file-diff file 'bzr))
'file-diff file dvc))
(base-buffer
(dvc-revision-get-file-in-buffer file base))
(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))
((deleted rename-source rename-target)
;; typically nothing to do; just need commit
(ding)
(dvc-fileinfo-next))
(dvc-status-ediff))
(missing
;; File is in database, but not in workspace

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

@ -257,6 +257,21 @@
(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)
&body body)
"Call BODY, after ensuring an automate session for ROOT-FORM is active."
@ -276,7 +291,7 @@
(thunk (gensym)))
`(let* ((,root (file-name-as-directory ,root-form))
(,key (file-truename ,root))
(,session (cdr (assoc ,key xmtn-automate--*sessions*)))
(,session (xmtn-automate-get-cached-session ,key))
(,thunk (lambda ()
(let ((,session-var ,session))
,@body))))
@ -286,6 +301,10 @@
(progn
(setq ,session (xmtn-automate--make-session ,root ,key))
(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*)))
(funcall ,thunk)))
(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)
(defun xmtn-automate--make-session (root key)
(dvc-trace "new session %s" key)
(let* ((name (format "xmtn automate session for %s" key)))
(let ((session (xmtn-automate--%make-raw-session)))
(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
;; path'. Don't warn if buffer hasn't been deleted; that
;; obscures the real error message
;; FIXME: if that is the reason, this assert fails. Disable assertions for now, fix later
(xmtn--assert-optional (null (xmtn-automate--session-buffer session))))
nil)
((ecase (process-status process)
(run nil)
(exit t)
@ -576,7 +595,7 @@ Signals an error if output contains zero lines or more than one line."
(exit nil)
(signal nil))
(accept-process-output process))
;;(dvc-trace "Process in root %s terminated" root)
(dvc-trace "Process in root %s terminated" root)
))
(xmtn-automate--initialize-session
session

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

@ -59,11 +59,22 @@ A list of strings.")
(save-match-data
(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
"Effective at macroexpansion time.")
;; (setq xmtn--*enable-assertions* t)
(defmacro xmtn--assert-for-effect (form &rest more-assert-args)
(if xmtn--*enable-assertions*
`(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)
(if (fboundp 'set-process-query-on-exit-flag)
;; emacs 22.2 and greater
`(set-process-query-on-exit-flag ,process ,value)
`(progn
;; emacs 22.1
(process-kill-without-query ,process ,value)
,value)))

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

@ -250,8 +250,8 @@ header."
(setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count))
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal)))
((string= "resolved_user_left" symbol)
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_left_user (cadar value))))
((string= "resolved_user" symbol)
(setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user (cadar value))))
(t
(error "found %s" symbol)))))))
@ -495,7 +495,8 @@ header."
"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 "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)
@ -522,7 +523,7 @@ header."
(insert "resolved_keep_left \n"))
(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)
@ -852,19 +853,25 @@ header."
(setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_drop))
(ewoc-invalidate xmtn-conflicts-ewoc elem)))
(defun xmtn-conflicts-resolve-user (side)
"Resolve the current conflict by user_SIDE."
(defun xmtn-conflicts-resolve-user (resolve-side default-side)
"Resolve the current conflict by user_RESOLVE-SIDE. Default to file from DEFAULT-SIDE."
(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))
(conflict (ewoc-data elem))
(result-file (read-file-name "resolution file: " "./" nil t
(xmtn-conflicts-conflict-right_name conflict))))
(ecase side
('left
(result-file
(expand-file-name
(read-file-name "resolution file: "
(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)))
('right
(right
(setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user result-file)))
)
(ewoc-invalidate xmtn-conflicts-ewoc elem)))
@ -987,32 +994,42 @@ header."
;; Don't need 'left' or 'right' in menu, since only one is
;; 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
:visible (xmtn-conflicts-resolve-drop_rightp)))
(define-key map [?8] '(menu-item "8) rename"
(define-key map [?a] '(menu-item "a) rename"
(lambda ()
(interactive)
(xmtn-conflicts-resolve-rename 'right))
:visible (xmtn-conflicts-resolve-rename_rightp)))
(define-key map [?7] '(menu-item "7) file"
(define-key map [?9] '(menu-item "9) right file"
(lambda ()
(interactive)
(xmtn-conflicts-resolve-user 'right))
(xmtn-conflicts-resolve-user 'right 'right))
: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
:visible (xmtn-conflicts-resolve-keep_rightp)))
(define-key map [?5] '(menu-item "5) ediff"
(define-key map [?6] '(menu-item "6) ediff"
(lambda ()
(interactive)
(xmtn-conflicts-resolve-ediff 'right))
:visible (xmtn-conflicts-resolve-user_rightp)))
(define-key map [?4] '(menu-item "4) file"
(define-key map [?5] '(menu-item "5) right file"
(lambda ()
(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)))
(define-key map [?3] '(menu-item "3) drop"
xmtn-conflicts-resolve-drop_left
@ -1058,17 +1075,17 @@ non-nil, show log-edit buffer in other frame."
(insert ": ")
))
(defun xmtn-conflicts-do-propagate ()
(defun xmtn-conflicts-do-propagate (&optional cached-branch)
"Perform propagate on revisions in current conflict buffer."
(interactive)
(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 ()
"Perform merge on revisions in current conflict buffer."
(interactive)
(save-some-buffers t); log buffer
(xmtn-dvc-merge))
(xmtn-dvc-merge-1 default-directory nil))
(defun xmtn-conflicts-ediff-resolution-ws ()
"Ediff current resolution file against workspace."
@ -1105,6 +1122,7 @@ non-nil, show log-edit buffer in other frame."
"`xmtn-conflicts' menu"
`("Mtn-conflicts"
["Clear resolution" xmtn-conflicts-clear-resolution t]
["Ediff resolution to ws" xmtn-conflicts-ediff-resolution-ws t]
["Propagate" xmtn-conflicts-do-propagate t]
["Merge" xmtn-conflicts-do-merge 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")
(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
retrieval by `xmtn-conflicts-load-opts'."
(let ((xmtn-conflicts-left-work left-work)
(xmtn-conflicts-right-work right-work)
(xmtn-conflicts-left-branch (xmtn--tree-default-branch left-work))
(xmtn-conflicts-right-branch (xmtn--tree-default-branch right-work)))
(xmtn-conflicts-left-branch (or left-branch
(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
'xmtn-conflicts-left-branch
@ -1174,19 +1194,17 @@ to right. Stores conflict file in RIGHT-WORK/_MTN."
'xmtn
(list "conflicts" "store" left-rev right-rev)
:finished (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(xmtn-conflicts-review default-directory))
:error (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(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.
It must be merged, and should be at the head revision, and have no local changes."
(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)))
(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 right-work (dvc-read-project-tree-maybe "to (workspace directory): " right-work))
(xmtn-check-workspace-for-propagate left-work)
(xmtn-check-workspace-for-propagate right-work)
(let ((left-branch (xmtn--tree-default-branch left-work))
(right-branch (xmtn--tree-default-branch right-work)))
(xmtn-check-propagate-needed left-work right-work)
(xmtn-check-workspace-for-propagate left-work left-branch)
(xmtn-check-workspace-for-propagate right-work right-branch)
(message "computing conflicts")
(xmtn-check-propagate-needed left-work right-work)
(xmtn-conflicts-1 left-work
(car (xmtn--heads left-work nil))
(message "computing conflicts")
(xmtn-conflicts-1 left-work
(car (xmtn--heads left-work left-branch))
right-work
(car (xmtn--heads right-work nil))))
(car (xmtn--heads right-work right-branch)))))
;;;###autoload
(defun xmtn-conflicts-merge ()
@ -1304,6 +1325,8 @@ workspace."
(if (file-exists-p "_MTN/resolutions")
(dired-delete-file "_MTN/resolutions" 'always))
(message "conflicts cleaned")
))
(provide 'xmtn-conflicts)

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

@ -285,12 +285,6 @@ the file before saving."
(if (file-exists-p 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
(defun xmtn-dvc-log-edit-done ()
(let* ((root default-directory)
@ -351,11 +345,9 @@ the file before saving."
"--depth=0"
"--" normalized-files))))
:error (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(dvc-default-error-function output error
status arguments))
:killed (lambda (output error status arguments)
(xmtn-dvc-log-clean)
(dvc-default-killed-function 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
;; commit was successful. Let's not interfere with
;; 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
default-directory
"* Just committed! Please refresh buffer"
(xmtn--status-header
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
;; debugging message.
(message "%s... " progress-message))
@ -1224,22 +1221,25 @@ finished."
(check-type revision-hash-id xmtn--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 target-revision-hash-id xmtn--hash-id)
(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)))
(post-process
(lambda ()
(message "%s... done" progress-message)
(dvc-revert-some-buffers default-directory)
(dvc-diff-clear-buffers 'xmtn
default-directory
"* Just updated; please refresh buffer"
(xmtn--status-header
default-directory
(xmtn--get-base-revision-hash-id-or-null default-directory)))))
(if post-update-p
(progn
(dvc-revert-some-buffers default-directory)
(dvc-diff-clear-buffers 'xmtn
default-directory
"* Just updated; please refresh buffer"
(xmtn--status-header
default-directory
(xmtn--get-base-revision-hash-id-or-null default-directory)))))))
)
(message "%s..." progress-message)
@ -1248,28 +1248,32 @@ finished."
(funcall post-process))
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
;; 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)
(error "Tree %s is already based on target revision %s"
root target-revision-hash-id))
(dvc-save-some-buffers root)
(xmtn--do-update root target-revision-hash-id))
;; Don't throw an error; upper level might be doing other directories as well.
(if (and check-id-p
(equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id))
(progn
(unless no-ding (ding))
(message "Tree %s is already based on target revision %s"
root target-revision-hash-id))
(dvc-save-some-buffers root)
(xmtn--do-update root target-revision-hash-id check-id-p)))
;;;###autoload
(defun xmtn-dvc-update (&optional revision-id)
(defun xmtn-dvc-update (&optional revision-id no-ding)
(let ((root (dvc-tree-root)))
(xmtn-automate-with-session (nil root)
(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))
(heads (xmtn--heads root branch)))
(case (length heads)
(0 (assert nil))
(1
(xmtn--update root (first heads)))
(xmtn--update root (first heads) t no-ding))
(t
;; User can choose one head from a revlist, or merge them.
@ -1279,12 +1283,13 @@ finished."
branch (length heads))))))))
nil)
(defun xmtn-propagate-from (other)
(defun xmtn-propagate-from (other &optional cached-branch)
"Propagate from OTHER branch to local tree branch."
(interactive "MPropagate from branch: ")
(let*
((root (dvc-tree-root))
(local-branch (xmtn--tree-default-branch root))
(local-branch (or cached-branch
(xmtn--tree-default-branch root)))
(resolve-conflicts
(if (file-exists-p (concat root "/_MTN/conflicts"))
(progn
@ -1318,31 +1323,35 @@ finished."
(xmtn--refresh-status-header display-buffer)
(message "%s... done" msg)))))))
(defun xmtn-dvc-merge-1 (root refresh-status)
(lexical-let ((refresh-status refresh-status))
(xmtn-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
(defun xmtn-dvc-merge (&optional other)
(if other
(xmtn-propagate-from other)
;; else merge heads
(let* ((root (dvc-tree-root))
(resolve-conflicts
(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)))
(case (length heads)
(0 (assert nil))
(1
(message "already merged"))
(t
(xmtn--run-command-that-might-invoke-merger
root
(list "merge" resolve-conflicts (xmtn-dvc-log-message))
(lambda () (xmtn--refresh-status-header display-buffer))))))))))
(branch (xmtn--tree-default-branch root))
(heads (xmtn--heads root branch)))
(case (length heads)
(0 (assert nil))
(1
(message "already merged"))
(t
(xmtn-dvc-merge-1 root t)))))
nil)
;;;###autoload

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

@ -152,9 +152,27 @@ See file commentary for details."
,base-revision-hash-id
,(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)
(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)
resolved-id
(ecase (first resolved-id)
@ -170,7 +188,7 @@ See file commentary for details."
(check-type hash-id xmtn--hash-id)
(loop repeat num
;; 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)))))))
(defun xmtn--error-unless-revision-exists (root hash-id)
@ -216,31 +234,6 @@ must be a workspace."
)))))
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)
(let ((hash-id (xmtn-automate-simple-command-output-line
root `("get_base_revision_id"))))

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

@ -26,19 +26,35 @@
(eval-when-compile
;; these have functions we use
(require 'xmtn-base)
(require 'xmtn-conflicts))
(defvar xmtn-propagate-from-root ""
"Buffer-local variable holding `from' root directory.")
(make-variable-buffer-local 'xmtn-propagate-from-root)
(put 'xmtn-propagate-from-root 'permanent-local t)
(defvar xmtn-propagate-to-root ""
"Buffer-local variable holding `to' root directory.")
(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))
from-work ; directory name relative to xmtn-propagate-from-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
from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads
to-head-rev ;
@ -47,9 +63,9 @@
from-heads ; 'at-head | 'need-update | 'need-merge)
to-heads ;
(from-local-changes
'need-scan) ; 'need-scan | 'need-status | 'ok
'need-scan) ; 'need-scan | 'need-commit | 'ok
(to-local-changes
'need-scan) ; once these are changed from 'need-scan, no action changes it .
'need-scan) ;
(conflicts
'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'ok
)
@ -60,6 +76,14 @@
(defun xmtn-propagate-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)
(setf (xmtn-propagate-data-need-refresh data) t)
(ewoc-invalidate xmtn-propagate-ewoc elem))
@ -77,112 +101,127 @@
(if (xmtn-propagate-data-need-refresh data)
(insert (dvc-face-add " need refresh\n" 'dvc-conflict))
(ecase (xmtn-propagate-data-from-local-changes data)
(need-scan (insert " local changes unknown " (xmtn-propagate-data-from-name data) "\n"))
(need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-from-name data) "\n")
'dvc-header)))
(ok nil))
(ecase (xmtn-propagate-data-to-local-changes data)
(need-scan (insert " local changes unknown " (xmtn-propagate-data-to-name data) "\n"))
(need-commit
(insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-to-name data) "\n")
'dvc-header)))
(ok nil))
(ecase (xmtn-propagate-data-from-heads data)
(at-head nil)
(need-update
(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)
(at-head nil)
(need-update
(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)
(progn
(ecase (xmtn-propagate-data-from-local-changes data)
(need-scan (insert " from local changes unknown\n"))
(need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header)))
(ok nil))
(ecase (xmtn-propagate-data-to-local-changes data)
(need-scan (insert " to local changes unknown\n"))
(need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header)))
(ok nil))
(if (and (eq 'at-head (xmtn-propagate-data-from-heads data))
(eq 'at-head (xmtn-propagate-data-to-heads data)))
(ecase (xmtn-propagate-data-conflicts data)
(need-scan
(insert "conflicts need scan\n"))
(need-resolve
(insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict)))
(need-review-resolve-internal
(insert (dvc-face-add " need review resolve internal\n" 'dvc-header))
(insert (dvc-face-add " need propagate\n" 'dvc-conflict)))
(ok
(insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
(ecase (xmtn-propagate-data-from-heads data)
(at-head nil)
(need-update (insert (dvc-face-add " need dvc-missing from\n" 'dvc-conflict)))
(need-merge (insert (dvc-face-add " need xmtn-heads from\n" 'dvc-conflict))))
(if (eq 'at-head (xmtn-propagate-data-to-heads data))
(insert " need clean\n"))
))
;; ewoc ought to do this, but it doesn't
(redisplay))
(ecase (xmtn-propagate-data-to-heads data)
(at-head nil)
(need-update (insert (dvc-face-add " need dvc-missing to\n" 'dvc-conflict)))
(need-merge (insert (dvc-face-add " need xmtn-heads to\n" 'dvc-conflict))))
(if (and (eq 'at-head (xmtn-propagate-data-from-heads data))
(eq 'at-head (xmtn-propagate-data-to-heads data)))
(ecase (xmtn-propagate-data-conflicts data)
(need-scan
(insert "conflicts need scan\n"))
(need-resolve
(insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict)))
(need-review-resolve-internal
(insert (dvc-face-add " need review resolve internal\n" 'dvc-header))
(insert (dvc-face-add " need propagate\n" 'dvc-conflict)))
(ok
(insert (dvc-face-add " need propagate\n" 'dvc-conflict)))))
)
;; propagate not needed
(ecase (xmtn-propagate-data-from-local-changes data)
(need-scan (insert " from local changes unknown\n"))
(need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header)))
(ok nil))
(ecase (xmtn-propagate-data-to-local-changes data)
(need-scan (insert " to local changes unknown\n"))
(need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header)))
(ok nil))
(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-kill-conflicts-buffer (data)
(if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
(let ((buffer (xmtn-propagate-data-conflicts-buffer data)))
(with-current-buffer buffer (save-buffer))
(kill-buffer buffer))))
(defun xmtn-propagate-clean ()
"Clean current workspace, delete from ewoc"
(interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(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))
(ewoc-delete xmtn-propagate-ewoc elem))))
(defun xmtn-propagate-cleanp ()
"Non-nil if clean is appropriate for current workspace."
(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))
(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 ()
(interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(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)))
(defun xmtn-propagate-refreshp ()
"Non-nil if refresh is appropriate for current workspace."
(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."
(interactive)
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
(data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data)
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(xmtn-dvc-update))
(xmtn-propagate-refresh-one data)
(xmtn--update (xmtn-propagate-to-work data)
(xmtn-propagate-data-to-head-rev data)
nil t)
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-updatep ()
"Non-nil if update is appropriate for current workspace."
(let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(not (xmtn-propagate-data-propagate-needed data))
(eq 'need-update (xmtn-propagate-data-to-heads data)))))
(defun xmtn-propagate-update-from ()
"Update current 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-rev data)
nil t)
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem)))
(defun xmtn-propagate-propagate ()
"Propagate current workspace."
@ -192,8 +231,8 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-propagate-need-refresh elem data)
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
(let ((xmtn-confirm-operation nil))
(xmtn-conflicts-do-propagate)))
(xmtn-propagate-refresh-one data)
(xmtn-conflicts-do-propagate (xmtn-propagate-data-to-branch data))))
(xmtn-propagate-refresh-one data nil)
(ewoc-invalidate xmtn-propagate-ewoc elem)))
(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))
(data (ewoc-data elem)))
(xmtn-propagate-need-refresh elem data)
(setf (xmtn-propagate-data-conflicts data) 'ok)
(pop-to-buffer (xmtn-propagate-data-conflicts-buffer data))))
(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))
(data (ewoc-data elem)))
(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)
(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))))
(and (not (xmtn-propagate-data-need-refresh data))
(member (xmtn-propagate-data-to-local-changes data)
'(need-scan need-status)))))
'(need-scan need-commit)))))
(defun xmtn-propagate-status-from ()
"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))))
(and (not (xmtn-propagate-data-need-refresh data))
(member (xmtn-propagate-data-from-local-changes data)
'(need-scan need-status)))))
'(need-scan need-commit)))))
(defun xmtn-propagate-missing-to ()
"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."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-update (xmtn-propagate-data-to-heads data)))))
(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."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-update (xmtn-propagate-data-from-heads data)))))
(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."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-merge (xmtn-propagate-data-to-heads data)))))
(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."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(xmtn-propagate-data-propagate-needed data)
(eq 'need-merge (xmtn-propagate-data-from-heads data)))))
(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"
xmtn-propagate-do-refresh-one
:visible (xmtn-propagate-refreshp)))
(define-key map [?a] '(menu-item "a) update"
xmtn-propagate-update
:visible (xmtn-propagate-updatep)))
(define-key map [?9] '(menu-item "9) propagate"
(define-key map [?b] '(menu-item "b) propagate"
xmtn-propagate-propagate
: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
: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
: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
:visible (xmtn-propagate-status-fromp)))
(define-key map [?5] '(menu-item "5) status to"
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"
(define-key map [?7] '(menu-item (concat "7) dvc-missing " (xmtn-propagate-to-name))
xmtn-propagate-missing-to
: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
: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
: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
:visible (xmtn-propagate-heads-fromp)))
map)
@ -395,7 +440,6 @@ The elements must all be of class xmtn-propagate-data.")
"Major mode to propagate multiple workspaces."
(setq dvc-buffer-current-active-dvc 'xmtn)
(setq buffer-read-only nil)
(setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer))
;; don't do normal clean up stuff
(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)
(setq buffer-read-only t)
(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)
"Value for xmtn-propagate-data-local-changes for WORK."
(message "checking %s for local changes" work)
(let ((default-directory work))
(let ((default-directory work)
result)
(dvc-run-dvc-sync
'xmtn
@ -424,11 +471,28 @@ The elements must all be of class xmtn-propagate-data.")
(set-buffer output)
(goto-char (point-min))
(if (search-forward "patch" (point-max) t)
'need-status
'ok))
(setq result 'need-commit)
(setq result 'ok)))
:error (lambda (output error status arguments)
(pop-to-buffer error))))
(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)
(pop-to-buffer error))))
result)
)
(defun xmtn-propagate-needed (data)
@ -438,50 +502,58 @@ The elements must all be of class xmtn-propagate-data.")
(from-head-rev (xmtn-propagate-data-from-head-rev data))
(to-head-rev (xmtn-propagate-data-to-head-rev data)))
;; If from has no descendants, then:
;; 1) to branched off earlier, and propagate is needed
;; 2) propagate was just done but required no changes; no propagate needed
;;
(if (string= from-head-rev to-head-rev)
;; case 2
(if (or (not from-head-rev)
(not to-head-rev))
;; multiple heads; can't propagate
(setq result nil)
(let ((descendents (xmtn-automate-simple-command-output-lines from-work (list "descendents" from-head-rev)))
done)
(if (not descendents)
;; case 1
(setq result t)
(while (and descendents (not done))
(if (string= to-head-rev (car descendents))
(progn
(setq result nil)
(setq done t)))
(setq descendents (cdr descendents))))))
;; 1) to branched off earlier, and propagate is needed
;; 2) propagate was just done but required no changes; no propagate needed
;;
(if (string= from-head-rev to-head-rev)
;; case 2
(setq result nil)
(let ((descendents (xmtn-automate-simple-command-output-lines from-work (list "descendents" from-head-rev)))
done)
(if (not descendents)
;; case 1
(setq result t)
(while (and descendents (not done))
(if (string= to-head-rev (car descendents))
(progn
(setq result nil)
(setq done t)))
(setq descendents (cdr descendents)))))))
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)."
(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))
(if (not (file-exists-p "_MTN/conflicts"))
(progn
;; 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
'xmtn
(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)
(xmtn-dvc-log-clean)
(pop-to-buffer error))))))
:error (lambda (output error status arguments)
(pop-to-buffer error)))))
;; create conflicts buffer
(save-excursion
(let ((dvc-switch-to-buffer-first nil))
(xmtn-conflicts-review default-directory)
(xmtn-conflicts-review to-work)
(current-buffer)))))))
(defun xmtn-propagate-conflicts (data)
@ -497,17 +569,12 @@ The elements must all be of class xmtn-propagate-data.")
(xmtn-conflicts-update-counts))
;; recreate conflicts
(if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
(kill-buffer (xmtn-propagate-data-conflicts-buffer data)))
(xmtn-kill-conflicts-buffer data)
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
(setf (xmtn-propagate-data-conflicts-buffer data)
(xmtn-propagate-conflicts-buffer
(xmtn-propagate-from-work data)
(xmtn-propagate-data-from-head-rev data)
(xmtn-propagate-to-work data)
(xmtn-propagate-data-to-head-rev data)))
(xmtn-propagate-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)
'need-resolve))))
(defun xmtn-propagate-refresh-one (data)
(defun xmtn-propagate-refresh-one (data refresh-local-changes)
"Refresh DATA."
(let ((from-work (xmtn-propagate-from-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)))
(case (length heads)
(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-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)))
(case (length heads)
(1
@ -549,23 +623,25 @@ The elements must all be of class xmtn-propagate-data.")
(setf (xmtn-propagate-data-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.
(progn
(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)))
(ok nil))
(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)))
(ok nil))
(ok nil))))
(setf (xmtn-propagate-data-conflicts data)
(xmtn-propagate-conflicts data)))
(if (xmtn-propagate-data-propagate-needed data)
;; can't compute conflicts if propagate not needed
(setf (xmtn-propagate-data-conflicts data)
(xmtn-propagate-conflicts data))
;; propagate not needed
(setf (xmtn-propagate-data-conflicts data) 'need-scan))
(setf (xmtn-propagate-data-need-refresh data) nil))
@ -574,35 +650,53 @@ The elements must all be of class xmtn-propagate-data.")
t)
(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)
(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"))
(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)))
(defun xmtn-propagate-make-data (from-workspace to-workspace from-name to-name)
"FROM-WORKSPACE, TO-WORKSPACE are relative names"
(let* ((from-work (concat xmtn-propagate-from-root from-workspace))
;; cached sessions not working (yet)
;;(from-session (xmtn-automate-cache-session from-work))
(to-work (concat xmtn-propagate-to-root to-workspace))
;;(to-session (xmtn-automate-cache-session to-work))
)
(ewoc-enter-last
xmtn-propagate-ewoc
(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
(defun xmtn-propagate-multiple (from-dir to-dir)
"Show all actions needed to propagate all projects under FROM-DIR to TO-DIR."
(defun xmtn-propagate-multiple (from-dir to-dir &optional workspaces)
"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): ")
(let ((from-workspaces (xmtn--filter-non-dir from-dir))
(to-workspaces (xmtn--filter-non-dir to-dir)))
(setq from-dir (substitute-in-file-name from-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*"))
(xmtn-propagate-mode)
(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-ewoc (ewoc-create 'xmtn-propagate-printer))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf
xmtn-propagate-ewoc
@ -613,40 +707,41 @@ The elements must all be of class xmtn-propagate-data.")
"")
(dolist (workspace from-workspaces)
(if (member workspace to-workspaces)
(ewoc-enter-last xmtn-propagate-ewoc
(make-xmtn-propagate-data
:to-work workspace
:from-work workspace
:need-refresh t))))
(xmtn-propagate-refresh)
(xmtn-propagate-next)))
(xmtn-propagate-make-data
workspace
workspace
(file-name-nondirectory (directory-file-name xmtn-propagate-from-root))
(file-name-nondirectory (directory-file-name xmtn-propagate-to-root)))))
(redisplay)
(xmtn-propagate-mode)))
;;;###autoload
(defun xmtn-propagate-one (from-work to-work)
"Show all actions needed to propagate FROM-WORK to TO-WORK."
(interactive "DPropagate all from (workspace): \nDto (workspace): ")
(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-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf
xmtn-propagate-ewoc
(concat
(format "From root : %s\n" xmtn-propagate-from-root)
(format " To root : %s\n" xmtn-propagate-to-root)
)
"")
(ewoc-enter-last xmtn-propagate-ewoc
(make-xmtn-propagate-data
:from-work (file-name-nondirectory from-work)
:to-work (file-name-nondirectory to-work)
:need-refresh t))
(xmtn-propagate-refresh)
(xmtn-propagate-next))
(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*"))
(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-ewoc (ewoc-create 'xmtn-propagate-printer))
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
(ewoc-set-hf
xmtn-propagate-ewoc
(concat
(format "From root : %s\n" xmtn-propagate-from-root)
(format " To root : %s\n" xmtn-propagate-to-root)
)
"")
(xmtn-propagate-make-data
(file-name-nondirectory (directory-file-name from-work))
(file-name-nondirectory (directory-file-name to-work))
(file-name-nondirectory (directory-file-name from-work))
(file-name-nondirectory (directory-file-name to-work)))
(xmtn-propagate-mode)))
(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
from the merge."
;; 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
;; compare to the actual result.
;; would be better if we had a read-only version of it.
(interactive)
(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
(cond
((string= (substring changelog 0 9) "propagate")
(setq left-start (+ 6 (string-match "(head" changelog)))
(setq left-end (string-match ")" changelog left-start))
(setq right-start (+ 6 (string-match "(head .*)" changelog left-start)))
(setq right-end (string-match ")" changelog right-start)))
(setq start (+ 1 (string-match "'" changelog)))
(setq end (string-match "'" changelog start))
(setq left-branch (substring changelog start end))
(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")
(setq left-start (+ 4 (string-match "of" changelog)))
(setq left-end (string-match "'" changelog left-start))
(setq right-start (+ 5 (string-match "and" changelog left-start)))
(setq right-end (string-match "'" changelog right-start)))
(setq start (+ 4 (string-match "of" changelog)))
(setq end (string-match "'" changelog start))
(setq left-rev (substring changelog start (1- end)))
(setq start (+ 5 (string-match "and" changelog start)))
(setq end (string-match "'" changelog start))
(setq right-rev (substring changelog start (1- end))))
(t
(error "not on a two parent revision")))
(setq left-rev (substring changelog left-start (1- left-end)))
(setq right-rev (substring changelog right-start (1- right-end)))
(xmtn-conflicts-save-opts
(read-file-name "left work: ")
(read-file-name "right work: ")
left-branch
right-branch)
(dvc-run-dvc-async
'xmtn
@ -380,11 +397,11 @@ from the merge."
: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)
(xmtn-dvc-log-clean)
(pop-to-buffer error)))))
;;;###autoload
@ -599,7 +616,7 @@ To be invoked from an xmtn revlist buffer."
(let* ((root (dvc-tree-root))
(entry (dvc-revlist-current-patch-struct))
(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
;; 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
RM = @RM@
MKDIR_P = /bin/mkdir -p
INSTALL = /bin/install -c
INSTALL = /c/Tools/gnuwin32/bin/ginstall -c
INSTALL_DATA = ${INSTALL} -m 644
MAKEINFO = makeinfo
TEXI2DVI = texi2dvi
# Other settings
datarootdir = ${prefix}/share
datarootdir = /c/kt/.emacs.d
prefix = /usr/local
info_dir = ${datarootdir}/info
@ -33,7 +33,7 @@ Makefile: $(srcdir)/Makefile.in ../config.status
ii = install-info
install: uninstall info
$(MKDIR_P) -m 0755 $(info_dir)
echo $(MKDIR_P) -m 0755 $(info_dir)
@for i in dvc.info* ; do \
echo Installing $$i ; \
$(INSTALL_DATA) $$i $(info_dir) ; \