From 8af13eb79229d809ab55402eac3ae8dd23ba8634 Mon Sep 17 00:00:00 2001 From: Kai Tetzlaff Date: Tue, 4 Jan 2011 12:44:19 +0100 Subject: [PATCH] update dvc --- dvc/lisp/dvc-buffers.el | 26 ++- dvc/lisp/dvc-fileinfo.el | 20 ++ dvc/lisp/dvc-utils.el | 33 +++- dvc/lisp/xmtn-dvc.el | 6 +- dvc/lisp/xmtn-ids.el | 11 +- dvc/lisp/xmtn-multi-status.el | 22 ++- dvc/lisp/xmtn-propagate.el | 14 +- dvc/lisp/xmtn-run.el | 15 +- dvc/lisp/xmtn-sync.el | 342 ++++++++++++++++++++++++++++++++++ dvc/texinfo/dvc-intro.texinfo | 15 ++ 10 files changed, 448 insertions(+), 56 deletions(-) diff --git a/dvc/lisp/dvc-buffers.el b/dvc/lisp/dvc-buffers.el index d5b2f22..c2401a7 100644 --- a/dvc/lisp/dvc-buffers.el +++ b/dvc/lisp/dvc-buffers.el @@ -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 diff --git a/dvc/lisp/dvc-fileinfo.el b/dvc/lisp/dvc-fileinfo.el index 20192be..c76d883 100644 --- a/dvc/lisp/dvc-fileinfo.el +++ b/dvc/lisp/dvc-fileinfo.el @@ -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)))))) diff --git a/dvc/lisp/dvc-utils.el b/dvc/lisp/dvc-utils.el index 4c38526..a8a7e56 100644 --- a/dvc/lisp/dvc-utils.el +++ b/dvc/lisp/dvc-utils.el @@ -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 @@ -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)))) diff --git a/dvc/lisp/xmtn-dvc.el b/dvc/lisp/xmtn-dvc.el index c515134..0846f8d 100644 --- a/dvc/lisp/xmtn-dvc.el +++ b/dvc/lisp/xmtn-dvc.el @@ -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 diff --git a/dvc/lisp/xmtn-ids.el b/dvc/lisp/xmtn-ids.el index f257f33..4068ea6 100644 --- a/dvc/lisp/xmtn-ids.el +++ b/dvc/lisp/xmtn-ids.el @@ -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 *)) diff --git a/dvc/lisp/xmtn-multi-status.el b/dvc/lisp/xmtn-multi-status.el index c1a388c..590de2b 100644 --- a/dvc/lisp/xmtn-multi-status.el +++ b/dvc/lisp/xmtn-multi-status.el @@ -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 () diff --git a/dvc/lisp/xmtn-propagate.el b/dvc/lisp/xmtn-propagate.el index 836febc..b27f408 100644 --- a/dvc/lisp/xmtn-propagate.el +++ b/dvc/lisp/xmtn-propagate.el @@ -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." diff --git a/dvc/lisp/xmtn-run.el b/dvc/lisp/xmtn-run.el index 1781825..e2d5021 100644 --- a/dvc/lisp/xmtn-run.el +++ b/dvc/lisp/xmtn-run.el @@ -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))) diff --git a/dvc/lisp/xmtn-sync.el b/dvc/lisp/xmtn-sync.el index 8ebd5ce..a5a406c 100644 --- a/dvc/lisp/xmtn-sync.el +++ b/dvc/lisp/xmtn-sync.el @@ -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) diff --git a/dvc/texinfo/dvc-intro.texinfo b/dvc/texinfo/dvc-intro.texinfo index 6ea02bd..b485799 100644 --- a/dvc/texinfo/dvc-intro.texinfo +++ b/dvc/texinfo/dvc-intro.texinfo @@ -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