+ `(vc-bzr-after-dir-status (quote ,update-function)
+ ;; "bzr status" results are relative to
+ ;; the bzr root directory, NOT to the
+ ;; directory "bzr status" was invoked in.
+ ;; Ugh.
+ ;; We pass the relative directory here so
+ ;; that `vc-bzr-after-dir-status' can
+ ;; frob the results accordingly.
+ (file-relative-name ,dir (vc-bzr-root ,dir)))))
+
+(defun vc-bzr-dir-status-files (dir files default-state update-function)
+ "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)
+ (file-relative-name ,dir (vc-bzr-root ,dir)))))
+
+(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-and-keep-at-point)
+ (define-key map "P" 'vc-bzr-shelve-apply-at-point)
+ (define-key map "S" 'vc-bzr-shelve-snapshot)
+ 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 and keep shelf" vc-bzr-shelve-apply-and-keep-at-point
+ :help "Apply the current shelf and keep it"))
+ (define-key map [po]
+ '(menu-item "Apply and remove shelf (pop)" vc-bzr-shelve-apply-at-point
+ :help "Apply the current shelf and remove it"))
+ (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-sn]
+ '(menu-item "Shelve a snapshot" vc-bzr-shelve-snapshot
+ :help "Shelve the current state of the tree and keep the current state"))
+ (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")
+ (root-dir (vc-bzr-root dir))
+ (pending-merge
+ ;; FIXME: looking for .bzr/checkout/merge-hashes is not a
+ ;; reliable method to detect pending merges, disable this
+ ;; until a proper solution is implemented.
+ (and nil
+ (file-exists-p
+ (expand-file-name ".bzr/checkout/merge-hashes" root-dir))))
+ (pending-merge-help-echo
+ (format "A merge has been performed.\nA commit from the top-level directory (%s)\nis required before being able to check in anything else" root-dir))
+ (light-checkout
+ (when (string-match ".+light checkout root: \\(.+\\)$" str)
+ (match-string 1 str)))
+ (light-checkout-branch
+ (when light-checkout
+ (when (string-match ".+checkout of branch: \\(.+\\)$" str)
+ (match-string 1 str)))))
+ (concat
+ (propertize "Parent branch : " 'face 'font-lock-type-face)
+ (propertize
+ (if (string-match "parent branch: \\(.+\\)$" str)
+ (match-string 1 str)
+ "None")
+ 'face 'font-lock-variable-name-face)
+ "\n"
+ (when light-checkout
+ (concat
+ (propertize "Light checkout root: " 'face 'font-lock-type-face)
+ (propertize light-checkout 'face 'font-lock-variable-name-face)
+ "\n"))
+ (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"))
+ (when pending-merge
+ (concat
+ (propertize "Warning : " 'face 'font-lock-warning-face
+ 'help-echo pending-merge-help-echo)
+ (propertize "Pending merges, commit recommended before any other action"
+ 'help-echo pending-merge-help-echo
+ 'face 'font-lock-warning-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 and keep shelf\nP: Apply and remove shelf (pop)\nS: Snapshot to a 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-diff*")
+ ;; FIXME: how can you show the contents of a shelf?
+ (vc-bzr-command "unshelve" "*vc-diff*" 'async nil "--preview" name)
+ (set-buffer "*vc-diff*")
+ (diff-mode)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer)))
+
+(defun vc-bzr-shelve-apply (name)
+ "Apply shelve NAME and remove it afterwards."
+ (interactive "sApply (and remove) shelf: ")
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" name)
+ (vc-resynch-buffer (vc-bzr-root default-directory) t t))
+
+(defun vc-bzr-shelve-apply-and-keep (name)
+ "Apply shelve NAME and keep it afterwards."
+ (interactive "sApply (and keep) shelf: ")
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep" name)
+ (vc-resynch-buffer (vc-bzr-root default-directory) t t))
+
+(defun vc-bzr-shelve-snapshot ()
+ "Create a stash with the current tree state."
+ (interactive)
+ (vc-bzr-command "shelve" nil 0 nil "--all" "-m"
+ (let ((ct (current-time)))
+ (concat
+ (format-time-string "Snapshot on %Y-%m-%d" ct)
+ (format-time-string " at %H:%M" ct))))
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep")
+ (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-apply-and-keep-at-point ()
+ (interactive)
+ (vc-bzr-shelve-apply-and-keep (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)))
+
+(defun vc-bzr-revision-table (files)
+ (let ((vc-bzr-revisions '())
+ (default-directory (file-name-directory (car files))))
+ (with-temp-buffer
+ (vc-bzr-command "log" t 0 files "--line")
+ (let ((start (point-min))
+ (loglines (buffer-substring-no-properties (point-min) (point-max))))
+ (while (string-match "^\\([0-9]+\\):" loglines)
+ (push (match-string 1 loglines) vc-bzr-revisions)
+ (setq start (+ start (match-end 0)))
+ (setq loglines (buffer-substring-no-properties start (point-max))))))
+ vc-bzr-revisions))
+
+(defun vc-bzr-conflicted-files (dir)
+ (let ((default-directory (vc-bzr-root dir))
+ (files ()))
+ (with-temp-buffer
+ (vc-bzr-command "status" t 0 default-directory)
+ (goto-char (point-min))
+ (when (re-search-forward "^conflicts:\n" nil t)
+ (while (looking-at " \\(?:Text conflict in \\(.*\\)\\|.*\\)\n")
+ (if (match-end 1)
+ (push (expand-file-name (match-string 1)) files))
+ (goto-char (match-end 0)))))
+ files))