Fix default-directory for vc-root-diff.
[bpt/emacs.git] / lisp / vc-bzr.el
index 5f01d29..35c84f3 100644 (file)
@@ -35,7 +35,7 @@
 ;; Known bugs
 ;; ==========
 
-;; When edititing a symlink and *both* the symlink and its target
+;; When editing a symlink and *both* the symlink and its target
 ;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
 ;; symlink, thereby not detecting whether the actual contents
 ;; (that is, the target contents) are changed.
@@ -451,11 +451,11 @@ or a superior directory.")
   "Unregister FILE from bzr."
   (vc-bzr-command "remove" nil 0 file "--keep"))
 
-(defun vc-bzr-checkin (files rev comment)
+(defun vc-bzr-checkin (files rev comment &optional extra-args)
   "Check FILE in to bzr with log message COMMENT.
 REV non-nil gets an error."
   (if rev (error "Can't check in a specific revision with bzr"))
-  (vc-bzr-command "commit" nil 0 files "-m" comment))
+  (apply 'vc-bzr-command "commit" nil 0 files (append (list "-m" comment) extra-args)))
 
 (defun vc-bzr-find-revision (file rev buffer)
   "Fetch revision REV of file FILE and put it into BUFFER."
@@ -545,6 +545,23 @@ REV non-nil gets an error."
        (goto-char (point-min)))
       found)))
 
+(declare-function log-edit-mode "log-edit" ())
+(defvar log-edit-extra-flags)
+(defvar log-edit-before-checkin-process)
+
+(define-derived-mode vc-bzr-log-edit-mode log-edit-mode "Bzr-Log-Edit"
+  "Mode for editing Bzr commit logs.
+If a line like:
+Author: NAME
+is present in the log, it is removed, and
+--author NAME
+is passed to the bzr commit command.  Similarly with Fixes: and --fixes."
+  (set (make-local-variable 'log-edit-extra-flags) nil)
+  (set (make-local-variable 'log-edit-before-checkin-process)
+       '(("^\\(Author\\|Fixes\\):[ \t]+\\(.*\\)[ \t]*$" .
+          (list (format "--%s" (downcase (match-string 1)))
+                (match-string 2))))))
+
 (defun vc-bzr-diff (files &optional rev1 rev2 buffer)
   "VC bzr backend for diff."
   ;; `bzr diff' exits with code 1 if diff is non-empty.
@@ -758,9 +775,11 @@ stream.  Standard error output is discarded."
 
     (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 "=" '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
@@ -768,16 +787,22 @@ stream.  Standard error output is discarded."
     (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"))
+    (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"))
@@ -794,6 +819,16 @@ stream.  Standard error output is discarded."
              (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)))
@@ -819,24 +854,32 @@ stream.  Standard error output is discarded."
         (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\nP: Apply and remove shelf (pop)\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))))))
+      (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."
@@ -846,16 +889,16 @@ stream.  Standard error output is discarded."
       (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-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 "unshelve" "*vc-bzr-shelve*" 'async nil "--preview" 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 and remove it afterwards."
@@ -863,6 +906,23 @@ stream.  Standard error output is discarded."
   (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-apply-and-keep (name)
+  "Apply shelve NAME and keep it afterwards."
+  (interactive "sApply (and keep) shelf: ")
+  (vc-bzr-command "unshelve" "*vc-bzr-shelve*" 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" "*vc-bzr-shelve*" 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")
@@ -887,14 +947,18 @@ stream.  Standard error output is discarded."
       (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-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)))