;;; vc-bzr.el --- VC backend for the bzr revision control system
-;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Riccardo Murri <riccardo.murri@gmail.com>
;; 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.
(if (file-exists-p location-fname)
(with-temp-buffer
(insert-file-contents location-fname)
- (when (re-search-forward "file://\(.+\)" nil t)
- (setq branch-format-file (match-string 1))
- (file-exists-p branch-format-file)))
+ ;; If the lightweight checkout points to a
+ ;; location in the local file system, then we can
+ ;; look there for the version information.
+ (when (re-search-forward "file://\\(.+\\)" nil t)
+ (let ((l-c-parent-dir (match-string 1)))
+ (when (and (memq system-type '(ms-dos windows-nt))
+ (string-match-p "^/[[:alpha:]]:" l-c-parent-dir))
+ ;;; The non-Windows code takes a shortcut by using the host/path
+ ;;; separator slash as the start of the absolute path. That
+ ;;; does not work on Windows, so we must remove it (bug#5345)
+ (setq l-c-parent-dir (substring l-c-parent-dir 1)))
+ (setq branch-format-file
+ (expand-file-name vc-bzr-admin-branch-format-file
+ l-c-parent-dir))
+ (setq lastrev-file
+ (expand-file-name vc-bzr-admin-lastrev l-c-parent-dir))
+ ;; FIXME: maybe it's overkill to check if both these files exist.
+ (and (file-exists-p branch-format-file)
+ (file-exists-p lastrev-file)))))
t)))
(with-temp-buffer
(insert-file-contents branch-format-file)
"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."
(set (make-local-variable 'log-view-file-re) "\\`a\\`")
(set (make-local-variable 'log-view-message-re)
(if vc-short-log
- "^ *\\([0-9.]+\\) \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
+ "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
"^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)"))
(set (make-local-variable 'log-view-font-lock-keywords)
;; log-view-font-lock-keywords is careful to use the buffer-local
(with-current-buffer buffer
(apply 'vc-bzr-command "log" buffer 'async files
(append
- (when shortlog '("--short"))
+ (when shortlog '("--line"))
(when start-revision (list (format "-r..%s" start-revision)))
(when limit (list "-l" (format "%s" limit)))
(if (stringp vc-bzr-log-switches)
(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.
- (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*") 'async files
+ (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
+ (if vc-disable-async-diff 1 'async) files
"--diff-options" (mapconcat 'identity
(vc-switches 'bzr 'diff)
" ")
;; For conflicts, should we list the .THIS/.BASE/.OTHER?
("C " . conflict)
("? " . unregistered)
- ("? " . unregistered)
;; No such state, but we need to distinguish this case.
("R " . renamed)
+ ("RM " . renamed)
;; For a non existent file FOO, the output is:
;; bzr: ERROR: Path(s) do not exist: FOO
("bzr" . not-found)
;; FIXME: maybe this warning can be put in the vc-dir header...
("wor" . not-found)
;; Ignore "P " and "P." for pending patches.
+ ("P " . not-found)
+ ("P. " . not-found)
))
(translated nil)
(result nil))
(when entry
(setf (nth 1 entry) 'conflict))))
((eq translated 'renamed)
- (re-search-forward "R \\(.*\\) => \\(.*\\)$" (line-end-position) t)
+ (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
(let ((new-name (file-relative-name (match-string 2) relative-dir))
(old-name (file-relative-name (match-string 1) relative-dir)))
(push (list new-name 'edited
(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)
+ (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
'(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"))
+ '(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"))
(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)))
(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))))))
+ (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."
(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."
- (interactive "sApply shelf: ")
+ "Apply shelve NAME and remove it afterwards."
+ (interactive "sApply (and remove) 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-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")
(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)))
+(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))
+
;;; Revision completion
(eval-and-compile
HCoop / bpt / emacs.git / blobdiff