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

update dvc

Browse Source
This commit is contained in:
Kai Tetzlaff 2011-01-04 12:44:19 +01:00
parent 0dd7dfadf8
commit 8af13eb792
10 changed files with 448 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -151,7 +151,7 @@ BUFFER should be the buffer to add."
(current-buffer)))
(defun dvc-get-buffer-create (dvc type &optional path)
"Get a buffer of type TYPE for the path PATH.
"Get a buffer of type TYPE for the path PATH (default `default-directory').
Maybe reuse one if it exists, according to the value of
`dvc-buffer-type-alist' (see its docstring), or, call
@ -159,21 +159,19 @@ Maybe reuse one if it exists, according to the value of
See also `dvc-get-buffer'"
;; Inspired from `cvs-get-buffer-create'
;;
;; For 'root buffers, make sure we don't create two buffers to the
;; same absolute path, even in the presence of symlinks.
(let ((return-buffer
(let* ((path (or path default-directory))
(elem (assoc type dvc-buffer-type-alist))
(mode (car (cddr elem))))
(let* ((elem (assoc type dvc-buffer-type-alist))
(mode (car (cddr elem)))
(path (if (eq mode 'root)
(dvc-tree-root (dvc-uniquify-file-name (or path default-directory) t))
(or path default-directory))))
(or (dvc-get-buffer dvc type path mode)
;; Buffer couldn't be reused. Create one
(let ((path (cond
((eq mode 'root)
(dvc-uniquify-file-name
(dvc-tree-root path)))
((or (eq mode 'string)
(eq mode 'string-multiple))
path)
(t (dvc-uniquify-file-name path))))
(name (concat "*" (symbol-name dvc) "-"
(let ((name (concat "*" (symbol-name dvc) "-"
(cadr (assoc type dvc-buffer-type-alist)))))
(let ((buffer
(if (or (eq mode 'string)
@ -202,7 +200,7 @@ If DVC is nil, it matches any back-end. TYPE must match exactly.
PATH matches if the entry in dvc-buffers-tree is a prefix of
PATH."
(let ((result nil)
(true-path (file-truename path))
(true-path (dvc-uniquify-file-name path))
tree)
(if dvc

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

@ -324,8 +324,28 @@ dvc-fileinfo-current-file only for renamed files."
;; source name is in more-status, and it includes the path
(dvc-fileinfo-file-more-status fileinfo))
(t
<<<<<<< TREE
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))
=======
;; see if there is a rename for this file in the ewoc
(let ((found-data
(ewoc-collect
dvc-fileinfo-ewoc
(lambda (data)
(etypecase data
(dvc-fileinfo-file
(and (eq 'rename-target (dvc-fileinfo-file-status data))
(string= (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-dir data))
(string= (dvc-fileinfo-file-file fileinfo)
(dvc-fileinfo-file-file data))))
(t nil))))))
(if found-data
(dvc-fileinfo-file-more-status (car found-data))
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))))
>>>>>>> MERGE-SOURCE
(dvc-fileinfo-legacy
(cadr (dvc-fileinfo-legacy-data fileinfo))))))

33
dvc/lisp/dvc-utils.el
View File

@ -1,6 +1,6 @@
;;; dvc-utils.el --- Utility functions for DVC
;; Copyright (C) 2005 - 2009 by all contributors
;; Copyright (C) 2005 - 2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
@ -275,16 +275,35 @@ means the two items are the same."
(setq pos (1+ pos)))
(when seq-int pos)))
(defun dvc-uniquify-file-name (path)
"Return a unique string designating PATH.
(defun dvc-uniquify-file-name (path &optional resolve-symlinks)
"Return a string containing an absolute path to PATH, which is relative to `default-directory'.
If PATH is a directory,the returned contains one and exactly one trailing
slash. If PATH is nil, then nil is returned."
slash. If PATH is nil, then nil is returned.
If RESOLVE-SYMLINKS is non-nil (default nil), resolve symlinks in path."
;; We normally _don'_ want 'file-truename' here, since that
;; eliminates symlinks. We assume the user has configured symlinks
;; the way they want within the workspace, so the view from the
;; current default directory is correct.
;;
;; This may cause problems with the path to the workspace root;
;; `call-process' spawns the backend process with symlinks in the
;; working directory expanded. Most backends get the workspace root
;; from the working directory; if DVC passes the workspace root
;; explicitly to the backend explicitly, it must resolve symlinks at
;; that point.
;;
;; Another case is DVC status buffers (and similar buffers); we
;; don't want to create two buffers to the same workspace with
;; different paths.
;;
;; In these cases, set resolve-symlinks t at the call point.
(and path
(let ((expanded (file-truename
(expand-file-name
(let ((expanded (expand-file-name
(if (file-directory-p path)
(file-name-as-directory path)
path)))))
path))))
(if resolve-symlinks
(setq expanded (file-truename expanded)))
(if (featurep 'xemacs)
(replace-regexp-in-string "/+$" "/" expanded)
expanded))))

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

@ -1399,7 +1399,6 @@ finished."
((revision $hash-id)
(setq source-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
@ -1407,7 +1406,6 @@ finished."
((revision $hash-id)
(return-from get-corresponding-path nil))
((local-tree $target-path)
(assert (xmtn--same-tree-p path target-path))
(return-from get-corresponding-path normalized-file-name)))
;; Handle an uncommitted rename in the current workspace
(setq normalized-file-name (xmtn--get-rename-in-workspace-to
@ -1418,7 +1416,6 @@ finished."
((revision $hash-id)
(setq target-revision-hash-id hash-id))
((local-tree $path)
(assert (xmtn--same-tree-p root path))
(let ((base-revision-hash-id
(xmtn--get-base-revision-hash-id-or-null path)))
(if (null base-revision-hash-id)
@ -1481,6 +1478,7 @@ finished."
(xmtn-automate-simple-command-output-string
root `("get_file" ,content-hash-id)))
<<<<<<< TREE
(defun xmtn--insert-file-contents (root content-hash-id buffer)
(check-type content-hash-id xmtn--hash-id)
(xmtn-automate-command-output-buffer
@ -1505,6 +1503,8 @@ finished."
(defun xmtn--same-tree-p (a b)
(equal (file-truename a) (file-truename b)))
=======
>>>>>>> MERGE-SOURCE
(defstruct (xmtn--revision (:constructor xmtn--make-revision))
;; matches data output by 'mtn diff'
new-manifest-hash-id

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

@ -1,6 +1,6 @@
;;; xmtn-ids.el --- Resolver routines for xmtn revision ids
;; Copyright (C) 2008, 2009 Stephen Leake
;; Copyright (C) 2008 - 2010 Stephen Leake
;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler
@ -131,15 +131,6 @@ See file commentary for details."
((local-tree $string) (assert (typep string 'string))))
resolved-backend-id))
(defun xmtn--resolve--local-tree (root path)
(check-type path string)
(let ((path-root (xmtn-tree-root path t)))
(unless (and path-root
(equal (file-truename path-root)
(file-truename path)))
(error "Path is not the root of a monotone tree: %S" `(local-tree ,path))))
`(local-tree ,path))
(defun xmtn--resolve--last-revision (root path num)
(check-type path string)
(check-type num (integer 1 *))

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

@ -61,14 +61,15 @@ The elements must all be of class xmtn-status-data.")
(defun xmtn-status-work (data)
(concat xmtn-status-root (xmtn-status-data-work data)))
(defun xmtn-status-need-refresh (elem data)
(defun xmtn-status-need-refresh (elem data local-changes)
;; The user has selected an action that will change the state of the
;; workspace via mtn actions; set our data to reflect that. We
;; assume the user will not be creating new files or editing
;; existing ones.
;; workspace via mtn actions; set our data to reflect that. If
;; local-changes is non-nil, xmtn-status-data-local-changes is set
;; to that value.
(setf (xmtn-status-data-need-refresh data) t)
(setf (xmtn-status-data-heads data) 'need-scan)
(setf (xmtn-status-data-conflicts data) 'need-scan)
(if local-changes (setf (xmtn-status-data-local-changes data) local-changes))
(ewoc-invalidate xmtn-status-ewoc elem))
(defun xmtn-status-printer (data)
@ -172,7 +173,7 @@ The elements must all be of class xmtn-status-data.")
(interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)))
(xmtn-status-need-refresh elem data)
(xmtn-status-need-refresh elem data nil)
(setf (xmtn-status-data-update-review data) 'need-review)
(let ((default-directory (xmtn-status-work data)))
(xmtn-dvc-update))
@ -190,7 +191,7 @@ The elements must all be of class xmtn-status-data.")
(interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)))
(xmtn-status-need-refresh elem data)
(xmtn-status-need-refresh elem data nil)
(setf (xmtn-status-data-conflicts data) 'resolved)
(pop-to-buffer (xmtn-status-data-conflicts-buffer data))))
@ -206,8 +207,8 @@ The elements must all be of class xmtn-status-data.")
(interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)))
(xmtn-status-need-refresh elem data)
(setf (xmtn-status-data-local-changes data) 'ok)
;; assume they are doing a checkin
(xmtn-status-need-refresh elem data 'ok)
(pop-to-buffer (xmtn-status-data-status-buffer data))
;; IMPROVEME: create a log-edit buffer now, since we have both a
;; status and conflict buffer, and that confuses dvc-log-edit
@ -233,7 +234,8 @@ The elements must all be of class xmtn-status-data.")
(interactive)
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem)))
(xmtn-status-need-refresh elem data)
;; assume they are adding FIXMEs
(xmtn-status-need-refresh elem data 'need-scan)
(setf (xmtn-status-data-update-review data) 'done)
(xmtn-review-update (xmtn-status-work data))))
@ -260,7 +262,7 @@ The elements must all be of class xmtn-status-data.")
(let* ((elem (ewoc-locate xmtn-status-ewoc))
(data (ewoc-data elem))
(default-directory (xmtn-status-work data)))
(xmtn-status-need-refresh elem data)
(xmtn-status-need-refresh elem data nil)
(xmtn-view-heads-revlist)))
(defun xmtn-status-headsp ()

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

@ -255,13 +255,18 @@ 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)
<<<<<<< TREE
=======
(if (not (buffer-live-p (xmtn-propagate-data-to-status-buffer data)))
(xmtn-propagate-create-to-status-buffer data))
>>>>>>> MERGE-SOURCE
(pop-to-buffer (xmtn-propagate-data-to-status-buffer data))))
(defun xmtn-propagate-commit-top ()
"Non-nil if commit is appropriate for current `to' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(eq (xmtn-propagate-data-to-local-changes data) 'need-commit))))
(member (xmtn-propagate-data-to-local-changes data) '(need-commit need-scan)))))
(defun xmtn-propagate-commit-from ()
"Show commit buffer for `from' workspace, so it can be committed, updated, or merged."
@ -269,13 +274,18 @@ 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)
<<<<<<< TREE
=======
(if (not (buffer-live-p (xmtn-propagate-data-from-status-buffer data)))
(xmtn-propagate-create-from-status-buffer data))
>>>>>>> MERGE-SOURCE
(pop-to-buffer (xmtn-propagate-data-from-status-buffer data))))
(defun xmtn-propagate-commit-fromp ()
"Non-nil if commit is appropriate for current `from' workspace."
(let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc))))
(and (not (xmtn-propagate-data-need-refresh data))
(eq (xmtn-propagate-data-from-local-changes data) 'need-commit))))
(member (xmtn-propagate-data-from-local-changes data) '(need-commit need-scan)))))
(defun xmtn-propagate-update-to ()
"Update current `to' workspace."

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

@ -55,24 +55,19 @@
;; non-Cygwin Emacs.
,@arguments))))
;;; The `dvc-run-dvc-*' functions use `call-process', which, for some
;;; reason, spawns the subprocess with a working directory with all
;;; symlinks expanded. (Or maybe it's the shell that expands the
;;; symlinks.) If the path to the root directory looks different from
;;; the current working directory, monotone rejects it even if it is
;;; the same via symlinks. Therefore, we need to resolve symlinks
;;; here in strategic places. Hence the calls to `file-truename'.
(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key)
(xmtn--check-cached-command-version)
(let ((default-directory (file-truename (or root default-directory))))
(let ((default-directory (or root default-directory)))
(apply #'dvc-run-dvc-async
'xmtn
`(,@xmtn-additional-arguments
;; We don't pass the --root argument here; it is not
;; necessary since default-directory is set, and it
;; confuses the Cygwin version of mtn when run with a
;; non-Cygwin Emacs.
;; non-Cygwin Emacs. It also confuses other versions of
;; mtn when there are symlinks in the path to the root;
;; `call-process' spawns the subprocess with a working
;; directory with all symlinks expanded.
,@arguments)
dvc-run-keys)))

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

@ -48,11 +48,30 @@
"File to store `xmtn-sync-branch-alist' and `xmtn-sync-remote-exec-alist'; relative to `dvc-config-directory'.")
;;; Internal variables
<<<<<<< TREE
(defconst xmtn-sync-required-command-version '(0 46)
"Minimum mtn version for automate sync; overrides xmtn--minimum-required-command-version.")
(defconst xmtn-sync-remote-exec-default "mtn"
"Default executable command to run on remote host for file: or ssh:; see `xmtn-sync-remote-exec-alist'.")
=======
(defconst xmtn-sync-save-file "sync"
"File to save sync review state for later; relative to `dvc-config-directory'.")
(defconst xmtn-sync-review-file "sync.basic_io"
"File to save shell sync basic_io output for input by `xmtn-sync-review'; relative to `dvc-config-directory'.")
(defconst xmtn-sync-branch-file "branches"
"File associating branch name with workspace root; relative to `dvc-config-directory'.")
(defconst xmtn-sync-config "xmtn-sync-config"
"File to store `xmtn-sync-branch-alist'; relative to `dvc-config-directory'.")
(defconst xmtn-sync-required-command-version '(0 99)
;; Sometimes the Cygwin version lags behind the MinGW version; this allows that.
"Minimum version for `xmtn-sync-executable'; overrides xmtn--minimum-required-command-version.
Must support file:, ssh:, automate sync.")
>>>>>>> MERGE-SOURCE
;; loaded from xmtn-sync-config
(defvar xmtn-sync-branch-alist nil
@ -141,14 +160,227 @@ The elements must all be of type xmtn-sync-sync.")
(setq xmtn-sync-ewoc (ewoc-create 'xmtn-sync-printer))
(setq dvc-buffer-refresh-function nil)
(dvc-install-buffer-menu)
<<<<<<< TREE
(setq buffer-read-only t)
(buffer-disable-undo)
(set-buffer-modified-p nil))
=======
(buffer-disable-undo))
(defun xmtn-sync-parse-revision-certs (direction)
"Parse certs associated with a revision; return (branch changelog date author)."
(let ((keyword (ecase direction
('receive "receive_cert")
('send "send_cert")))
cert-label branch date author changelog old-branch)
(while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value)))
(cond
((string= cert-label "branch")
(xmtn-basic-io-check-line "value" (setq branch (cadar value)))
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-skip-line "revision"))
((string= cert-label "changelog")
(xmtn-basic-io-check-line "value" (setq changelog (cadar value)))
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-skip-line "revision"))
((string= cert-label "date")
(xmtn-basic-io-check-line "value" (setq date (cadar value)))
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-skip-line "revision"))
((string= cert-label "author")
(xmtn-basic-io-check-line "value" (setq author (cadar value)))
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-skip-line "revision"))
(t
;; ignore other certs
(xmtn-basic-io-skip-stanza))
)
(xmtn-basic-io-skip-blank-lines) ;; might be at end of parsing region
) ;; end while cert
(list branch changelog date author)))
(defun xmtn-sync-enter-rev (revid branch date author changelog direction)
"Enter data for REVID into ewoc."
(let (old-branch)
(ewoc-map
(lambda (data)
(if (string= branch (xmtn-sync-branch-name data))
;; already some data for branch
(let ((rev-alist (xmtn-sync-branch-rev-alist data)))
(ecase direction
('receive
(setf (xmtn-sync-branch-rev-alist data)
;; sync sends revs newest first, we want newest
;; displayed last, so append to head of list
(push (list revid (list date author changelog)) rev-alist)))
('send
(setf (xmtn-sync-branch-send-count data) (+ 1 (xmtn-sync-branch-send-count data)))))
(setq old-branch t)
t; update ewoc
)))
xmtn-sync-ewoc)
(if (not old-branch)
(ewoc-enter-last
xmtn-sync-ewoc
(ecase direction
('receive
(make-xmtn-sync-branch
:name branch
:rev-alist (list (list revid (list date author changelog)))
:send-count 0
:print-mode 'summary))
('send
(make-xmtn-sync-branch
:name branch
:rev-alist nil
:send-count 1
:print-mode 'summary)))))))
(defun xmtn-sync-parse-revisions (direction)
"Parse revisions with associated certs."
(let ((keyword (ecase direction
('receive "receive_revision")
('send "send_revision")))
revid)
(while (xmtn-basic-io-optional-line keyword (setq revid (cadar value)))
(xmtn-basic-io-skip-blank-lines)
(let* ((cert-values (xmtn-sync-parse-revision-certs direction))
(branch (nth 0 cert-values))
(changelog (nth 1 cert-values))
(date (nth 2 cert-values))
(author (nth 3 cert-values)))
(xmtn-sync-enter-rev revid branch date author changelog direction)))))
(defun xmtn-sync-parse-certs (direction)
"Parse certs not associated with revisions."
;; The only case we care about is a new branch created from an existing revision.
(let ((keyword (ecase direction
('receive "receive_cert")
('send "send_cert")))
revid
cert-label
branch
(date "")
(author "")
(changelog "create branch\n")
old-branch)
(while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value)))
(cond
((string= cert-label "branch")
(xmtn-basic-io-check-line "value" (setq branch (cadar value)))
(xmtn-basic-io-skip-line "key")
(xmtn-basic-io-check-line "revision" (setq revid (cadar value)))
(xmtn-sync-enter-rev revid branch date author changelog direction))
(t
;; ignore other certs
(xmtn-basic-io-skip-stanza))
)
;; move to next stanza or end of parsing region
(xmtn-basic-io-skip-blank-lines)
)))
(defun xmtn-sync-parse-keys (direction)
;; just ignore all keys
(let ((keyword (ecase direction
('receive "receive_key")
('send "send_key"))))
(xmtn-basic-io-skip-blank-lines)
(while (xmtn-basic-io-optional-skip-line keyword))))
(defun xmtn-sync-parse (begin)
"Parse current buffer starting at BEGIN, fill in `xmtn-sync-ewoc' in current buffer, erase parsed text."
(set-syntax-table xmtn-basic-io--*syntax-table*)
(goto-char begin)
;; receive_cert "branch"
;; value "foo2"
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; revision [e4352c1d28b38e87b5040f770a66be2ec9b2362d]
;;
;; ... more unattached certs
;;
;; receive_revision [e4352c1d28b38e87b5040f770a66be2ec9b2362d]
;;
;; receive_cert "branch"
;; value "foo2"
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; revision [...]
;;
;; receive_cert "changelog"
;; value "more
;; "
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; revision [...]
;;
;; receive_cert "date"
;; value "2010-09-21T08:29:11"
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; revision [...]
;;
;; receive_cert "author"
;; value "tester@test.net"
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; revision [...]
;;
;; ... more certs
;;
;; ... more revisions with certs
;;
;; receive_key
;;
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50]
;; ... more keys
;;
;; send_cert ... (unattached)
;;
;; send_revision [...]
;; send_cert ...
;;
;; send_key ...
(xmtn-sync-parse-certs 'receive)
(xmtn-sync-parse-revisions 'receive)
(xmtn-sync-parse-keys 'receive)
(xmtn-sync-parse-certs 'send)
(xmtn-sync-parse-revisions 'send)
(xmtn-sync-parse-keys 'send)
(delete-region begin (point))
)
(defun xmtn-sync-load-file (&optional noerror)
"Add contents of `xmtn-sync-save-file' to current ewoc."
(let ((save-file (expand-file-name xmtn-sync-save-file dvc-config-directory))
stuff)
(if (file-exists-p save-file)
(progn
(load save-file)
(setq buffer-read-only nil)
(dolist (data stuff) (ewoc-enter-last xmtn-sync-ewoc data))
(setq buffer-read-only t)
(set-buffer-modified-p nil))
(unless noerror
(error "%s file not found" save-file)))))
>>>>>>> MERGE-SOURCE
;;;###autoload
(defun xmtn-sync-sync (local-db remote-host remote-db)
"Sync LOCAL-DB with REMOTE-HOST REMOTE-DB, display sent and received branches.
Remote-db should include branch pattern in URI syntax."
<<<<<<< TREE
(interactive "flocal db: \nMremote-host: \nMremote-db: ")
(pop-to-buffer (get-buffer-create "*xmtn-sync*"))
(let ((xmtn-executable xmtn-sync-executable)
@ -169,6 +401,116 @@ Remote-db should include branch pattern in URI syntax."
) ;; options
"sync" (concat remote-host remote-db)) ;; command, args
)))
=======
(interactive "flocal db: \nMscheme: \nMremote-host: \nMremote-db: ")
(pop-to-buffer (get-buffer-create "*xmtn-sync*"))
(setq buffer-read-only nil)
(delete-region (point-min) (point-max))
;; `xmtn-sync-parse' creates ewoc entries, which are inserted into
;; the xmtn-sync buffer. Since it is parsing the same buffer, we
;; need them to be inserted _after_ the text that is being
;; parsed. `xmtn-sync-mode' creates the ewoc at point.
(let ((opts xmtn-sync-automate-args)
(remote-uri (concat scheme "://" remote-host remote-db))
(msg "Running mtn sync ..."))
(message msg)
(redisplay) ;; show tickers in mode-line
;; Remote command (if needed by scheme) is determined by a custom
;; version of get_netsync_connect_command; see xmtn-hooks.lua.
(if (eq system-type 'windows-nt)
(add-to-list 'opts
(concat "--rcfile=" (substring (locate-library "xmtn-hooks.lua") 2)))
(add-to-list 'opts
(concat "--rcfile=" (locate-library "xmtn-hooks.lua"))))
;; Always use mtn executable that supports file and ssh, so we
;; only need one session for all syncs.
(let ((xmtn-executable xmtn-sync-executable)
(xmtn--minimum-required-command-version xmtn-sync-required-command-version)
(xmtn-automate-arguments opts))
(xmtn-automate-command-output-buffer
(expand-file-name "~/sync") ; root - one session for all syncs
(current-buffer) ; output-buffer
(list
(list "db" local-db) ;; options
"sync" remote-uri) ;; command, args
'("revisions" "revs in" "revs out") ;; display-tickers
))
(message (concat msg " done"))
(goto-char (point-max))
;; don't lose what was saved from last sync; may not have been reviewed yet
(xmtn-sync-mode)
(xmtn-sync-load-file t)
(setq buffer-read-only nil)
(ewoc-set-hf
xmtn-sync-ewoc
(concat ;; header
(format " local db: %s\n" local-db)
(format "remote db: %s\n" remote-uri))
"") ;; footer
(xmtn-sync-parse (point-min))
(setq buffer-read-only t)
(set-buffer-modified-p nil)
(xmtn-sync-save)
(unless xmtn-sync-branch-alist
(let ((branch-file (expand-file-name xmtn-sync-branch-file dvc-config-directory)))
(if (file-exists-p branch-file)
(load branch-file))))
))
(defun xmtn-sync-save ()
"Save current sync results in `xmtn-sync-save-file' for later review."
(interactive)
(let ((save-file (expand-file-name xmtn-sync-save-file dvc-config-directory))
stuff)
;; Directly saving the ewoc doesn't work; too complicated for
;; pp-to-string. So we turn the ewoc into a simpler list of data
;; items
(ewoc-map
(lambda (data)
(setq stuff (add-to-list 'stuff data t))
nil)
xmtn-sync-ewoc)
(dvc-save-state
(list 'stuff)
(expand-file-name xmtn-sync-save-file dvc-config-directory))))
;;;###autoload
(defun xmtn-sync-review (&optional file)
"Display sync results in FILE (defaults to `xmtn-sync-review-file'), appended to content of `xmtn-sync-save-file'.
FILE should be output of 'automate sync'. (external sync handles tickers better)."
(interactive)
;; first load xmtn-sync-save-file
(pop-to-buffer (get-buffer-create "*xmtn-sync*"))
(setq buffer-read-only nil)
(delete-region (point-min) (point-max))
(xmtn-sync-mode)
(xmtn-sync-load-file)
;; now add file
(setq file (or file
(expand-file-name xmtn-sync-review-file dvc-config-directory)))
(if (file-exists-p file)
(progn
(goto-char (point-min))
(setq buffer-read-only nil)
(insert-file-contents-literally file)
(xmtn-sync-parse (point-min))
(setq buffer-read-only t)
(delete-file file))))
>>>>>>> MERGE-SOURCE
(provide 'xmtn-sync)

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

@ -289,6 +289,21 @@ Summarizes the status of several workspaces
@item xmtn-propagate-multiple
Supervises propagating several workspaces
<<<<<<< TREE
=======
@item xmtn-sync-sync
Syncs a local database with a remote database, displays branches that
have been transferred.
@item xmtn-sync-review
Reviews saved output of an external @command{mtn automate sync},
displays branches that have been transferred. This is useful for syncs
that take a long time, because external commands display the tickers
much better than DVC does.
The external sync should redirect stdout to @file{~/.dvc/sync.basic_io}.
>>>>>>> MERGE-SOURCE
@end table
@menu