comparison lisp/vc-bzr.el @ 106387:e01e9655414f

Add support for bzr shelve/unshelve. * vc-bzr.el (vc-bzr-shelve-map, vc-bzr-shelve-menu-map) (vc-bzr-extra-menu-map): New variables. (vc-bzr-extra-menu, vc-bzr-extra-status-menu, vc-bzr-shelve) (vc-bzr-shelve-apply, vc-bzr-shelve-list) (vc-bzr-shelve-get-at-point, vc-bzr-shelve-delete-at-point) (vc-bzr-shelve-apply-at-point, vc-bzr-shelve-menu): New functions. (vc-bzr-dir-extra-headers): Display shelves.

106386:d1166d927ca2

  "Return a list of conses (file . state) for DIR."
  (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
  (vc-exec-after
   `(vc-bzr-after-dir-status (quote ,update-function))))

(defun vc-bzr-dir-extra-headers (dir)
  (let*
      ((str (with-temp-buffer
	      (vc-bzr-command "info" t 0 dir)
	      (buffer-string)))
       (light-checkout
	(when (string-match ".+light checkout root: \\(.+\\)$" str)
	  (match-string 1 str)))
       (light-checkout-branch
	(when light-checkout

      (when light-checkout-branch
	(concat
	 (propertize "Checkout of branch : " 'face 'font-lock-type-face)
	 (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
	 "\n")))))

;;; Revision completion

(eval-and-compile
  (defconst vc-bzr-revision-keywords

106387:e01e9655414f

  "Return a list of conses (file . state) for DIR."
  (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
  (vc-exec-after
   `(vc-bzr-after-dir-status (quote ,update-function))))

(defvar vc-bzr-shelve-map
  (let ((map (make-sparse-keymap)))
    ;; Turn off vc-dir marking
    (define-key map [mouse-2] 'ignore)

    (define-key map [down-mouse-3] 'vc-bzr-shelve-menu)
    (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point)
    ;; (define-key map "=" 'vc-bzr-shelve-show-at-point)
    ;; (define-key map "\C-m" 'vc-bzr-shelve-show-at-point)
    (define-key map "A" 'vc-bzr-shelve-apply-at-point)
    map))

(defvar vc-bzr-shelve-menu-map
  (let ((map (make-sparse-keymap "Bzr Shelve")))
    (define-key map [de]
      '(menu-item "Delete shelf" vc-bzr-shelve-delete-at-point
		  :help "Delete the current shelf"))
    (define-key map [ap]
      '(menu-item "Apply shelf" vc-bzr-shelve-apply-at-point
		  :help "Apply the current shelf"))
    ;; (define-key map [sh]
    ;;   '(menu-item "Show shelve" vc-bzr-shelve-show-at-point
    ;; 		  :help "Show the contents of the current shelve"))
    map))

(defvar vc-bzr-extra-menu-map
  (let ((map (make-sparse-keymap)))
    (define-key map [bzr-sh]
      '(menu-item "Shelve..." vc-bzr-shelve
		  :help "Shelve changes"))
    map))

(defun vc-bzr-extra-menu () vc-bzr-extra-menu-map)

(defun vc-bzr-extra-status-menu () vc-bzr-extra-menu-map)

(defun vc-bzr-dir-extra-headers (dir)
  (let*
      ((str (with-temp-buffer
	      (vc-bzr-command "info" t 0 dir)
	      (buffer-string)))
       (shelve (vc-bzr-shelve-list))
       (shelve-help-echo "Use M-x vc-bzr-shelve to create shelves")
       (light-checkout
	(when (string-match ".+light checkout root: \\(.+\\)$" str)
	  (match-string 1 str)))
       (light-checkout-branch
	(when light-checkout

      (when light-checkout-branch
	(concat
	 (propertize "Checkout of branch : " 'face 'font-lock-type-face)
	 (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
	 "\n")))))
     (if shelve
	 (concat
	  (propertize "Shelves            :\n" 'face 'font-lock-type-face
		      'help-echo shelve-help-echo)
	  (mapconcat
	   (lambda (x)
	     (propertize x
			 'face 'font-lock-variable-name-face
			 'mouse-face 'highlight
			 'help-echo "mouse-3: Show shelve menu\nA: Apply shelf\nC-k: Delete shelf"
			 'keymap vc-bzr-shelve-map))
	   shelve "\n"))
       (concat
	(propertize "Shelves            : " 'face 'font-lock-type-face
		    'help-echo shelve-help-echo)
	(propertize "No shelved changes"
		    'help-echo shelve-help-echo
		    'face 'font-lock-variable-name-face))))))

(defun vc-bzr-shelve (name)
  "Create a shelve."
  (interactive "sShelf name: ")
  (let ((root (vc-bzr-root default-directory)))
    (when root
      (vc-bzr-command "shelve" nil 0 nil "--all" "-m" name)
      (vc-resynch-buffer root t t))))

;; (defun vc-bzr-shelve-show (name)
;;   "Show the contents of shelve NAME."
;;   (interactive "sShelve name: ")
;;   (vc-setup-buffer "*vc-bzr-shelve*")
;;   ;; FIXME: how can you show the contents of a shelf?
;;   (vc-bzr-command "shelve" "*vc-bzr-shelve*" 'async nil name)
;;   (set-buffer "*vc-bzr-shelve*")
;;   (diff-mode)
;;   (setq buffer-read-only t)
;;   (pop-to-buffer (current-buffer)))

(defun vc-bzr-shelve-apply (name)
  "Apply shelve NAME."
  (interactive "sApply shelf: ")
  (vc-bzr-command "unshelve" "*vc-bzr-shelve*" 0 nil "--apply" name)
  (vc-resynch-buffer (vc-bzr-root default-directory) t t))

(defun vc-bzr-shelve-list ()
  (with-temp-buffer
    (vc-bzr-command "shelve" (current-buffer) 1 nil "--list" "-q")
    (delete
     ""
     (split-string
      (buffer-substring (point-min) (point-max))
      "\n"))))

(defun vc-bzr-shelve-get-at-point (point)
  (save-excursion
    (goto-char point)
    (beginning-of-line)
    (if (looking-at "^ +\\([0-9]+\\):")
	(match-string 1)
      (error "Cannot find shelf at point"))))

(defun vc-bzr-shelve-delete-at-point ()
  (interactive)
  (let ((shelve (vc-bzr-shelve-get-at-point (point))))
    (when (y-or-n-p (format "Remove shelf %s ?" shelve))
      (vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve)
      (vc-dir-refresh))))

;; (defun vc-bzr-shelve-show-at-point ()
;;   (interactive)
;;   (vc-bzr-shelve-show (vc-bzr-shelve-get-at-point (point))))

(defun vc-bzr-shelve-apply-at-point ()
  (interactive)
  (vc-bzr-shelve-apply (vc-bzr-shelve-get-at-point (point))))

(defun vc-bzr-shelve-menu (e)
  (interactive "e")
  (vc-dir-at-event e (popup-menu vc-bzr-shelve-menu-map e)))

;;; Revision completion

(eval-and-compile
  (defconst vc-bzr-revision-keywords