X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/11b4001c8ffddf9cdde106409287f2387fd2cd83..b336bfcdf39f1e4d35bff4a7bd01d3b4bca8f516:/lisp/vc-bzr.el diff --git a/lisp/vc-bzr.el b/lisp/vc-bzr.el index 2fa1ee2509..8396547bdc 100644 --- a/lisp/vc-bzr.el +++ b/lisp/vc-bzr.el @@ -1,8 +1,9 @@ ;;; vc-bzr.el --- VC backend for the bzr revision control system -;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. -;; Author: Dave Love , Riccardo Murri +;; Author: Dave Love +;; Riccardo Murri ;; Keywords: tools ;; Created: Sept 2006 ;; Version: 2008-01-04 (Bzr revno 25) @@ -34,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. @@ -70,14 +71,16 @@ :type 'string) (defcustom vc-bzr-diff-switches nil - "String/list of strings specifying extra switches for bzr diff under VC." - :type '(choice (const :tag "None" nil) + "String or list of strings specifying switches for bzr diff under VC. +If nil, use the value of `vc-diff-switches'. If t, use no switches." + :type '(choice (const :tag "Unspecified" nil) + (const :tag "None" t) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) :group 'vc-bzr) (defcustom vc-bzr-log-switches nil - "String/list of strings specifying extra switches for `bzr log' under VC." + "String or list of strings specifying switches for bzr log under VC." :type '(choice (const :tag "None" nil) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) @@ -131,7 +134,8 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and (with-temp-buffer (set-buffer-multibyte nil) (let ((prog sha1-program) - (args nil)) + (args nil) + process-file-side-effects) (when (consp prog) (setq args (cdr prog)) (setq prog (car prog))) @@ -140,7 +144,7 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and (defun vc-bzr-state-heuristic (file) "Like `vc-bzr-state' but hopefully without running Bzr." - ;; `bzr status' is excrutiatingly slow with large histories and + ;; `bzr status' was excrutiatingly slow with large histories and ;; pending merges, so try to avoid using it until they fix their ;; performance problems. ;; This function tries first to parse Bzr internal file @@ -155,50 +159,64 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and ;; This looks at internal files. May break if they change ;; their format. (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) - (if (not (file-readable-p dirstate)) - (vc-bzr-state file) ; Expensive. - (with-temp-buffer - (insert-file-contents dirstate) - (goto-char (point-min)) - (if (not (looking-at "#bazaar dirstate flat format 3")) - (vc-bzr-state file) ; Some other unknown format? - (let* ((relfile (file-relative-name file root)) - (reldir (file-name-directory relfile))) - (if (re-search-forward - (concat "^\0" - (if reldir (regexp-quote - (directory-file-name reldir))) - "\0" - (regexp-quote (file-name-nondirectory relfile)) - "\0" - "[^\0]*\0" ;id? - "\\([^\0]*\\)\0" ;"a/f/d", a=removed? - "[^\0]*\0" ;sha1 (empty if conflicted)? - "\\([^\0]*\\)\0" ;size? - "[^\0]*\0" ;"y/n", executable? - "[^\0]*\0" ;? - "\\([^\0]*\\)\0" ;"a/f/d" a=added? - "\\([^\0]*\\)\0" ;sha1 again? - "[^\0]*\0" ;size again? - "[^\0]*\0" ;"y/n", executable again? - "[^\0]*\0" ;last revid? - ;; There are more fields when merges are pending. - ) - nil t) - ;; Apparently the second sha1 is the one we want: when - ;; there's a conflict, the first sha1 is absent (and the - ;; first size seems to correspond to the file with - ;; 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)) - (nth 7 (file-attributes file))) - (equal (match-string 4) - (vc-bzr-sha1 file))) - 'up-to-date) - (t 'edited)) - 'unregistered))))))))) + (condition-case nil + (with-temp-buffer + (insert-file-contents dirstate) + (goto-char (point-min)) + (if (not (looking-at "#bazaar dirstate flat format 3")) + (vc-bzr-state file) ; Some other unknown format? + (let* ((relfile (file-relative-name file root)) + (reldir (file-name-directory relfile))) + (if (re-search-forward + (concat "^\0" + (if reldir (regexp-quote + (directory-file-name reldir))) + "\0" + (regexp-quote (file-name-nondirectory relfile)) + "\0" + "[^\0]*\0" ;id? + "\\([^\0]*\\)\0" ;"a/f/d", a=removed? + "\\([^\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" ;"y/n", executable again? + "[^\0]*\0" ;last revid? + ;; There are more fields when merges are pending. + ) + nil t) + ;; Apparently the second sha1 is the one we want: when + ;; there's a conflict, the first sha1 is absent (and the + ;; first size seems to correspond to the file with + ;; conflict markers). + (cond + ((eq (char-after (match-beginning 1)) ?a) 'removed) + ((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 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)))) + ;; Either the dirstate file can't be read, or the sha1 + ;; executable is missing, or ... + ;; In either case, recent versions of Bzr aren't that slow + ;; any more. + (error (vc-bzr-state file))))))) + (defun vc-bzr-registered (file) "Return non-nil if FILE is registered with bzr." @@ -324,7 +342,40 @@ If any error occurred in running `bzr status', then return nil." (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir))) ;; This looks at internal files to avoid forking a bzr process. ;; May break if they change their format. - (if (file-exists-p branch-format-file) + (if (and (file-exists-p branch-format-file) + ;; For lightweight checkouts (obtained with bzr checkout --lightweight) + ;; the branch-format-file does not contain the revision + ;; information, we need to look up the branch-format-file + ;; in the place where the lightweight checkout comes + ;; from. We only do that if it's a local file. + (let ((location-fname (expand-file-name + (concat vc-bzr-admin-dirname + "/branch/location") rootdir))) + ;; The existence of this file is how we distinguish + ;; lightweight checkouts. + (if (file-exists-p location-fname) + (with-temp-buffer + (insert-file-contents location-fname) + ;; 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) (goto-char (point-min)) @@ -335,11 +386,13 @@ If any error occurred in running `bzr status', then return nil." ;; count lines in .bzr/branch/revision-history (insert-file-contents revhistory-file) (number-to-string (count-lines (line-end-position) (point-max)))) - ((looking-at "Bazaar Branch Format 6 (bzr 0.15)") + ((or + (looking-at "Bazaar Branch Format 6 (bzr 0.15)") + (looking-at "Bazaar Branch Format 7 (needs bzr 1.6)")) ;; revno is the first number in .bzr/branch/last-revision (insert-file-contents lastrev-file) - (if (re-search-forward "[0-9]+" nil t) - (buffer-substring (match-beginning 0) (match-end 0)))))) + (when (re-search-forward "[0-9]+" nil t) + (buffer-substring (match-beginning 0) (match-end 0)))))) ;; fallback to calling "bzr revno" (lexical-let* ((result (vc-bzr-command-discarding-stderr @@ -425,26 +478,35 @@ 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. (require 'add-log) (set (make-local-variable 'log-view-per-file-logs) nil) - (set (make-local-variable 'log-view-file-re) "^Working file:[ \t]+\\(.+\\)") + (set (make-local-variable 'log-view-file-re) "\\`a\\`") (set (make-local-variable 'log-view-message-re) - "^ *-+\n *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)") + (if vc-short-log + "^ *\\([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. - (append `((,log-view-message-re . 'log-view-message-face)) - ;; log-view-font-lock-keywords - '(("^ *committer: \ + (if vc-short-log + (append `((,log-view-message-re + (1 'log-view-message-face) + (2 'change-log-name) + (3 'change-log-date) + (4 'change-log-list nil lax)))) + (append `((,log-view-message-re . 'log-view-message-face)) + ;; log-view-font-lock-keywords + '(("^ *\\(?:committer\\|author\\): \ \\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face)))))) + (1 'change-log-name) + (2 'change-log-email)) + ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face))))))) -(defun vc-bzr-print-log (files &optional buffer) ; get buffer arg in Emacs 22 +(defun vc-bzr-print-log (files buffer &optional shortlog start-revision limit) "Get bzr change log for FILES into specified BUFFER." ;; `vc-do-command' creates the buffer, but we need it before running ;; the command. @@ -454,22 +516,22 @@ REV non-nil gets an error." ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so ;; the log display may not what the user wants - but I see no other ;; way of getting the above regexps working. - (dolist (file files) - (vc-exec-after - `(let ((inhibit-read-only t)) - (with-current-buffer buffer - ;; Insert the file name so that log-view.el can find it. - (insert "Working file: " ',file "\n")) ;; Like RCS/CVS. - (apply 'vc-bzr-command "log" ',buffer 'async ',file - ',(if (stringp vc-bzr-log-switches) - (list vc-bzr-log-switches) - vc-bzr-log-switches)))))) + (with-current-buffer buffer + (apply 'vc-bzr-command "log" buffer 'async files + (append + (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-show-log-entry (revision) "Find entry for patch name REVISION in bzr change log buffer." (goto-char (point-min)) (when revision - (let (case-fold-search) + (let (case-fold-search + found) (if (re-search-forward ;; "revno:" can appear either at the beginning of a line, ;; or indented. @@ -477,13 +539,17 @@ REV non-nil gets an error." ;; The revision can contain ".", quote it so that it ;; does not interfere with regexp matching. (regexp-quote revision) "$") nil t) - (beginning-of-line 0) - (goto-char (point-min)))))) + (progn + (beginning-of-line 0) + (setq found t)) + (goto-char (point-min))) + found))) (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) " ") @@ -517,32 +583,43 @@ REV non-nil gets an error." "Prepare BUFFER for `vc-annotate' on FILE. Each line is tagged with the revision number, which has a `help-echo' property containing author and date information." - (apply #'vc-bzr-command "annotate" buffer 0 file "--long" "--all" + (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all" (if revision (list "-r" revision))) - (with-current-buffer buffer - ;; Store the tags for the annotated source lines in a hash table - ;; to allow saving space by sharing the text properties. - (setq vc-bzr-annotation-table (make-hash-table :test 'equal)) - (goto-char (point-min)) - (while (re-search-forward "^\\( *[0-9.]+ *\\) \\([^\n ]+\\) +\\([0-9]\\{8\\}\\) |" - nil t) - (let* ((rev (match-string 1)) - (author (match-string 2)) - (date (match-string 3)) - (key (match-string 0)) - (tag (gethash key vc-bzr-annotation-table))) - (unless tag - (setq tag (propertize rev 'help-echo (concat "Author: " author - ", date: " date) - 'mouse-face 'highlight)) - (puthash key tag vc-bzr-annotation-table)) - (replace-match "") - (insert tag " |"))))) + (lexical-let ((table (make-hash-table :test 'equal))) + (set-process-filter + (get-buffer-process buffer) + (lambda (proc string) + (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) + (let* ((rev (match-string 1 string)) + (author (match-string 2 string)) + (date (match-string 3 string)) + (key (substring string (match-beginning 0) + (match-beginning 4))) + (line (match-string 4 string)) + (tag (gethash key table)) + (inhibit-read-only t)) + (setq string (substring string (match-end 0))) + (unless tag + (setq tag + (propertize + (format "%s %-7.7s" rev author) + 'help-echo (format "Revision: %d, author: %s, date: %s" + (string-to-number rev) + author date) + 'mouse-face 'highlight)) + (puthash key tag table)) + (goto-char (process-mark proc)) + (insert tag line) + (move-marker (process-mark proc) (point)))) + (process-put proc :vc-left-over string))))))) (declare-function vc-annotate-convert-time "vc-annotate" (time)) (defun vc-bzr-annotate-time () - (when (re-search-forward "^ *[0-9.]+ +|" nil t) + (when (re-search-forward "^ *[0-9.]+ +[^\n ]* +|" 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))) @@ -557,7 +634,7 @@ property containing author and date information." Return nil if current line isn't annotated." (save-excursion (beginning-of-line) - (if (looking-at " *\\([0-9.]+\\) *| ") + (if (looking-at "^ *\\([0-9.]+\\) +[^\n ]* +|") (match-string-no-properties 1)))) (defun vc-bzr-command-discarding-stderr (command &rest args) @@ -571,24 +648,16 @@ stream. Standard error output is discarded." (apply #'process-file command nil (list (current-buffer) nil) nil args) (buffer-substring (point-min) (point-max))))) -(defun vc-bzr-prettify-state-info (file) - "Bzr-specific version of `vc-prettify-state-info'." - (if (eq 'edited (vc-state file)) - (concat "(" (symbol-name (or (vc-file-getprop file 'vc-bzr-state) - 'edited)) ")") - ;; else fall back to default vc.el representation - (vc-default-prettify-state-info 'Bzr file))) - (defstruct (vc-bzr-extra-fileinfo (:copier nil) (:constructor vc-bzr-create-extra-fileinfo (extra-name)) (:conc-name vc-bzr-extra-fileinfo->)) extra-name) ;; original name for rename targets, new name for -(defun vc-bzr-status-printer (info) +(defun vc-bzr-dir-printer (info) "Pretty-printer for the vc-dir-fileinfo structure." (let ((extra (vc-dir-fileinfo->extra info))) - (vc-default-status-printer 'Bzr info) + (vc-default-dir-printer 'Bzr info) (when extra (insert (propertize (format " (renamed from %s)" @@ -596,7 +665,7 @@ stream. Standard error output is discarded." 'face 'font-lock-comment-face))))) ;; FIXME: this needs testing, it's probably incomplete. -(defun vc-bzr-after-dir-status (update-function) +(defun vc-bzr-after-dir-status (update-function relative-dir) (let ((status-str nil) (translation '(("+N " . added) ("-D " . removed) @@ -608,13 +677,20 @@ 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) + ;; If the tree is not up to date, bzr will print this warning: + ;; working tree is out of date, run 'bzr update' + ;; ignore it. + ;; 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)) @@ -638,17 +714,18 @@ stream. Standard error output is discarded." (when entry (setf (nth 1 entry) 'conflict)))) ((eq translated 'renamed) - (re-search-forward "R \\(.*\\) => \\(.*\\)$" (line-end-position) t) - (let ((new-name (match-string 2)) - (old-name (match-string 1))) + (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 (vc-bzr-create-extra-fileinfo old-name)) result))) ;; do nothing for non existent files ((eq translated 'not-found)) (t - (push (list (buffer-substring-no-properties - (+ (point) 4) - (line-end-position)) + (push (list (file-relative-name + (buffer-substring-no-properties + (+ (point) 4) + (line-end-position)) relative-dir) translated) result))) (forward-line)) (funcall update-function result))) @@ -657,15 +734,209 @@ stream. Standard error output is discarded." "Return a list of conses (file . state) for DIR." (vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S") (vc-exec-after - `(vc-bzr-after-dir-status (quote ,update-function)))) + `(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)))) + `(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 "P" '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 [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-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-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 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-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))) + +(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 + (defconst vc-bzr-revision-keywords + '("revno" "revid" "last" "before" + "tag" "date" "ancestor" "branch" "submit"))) + (defun vc-bzr-revision-completion-table (files) (lexical-let ((files files)) ;; What about using `files'?!? --Stef @@ -674,14 +945,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)) - ;; FIXME: only allow directories. - ;; FIXME: don't allow envvars. - 'read-file-name-internal + (apply-partially + 'completion-table-with-predicate + 'completion-file-name-table + 'file-directory-p t) (substring string (match-end 0)) - ;; Dropping `pred'. Maybe we should - ;; just stash it in - ;; `read-file-name-predicate'? - nil + pred action)) ((string-match "\\`\\(before\\):" string) (completion-table-with-context (substring string 0 (match-end 0)) @@ -692,7 +961,8 @@ stream. Standard error output is discarded." ((string-match "\\`\\(tag\\):" string) (let ((prefix (substring string 0 (match-end 0))) (tag (substring string (match-end 0))) - (table nil)) + (table nil) + process-file-side-effects) (with-temp-buffer ;; "bzr-1.2 tags" is much faster with --show-ids. (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids") @@ -703,20 +973,25 @@ stream. Standard error output is discarded." (push (match-string-no-properties 1) table))) (completion-table-with-context prefix table tag pred action))) - ((string-match "\\`\\(revid\\):" string) - ;; FIXME: How can I get a list of revision ids? - ) - ((eq (car-safe action) 'boundaries) - (list* 'boundaries - (string-match "[^:]*\\'" string) - (string-match ":" (cdr action)))) + ((string-match "\\`\\([a-z]+\\):" string) + ;; no actual completion for the remaining keywords. + (completion-table-with-context (substring string 0 (match-end 0)) + (if (member (match-string 1 string) + vc-bzr-revision-keywords) + ;; If it's a valid keyword, + ;; use a non-empty table to + ;; indicate it. + '("") nil) + (substring string (match-end 0)) + pred + action)) (t ;; Could use completion-table-with-terminator, except that it ;; currently doesn't work right w.r.t pcm and doesn't give ;; the *Completions* output we want. - (complete-with-action action '("revno:" "revid:" "last:" "before:" - "tag:" "date:" "ancestor:" "branch:" - "submit:") + (complete-with-action action (eval-when-compile + (mapcar (lambda (s) (concat s ":")) + vc-bzr-revision-keywords)) string pred)))))) (eval-after-load "vc"