730 lines
31 KiB
EmacsLisp
730 lines
31 KiB
EmacsLisp
;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone
|
|
|
|
;; Copyright (C) 2009 Stephen Leake
|
|
|
|
;; Author: Stephen Leake
|
|
;; Keywords: tools
|
|
|
|
;; This file is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2 of the License, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This file is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this file; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
|
|
;; Boston, MA 02110-1301 USA.
|
|
|
|
(eval-and-compile
|
|
;; these have macros we use
|
|
(require 'xmtn-ids))
|
|
|
|
(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 ;
|
|
conflicts-buffer ; *xmtn-conflicts* buffer for this propagation
|
|
propagate-needed ; nil | t
|
|
from-heads ; 'at-head | 'need-update | 'need-merge)
|
|
to-heads ;
|
|
(from-local-changes
|
|
'need-scan) ; 'need-scan | 'need-commit | 'ok
|
|
(to-local-changes
|
|
'need-scan) ;
|
|
(conflicts
|
|
'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'ok
|
|
)
|
|
|
|
(defun xmtn-propagate-from-work (data)
|
|
(concat xmtn-propagate-from-root (xmtn-propagate-data-from-work data)))
|
|
|
|
(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))
|
|
|
|
(defun xmtn-propagate-printer (data)
|
|
"Print an ewoc element."
|
|
(if (string= (xmtn-propagate-data-from-work data)
|
|
(xmtn-propagate-data-to-work data))
|
|
(insert (dvc-face-add (format "%s\n" (xmtn-propagate-data-from-work data)) 'dvc-keyword))
|
|
(insert (dvc-face-add (format "%s -> %s\n"
|
|
(xmtn-propagate-data-from-work data)
|
|
(xmtn-propagate-data-to-work data))
|
|
'dvc-keyword)))
|
|
|
|
(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)
|
|
|
|
(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)))))
|
|
|
|
(if (eq 'at-head (xmtn-propagate-data-to-heads data))
|
|
(insert (dvc-face-add " need clean\n" 'dvc-conflict)))
|
|
))
|
|
;; ewoc ought to do this, but it doesn't
|
|
(redisplay))
|
|
|
|
(defun xmtn-propagate-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-save-conflicts-buffer (data)
|
|
(if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))
|
|
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer))))
|
|
|
|
(defun xmtn-propagate-clean ()
|
|
"Clean current workspace, delete from ewoc"
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
|
|
;; only one conflicts file and buffer
|
|
(xmtn-propagate-kill-conflicts-buffer data)
|
|
(xmtn-conflicts-clean (xmtn-propagate-to-work 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))))
|
|
;; 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))
|
|
(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 (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))))
|
|
(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-to ()
|
|
"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-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-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."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
|
|
(if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
|
|
;; user deleted conflicts buffer after resolving conflicts; get it back
|
|
(setf (xmtn-propagate-data-conflicts-buffer data)
|
|
(xmtn-propagate-conflicts-buffer data)))
|
|
|
|
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
|
|
(let ((xmtn-confirm-operation nil))
|
|
(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 ()
|
|
"Non-nil if propagate is appropriate for current 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 'at-head (xmtn-propagate-data-from-heads data))
|
|
(eq 'at-head (xmtn-propagate-data-to-heads data))
|
|
(member (xmtn-propagate-data-conflicts data)
|
|
'(ok need-review-resolve-internal)))))
|
|
|
|
(defun xmtn-propagate-resolve-conflicts ()
|
|
"Resolve conflicts for current workspace."
|
|
(interactive)
|
|
(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 ()
|
|
"Non-nil if resolve conflicts is appropriate for current 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 'at-head (xmtn-propagate-data-from-heads data))
|
|
(eq 'at-head (xmtn-propagate-data-to-heads data))
|
|
(member (xmtn-propagate-data-conflicts data)
|
|
'(need-resolve need-review-resolve-internal)))))
|
|
|
|
(defun xmtn-propagate-status-to ()
|
|
"Run xmtn-status on current `to' workspace."
|
|
(interactive)
|
|
(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-propagate-kill-conflicts-buffer data)
|
|
|
|
(setf (xmtn-propagate-data-to-local-changes data) 'ok)
|
|
(xmtn-status (xmtn-propagate-to-work data))))
|
|
|
|
(defun xmtn-propagate-status-to-ok ()
|
|
"Ignore local changes in current `to' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(setf (xmtn-propagate-data-to-local-changes data) 'ok)
|
|
(ewoc-invalidate xmtn-propagate-ewoc elem)))
|
|
|
|
(defun xmtn-propagate-status-top ()
|
|
"Non-nil if xmtn-status is appropriate for current `to' workspace."
|
|
(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-commit)))))
|
|
|
|
(defun xmtn-propagate-status-from ()
|
|
"Run xmtn-status on current `from' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
(setf (xmtn-propagate-data-from-local-changes data) 'ok)
|
|
(xmtn-status (xmtn-propagate-from-work data))))
|
|
|
|
(defun xmtn-propagate-status-from-ok ()
|
|
"Ignore local changes in current `from' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(setf (xmtn-propagate-data-from-local-changes data) 'ok)
|
|
(ewoc-invalidate xmtn-propagate-ewoc elem)))
|
|
|
|
(defun xmtn-propagate-status-fromp ()
|
|
"Non-nil if xmtn-status is appropriate for current `from' workspace."
|
|
(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-commit)))))
|
|
|
|
(defun xmtn-propagate-missing-to ()
|
|
"Run xmtn-missing on current `to' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
(xmtn-missing nil (xmtn-propagate-to-work data))))
|
|
|
|
(defun xmtn-propagate-missing-top ()
|
|
"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))
|
|
(eq 'need-update (xmtn-propagate-data-to-heads data)))))
|
|
|
|
(defun xmtn-propagate-missing-from ()
|
|
"Run xmtn-missing on current `from' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
(xmtn-missing nil (xmtn-propagate-from-work data))))
|
|
|
|
(defun xmtn-propagate-missing-fromp ()
|
|
"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))
|
|
(eq 'need-update (xmtn-propagate-data-from-heads data)))))
|
|
|
|
(defun xmtn-propagate-heads-to ()
|
|
"Run xmtn-heads on current `to' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem))
|
|
(default-directory (xmtn-propagate-to-work data)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
(xmtn-view-heads-revlist)))
|
|
|
|
(defun xmtn-propagate-heads-top ()
|
|
"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))
|
|
(eq 'need-merge (xmtn-propagate-data-to-heads data)))))
|
|
|
|
(defun xmtn-propagate-heads-from ()
|
|
"Run xmtn-heads on current `from' workspace."
|
|
(interactive)
|
|
(let* ((elem (ewoc-locate xmtn-propagate-ewoc))
|
|
(data (ewoc-data elem))
|
|
(default-directory (xmtn-propagate-from-work data)))
|
|
(xmtn-propagate-need-refresh elem data)
|
|
(xmtn-view-heads-revlist)))
|
|
|
|
(defun xmtn-propagate-heads-fromp ()
|
|
"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))
|
|
(eq 'need-merge (xmtn-propagate-data-from-heads data)))))
|
|
|
|
(defvar xmtn-propagate-actions-map
|
|
(let ((map (make-sparse-keymap "actions")))
|
|
(define-key map [?c] '(menu-item "c) clean/delete"
|
|
xmtn-propagate-clean
|
|
:visible (xmtn-propagate-cleanp)))
|
|
(define-key map [?g] '(menu-item "g) refresh"
|
|
xmtn-propagate-do-refresh-one
|
|
:visible (xmtn-propagate-refreshp)))
|
|
(define-key map [?b] '(menu-item "b) propagate"
|
|
xmtn-propagate-propagate
|
|
:visible (xmtn-propagate-propagatep)))
|
|
(define-key map [?a] '(menu-item "a) resolve conflicts"
|
|
xmtn-propagate-resolve-conflicts
|
|
:visible (xmtn-propagate-resolve-conflictsp)))
|
|
(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 [?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 [?7] '(menu-item (concat "7) dvc-missing " (xmtn-propagate-to-name))
|
|
xmtn-propagate-missing-to
|
|
:visible (xmtn-propagate-missing-top)))
|
|
(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 [?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 (concat "0) xmtn-heads " (xmtn-propagate-from-name))
|
|
xmtn-propagate-heads-from
|
|
:visible (xmtn-propagate-heads-fromp)))
|
|
map)
|
|
"Keyboard menu keymap used to manage propagates.")
|
|
|
|
(dvc-make-ewoc-next xmtn-propagate-next xmtn-propagate-ewoc)
|
|
(dvc-make-ewoc-prev xmtn-propagate-prev xmtn-propagate-ewoc)
|
|
|
|
(defvar xmtn-propagate-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map "\M-d" xmtn-propagate-actions-map)
|
|
(define-key map [?g] 'xmtn-propagate-refresh)
|
|
(define-key map [?n] 'xmtn-propagate-next)
|
|
(define-key map [?p] 'xmtn-propagate-prev)
|
|
(define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer))))
|
|
map)
|
|
"Keymap used in `xmtn-propagate-mode'.")
|
|
|
|
(define-derived-mode xmtn-propagate-mode nil "xmtn-propagate"
|
|
"Major mode to propagate multiple workspaces."
|
|
(setq dvc-buffer-current-active-dvc 'xmtn)
|
|
(setq buffer-read-only nil)
|
|
|
|
;; don't do normal clean up stuff
|
|
(set (make-local-variable 'before-save-hook) nil)
|
|
(set (make-local-variable 'write-file-functions) nil)
|
|
|
|
(dvc-install-buffer-menu)
|
|
(setq buffer-read-only t)
|
|
(buffer-disable-undo)
|
|
(set-buffer-modified-p nil)
|
|
(xmtn-propagate-refresh)
|
|
(xmtn-propagate-next nil t))
|
|
|
|
(defun xmtn-propagate-needed (data)
|
|
"t if DATA needs propagate."
|
|
(let ((result t)
|
|
(from-work (xmtn-propagate-from-work data))
|
|
(from-head-rev (xmtn-propagate-data-from-head-rev data))
|
|
(to-head-rev (xmtn-propagate-data-to-head-rev data)))
|
|
|
|
(if (or (not from-head-rev)
|
|
(not to-head-rev))
|
|
;; multiple heads; can't propagate
|
|
(setq result nil)
|
|
|
|
;; 1) to branched off earlier, and propagate is needed
|
|
;; 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 (data)
|
|
"Return a conflicts buffer for FROM-WORK, TO-WORK (absolute paths)."
|
|
(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 (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-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)
|
|
|
|
: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 to-work)
|
|
(current-buffer)))))))
|
|
|
|
(defun xmtn-propagate-conflicts (data)
|
|
"Return value for xmtn-propagate-data-conflicts for DATA."
|
|
|
|
(if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)))
|
|
;; user may have deleted conflicts buffer after resolving
|
|
;; conflicts; don't throw that away.
|
|
(setf (xmtn-propagate-data-conflicts-buffer data)
|
|
(xmtn-propagate-conflicts-buffer data)))
|
|
|
|
(let ((revs-current
|
|
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
|
|
(and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision)
|
|
(string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))
|
|
(if revs-current
|
|
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
|
|
(xmtn-conflicts-update-counts)
|
|
(save-buffer))
|
|
|
|
;; else recreate conflicts
|
|
(xmtn-propagate-kill-conflicts-buffer data)
|
|
|
|
(xmtn-conflicts-clean (xmtn-propagate-to-work data))
|
|
|
|
(setf (xmtn-propagate-data-conflicts-buffer data)
|
|
(xmtn-propagate-conflicts-buffer data))
|
|
)
|
|
|
|
(with-current-buffer (xmtn-propagate-data-conflicts-buffer data)
|
|
(if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-count)
|
|
(if (< 0 xmtn-conflicts-resolved-internal-count)
|
|
'need-review-resolve-internal
|
|
'ok)
|
|
'need-resolve))))
|
|
|
|
(defun xmtn-propagate-refresh-one (data refresh-local-changes)
|
|
"Refresh DATA."
|
|
(let ((from-work (xmtn-propagate-from-work data))
|
|
(to-work (xmtn-propagate-to-work data)))
|
|
|
|
(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
|
|
(setf (xmtn-propagate-data-from-head-rev data) (nth 0 heads))
|
|
(if (string= (xmtn-propagate-data-from-head-rev data) from-base-rev)
|
|
(setf (xmtn-propagate-data-from-heads data) 'at-head)
|
|
(setf (xmtn-propagate-data-from-heads data) 'need-update)))
|
|
(t
|
|
(setf (xmtn-propagate-data-from-head-rev data) nil)
|
|
(setf (xmtn-propagate-data-from-heads data) 'need-merge))))
|
|
|
|
(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
|
|
(setf (xmtn-propagate-data-to-head-rev data) (nth 0 heads))
|
|
(if (string= (xmtn-propagate-data-to-head-rev data) to-base-rev)
|
|
(setf (xmtn-propagate-data-to-heads data) 'at-head)
|
|
(setf (xmtn-propagate-data-to-heads data) 'need-update)))
|
|
(t
|
|
(setf (xmtn-propagate-data-to-head-rev data) nil)
|
|
(setf (xmtn-propagate-data-to-heads data) 'need-merge))))
|
|
|
|
(setf (xmtn-propagate-data-propagate-needed data)
|
|
(xmtn-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-commit)
|
|
(setf (xmtn-propagate-data-from-local-changes data) (xmtn-automate-local-changes from-work)))
|
|
(ok nil))
|
|
|
|
(ecase (xmtn-propagate-data-to-local-changes data)
|
|
((need-scan need-commit)
|
|
(setf (xmtn-propagate-data-to-local-changes data) (xmtn-automate-local-changes to-work)))
|
|
(ok nil))))
|
|
|
|
(if (xmtn-propagate-data-propagate-needed data)
|
|
(progn
|
|
(if refresh-local-changes
|
|
(progn
|
|
(xmtn-propagate-kill-conflicts-buffer data)
|
|
(xmtn-conflicts-clean (xmtn-propagate-to-work data))))
|
|
|
|
(setf (xmtn-propagate-data-conflicts data)
|
|
(xmtn-propagate-conflicts data)))
|
|
|
|
;; can't compute conflicts if propagate not needed
|
|
(setf (xmtn-propagate-data-conflicts data) 'need-scan))
|
|
|
|
(setf (xmtn-propagate-data-need-refresh data) nil))
|
|
|
|
;; return non-nil to refresh display as we go along
|
|
t)
|
|
|
|
(defun xmtn-propagate-refresh ()
|
|
"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 current-prefix-arg)
|
|
;; leaves point at (point-min)
|
|
(xmtn-propagate-next t)
|
|
(message "done"))
|
|
|
|
(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 &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): ")
|
|
(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*"))
|
|
(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
|
|
(concat
|
|
(format "From root : %s\n" xmtn-propagate-from-root)
|
|
(format " To root : %s\n" xmtn-propagate-to-root)
|
|
)
|
|
"")
|
|
(dolist (workspace from-workspaces)
|
|
(if (member workspace to-workspaces)
|
|
(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): ")
|
|
(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*"))
|
|
;; default-directory is wrong if buffer is reused
|
|
(setq default-directory to-work)
|
|
(setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../")))
|
|
(setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../")))
|
|
(setq xmtn-propagate-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)
|
|
|
|
;; end of file
|