X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/460f6e7ced30ef7dbbf05284f0ca28f94e613c71..29bbcfa7054e69db0dbe8250af2c809b39ecb54d:/lisp/vc-bzr.el diff --git a/lisp/vc-bzr.el b/lisp/vc-bzr.el index fff4eca57f..41c9663fc7 100644 --- a/lisp/vc-bzr.el +++ b/lisp/vc-bzr.el @@ -1,6 +1,6 @@ ;;; 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, 2011 Free Software Foundation, Inc. ;; Author: Dave Love ;; Riccardo Murri @@ -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. @@ -176,13 +176,13 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and "\0" "[^\0]*\0" ;id? "\\([^\0]*\\)\0" ;"a/f/d", a=removed? - "[^\0]*\0" ;sha1 (empty if conflicted)? - "\\([^\0]*\\)\0" ;size? + "\\([^\0]*\\)\0" ;sha1 (empty if conflicted)? + "\\([^\0]*\\)\0" ;size?p "[^\0]*\0" ;"y/n", executable? "[^\0]*\0" ;? "\\([^\0]*\\)\0" ;"a/f/d" a=added? "\\([^\0]*\\)\0" ;sha1 again? - "[^\0]*\0" ;size again? + "\\([^\0]*\\)\0" ;size again? "[^\0]*\0" ;"y/n", executable again? "[^\0]*\0" ;last revid? ;; There are more fields when merges are pending. @@ -194,11 +194,20 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and ;; conflict markers). (cond ((eq (char-after (match-beginning 1)) ?a) 'removed) - ((eq (char-after (match-beginning 3)) ?a) 'added) - ((and (eq (string-to-number (match-string 2)) + ((eq (char-after (match-beginning 4)) ?a) 'added) + ((or (and (eq (string-to-number (match-string 3)) (nth 7 (file-attributes file))) - (equal (match-string 4) + (equal (match-string 5) (vc-bzr-sha1 file))) + (and + ;; It looks like for lightweight + ;; checkouts \2 is empty and we need to + ;; look for size in \6. + (eq (match-beginning 2) (match-end 2)) + (eq (string-to-number (match-string 6)) + (nth 7 (file-attributes file))) + (equal (match-string 5) + (vc-bzr-sha1 file)))) 'up-to-date) (t 'edited)) 'unregistered)))) @@ -347,9 +356,25 @@ If any error occurred in running `bzr status', then return nil." (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) @@ -426,11 +451,17 @@ or a superior directory.") "Unregister FILE from bzr." (vc-bzr-command "remove" nil 0 file "--keep")) +(declare-function log-edit-extract-headers "log-edit" (headers string)) + (defun vc-bzr-checkin (files rev comment) "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 (cons "-m" (log-edit-extract-headers '(("Author" . "--author") + ("Date" . "--commit-time") + ("Fixes" . "--fixes")) + comment)))) (defun vc-bzr-find-revision (file rev buffer) "Fetch revision REV of file FILE and put it into BUFFER." @@ -453,7 +484,6 @@ REV non-nil gets an error." (defvar log-view-font-lock-keywords) (defvar log-view-current-tag-function) (defvar log-view-per-file-logs) -(defvar vc-short-log) (define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View" (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack. @@ -461,13 +491,13 @@ REV non-nil gets an error." (set (make-local-variable 'log-view-per-file-logs) nil) (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\\]\\)?" + (if (eq vc-log-view-type 'short) + "^ *\\([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 ;; value of log-view-message-re only since Emacs-23. - (if vc-short-log + (if (eq vc-log-view-type 'short) (append `((,log-view-message-re (1 'log-view-message-face) (2 'change-log-name) @@ -475,7 +505,7 @@ REV non-nil gets an error." (4 'change-log-list nil lax)))) (append `((,log-view-message-re . 'log-view-message-face)) ;; log-view-font-lock-keywords - '(("^ *committer: \ + '(("^ *\\(?:committer\\|author\\): \ \\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]" (1 'change-log-name) (2 'change-log-email)) @@ -494,13 +524,21 @@ REV non-nil gets an error." (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) (list vc-bzr-log-switches) vc-bzr-log-switches))))) +(defun vc-bzr-log-incoming (buffer remote-location) + (apply 'vc-bzr-command "missing" buffer 'async nil + (list "--theirs-only" (unless (string= remote-location "") remote-location)))) + +(defun vc-bzr-log-outgoing (buffer remote-location) + (apply 'vc-bzr-command "missing" buffer 'async nil + (list "--mine-only" (unless (string= remote-location "") remote-location)))) + (defun vc-bzr-show-log-entry (revision) "Find entry for patch name REVISION in bzr change log buffer." (goto-char (point-min)) @@ -523,7 +561,8 @@ REV non-nil gets an error." (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) " ") @@ -566,7 +605,7 @@ property containing author and date information." (when (process-buffer proc) (with-current-buffer (process-buffer proc) (setq string (concat (process-get proc :vc-left-over) string)) - (while (string-match "^\\( *[0-9.]+ *\\) \\([^\n ]+\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string) + (while (string-match "^\\( *[0-9.]+ *\\) \\(.+?\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string) (let* ((rev (match-string 1 string)) (author (match-string 2 string)) (date (match-string 3 string)) @@ -593,7 +632,7 @@ property containing author and date information." (declare-function vc-annotate-convert-time "vc-annotate" (time)) (defun vc-bzr-annotate-time () - (when (re-search-forward "^ *[0-9.]+ +[^\n ]* +|" nil t) + (when (re-search-forward "^ *[0-9.]+ +.+? +|" nil t) (let ((prop (get-text-property (line-beginning-position) 'help-echo))) (string-match "[0-9]+\\'" prop) (let ((str (match-string-no-properties 0 prop))) @@ -651,9 +690,9 @@ stream. Standard error output is discarded." ;; 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) @@ -663,6 +702,8 @@ stream. Standard error output is discarded." ;; 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)) @@ -686,7 +727,7 @@ stream. Standard error output is discarded." (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 @@ -730,9 +771,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 "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 @@ -741,15 +784,21 @@ stream. Standard error output is discarded." '(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")) @@ -766,6 +815,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))) @@ -791,24 +850,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\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." @@ -818,21 +885,38 @@ 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-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." - (interactive "sApply shelf: ") - (vc-bzr-command "unshelve" "*vc-bzr-shelve*" 0 nil "--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 () @@ -859,18 +943,48 @@ 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))) +(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)) + ;;; Revision completion (eval-and-compile @@ -886,10 +1000,12 @@ stream. Standard error output is discarded." ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):" string) (completion-table-with-context (substring string 0 (match-end 0)) - 'completion-file-name-table + (apply-partially + 'completion-table-with-predicate + 'completion-file-name-table + 'file-directory-p t) (substring string (match-end 0)) - ;; Dropping `pred' for no good reason. - 'file-directory-p + pred action)) ((string-match "\\`\\(before\\):" string) (completion-table-with-context (substring string 0 (match-end 0))