X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e0607aaa2c6b33104fed475eb15452b2cdb6df03..29bbcfa7054e69db0dbe8250af2c809b39ecb54d:/lisp/vc-bzr.el diff --git a/lisp/vc-bzr.el b/lisp/vc-bzr.el index aca00409fa..41c9663fc7 100644 --- a/lisp/vc-bzr.el +++ b/lisp/vc-bzr.el @@ -1,28 +1,28 @@ ;;; 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, 2011 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) ;; URL: http://launchpad.net/vc-bzr -;; This file is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. -;; This file is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -30,26 +30,31 @@ ;; for alternate development ;; branches of `vc-bzr'. -;; Load this library to register bzr support in VC. +;; Load this library to register bzr support in VC. ;; 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. +;; (that is, the target contents) are changed. ;; See https://bugs.launchpad.net/vc-bzr/+bug/116607 ;; For an up-to-date list of bugs, please see: ;; https://bugs.launchpad.net/vc-bzr/+bugs +;;; Properties of the backend + +(defun vc-bzr-revision-granularity () 'repository) +(defun vc-bzr-checkout-model (files) 'implicit) ;;; Code: (eval-when-compile (require 'cl) - (require 'vc)) ; for vc-exec-after + (require 'vc) ;; for vc-exec-after + (require 'vc-dir)) ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. @@ -66,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)) @@ -89,7 +96,7 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) "LC_MESSAGES=C" ; Force English output process-environment))) - (apply 'vc-do-command buffer okstatus vc-bzr-program + (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program file-or-list bzr-command args))) @@ -127,16 +134,17 @@ 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))) - (apply 'call-process prog file t nil args) + (apply 'process-file prog (file-relative-name file) t nil args) (buffer-substring (point-min) (+ (point-min) 40))))) (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 @@ -151,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." @@ -210,7 +232,7 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and (lexical-let* ((filename* (expand-file-name filename)) (rootdir (vc-bzr-root filename*))) - (when rootdir + (when rootdir (file-relative-name filename* rootdir)))) (defun vc-bzr-status (file) @@ -275,7 +297,7 @@ If any error occurred in running `bzr status', then return nil." (renamed . edited) (modified . edited) (removed . removed) - (ignored . unregistered) + (ignored . ignored) (unknown . unregistered) (unchanged . up-to-date))))))) @@ -320,34 +342,67 @@ 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) + (insert-file-contents branch-format-file) (goto-char (point-min)) (cond ((or (looking-at "Bazaar-NG branch, format 0.0.4") (looking-at "Bazaar-NG branch format 5")) ;; count lines in .bzr/branch/revision-history - (insert-file-contents revhistory-file) + (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)))))) + (insert-file-contents lastrev-file) + (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 - vc-bzr-program "revno" file)) + vc-bzr-program "revno" (file-relative-name file))) (exitcode (car result)) (output (cdr result))) (cond ((eq exitcode 0) (substring output 0 -1)) (t nil)))))) -(defun vc-bzr-checkout-model (files) 'implicit) - (defun vc-bzr-create-repo () "Create a new Bzr repository." (vc-bzr-command "init" nil 0 nil)) @@ -396,14 +451,20 @@ 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)) - -(defun vc-bzr-find-version (file rev buffer) - "Fetch version REV of file FILE and put it into BUFFER." + (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." (with-current-buffer buffer (if (and rev (stringp rev) (not (string= rev ""))) (vc-bzr-command "cat" t 0 file "-r" rev) @@ -422,25 +483,35 @@ REV non-nil gets an error." (defvar log-view-file-re) (defvar log-view-font-lock-keywords) (defvar log-view-current-tag-function) +(defvar log-view-per-file-logs) (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-file-re) "^Working file:[ \t]+\\(.+\\)") + (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) - "^ *-+\n *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)") + (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. - (append `((,log-view-message-re . 'log-view-message-face)) - ;; log-view-font-lock-keywords - '(("^ *committer: \ + (if (eq vc-log-view-type 'short) + (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. @@ -450,42 +521,56 @@ 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-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)) - (let (case-fold-search) - (if (re-search-forward - ;; "revno:" can appear either at the beginning of a line, or indented. - (concat "^[ ]*-+\n[ ]*revno: " - ;; 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))))) + (when revision + (let (case-fold-search + found) + (if (re-search-forward + ;; "revno:" can appear either at the beginning of a line, + ;; or indented. + (concat "^[ ]*-+\n[ ]*revno: " + ;; The revision can contain ".", quote it so that it + ;; does not interfere with regexp matching. + (regexp-quote revision) "$") nil t) + (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 - "--diff-options" (mapconcat 'identity - (vc-diff-switches-list bzr) + (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) " ") ;; This `when' is just an optimization because bzr-1.2 is *much* ;; faster when the revision argument is not given. (when (or rev1 rev2) (list "-r" (format "%s..%s" - (or rev1 "revno:-1") + (or rev1 "revno:-1") (or rev2 "")))))) @@ -511,45 +596,58 @@ 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.]+ *\\) \\(.+?\\) +\\([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.]+ +.+? +|" 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))) (vc-annotate-convert-time (encode-time 0 0 0 - (string-to-number (substring (match-string 0 prop) 6 8)) - (string-to-number (substring (match-string 0 prop) 4 6)) - (string-to-number (substring (match-string 0 prop) 0 4)) - ))))) + (string-to-number (substring str 6 8)) + (string-to-number (substring str 4 6)) + (string-to-number (substring str 0 4)))))))) (defun vc-bzr-annotate-extract-revision-at-line () "Return revision for current line of annoation buffer, or nil. 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) @@ -560,151 +658,340 @@ containing whatever the process sent to its standard output stream. Standard error output is discarded." (with-temp-buffer (cons - (apply #'call-process command nil (list (current-buffer) nil) nil args) + (apply #'process-file command nil (list (current-buffer) nil) nil args) (buffer-substring (point-min) (point-max))))) -;; TODO: it would be nice to mark the conflicted files in VC Dired, -;; and implement a command to run ediff and `bzr resolve' once the -;; changes have been merged. -(defun vc-bzr-dir-state (dir &optional localp) - "Find the VC state of all files in DIR and its subdirectories. -Optional argument LOCALP is always ignored." - (let ((bzr-root-directory (vc-bzr-root dir)) - (at-start t) - current-bzr-state current-vc-state) - ;; Check that DIR is a bzr repository. - (unless (file-name-absolute-p bzr-root-directory) - (error "Cannot find bzr repository for directory `%s'" dir)) - ;; `bzr ls --versioned' lists all versioned files; - ;; assume they are up-to-date, unless we are given - ;; evidence of the contrary. - (setq at-start t) - (with-temp-buffer - (buffer-disable-undo) ;; Because these buffers can get huge - (vc-bzr-command "ls" t 0 nil "--versioned") - (goto-char (point-min)) - (while (or at-start - (eq 0 (forward-line))) - (setq at-start nil) - (let ((file (expand-file-name - (buffer-substring-no-properties - (line-beginning-position) (line-end-position)) - bzr-root-directory))) - ;; files are up-to-date unless they appear in the `bzr - ;; status' output below - (vc-file-setprop file 'vc-state 'up-to-date) - ;; XXX: is this correct? what happens if one - ;; mixes different SCMs in the same dir? - ;; Anyway, we're looking at the output of `bzr ls --versioned', - ;; so we know these files are registered with Bzr. - (vc-file-setprop file 'vc-backend 'Bzr)))) - ;; `bzr status' reports on added/modified/renamed and unknown/ignored files - (setq at-start t) - (with-temp-buffer - (vc-bzr-command "status" t 0 nil) - (goto-char (point-min)) - (while (or at-start - (eq 0 (forward-line))) - (setq at-start nil) - (cond - ((looking-at "^added") - (setq current-vc-state 'added) - (setq current-bzr-state 'added)) - ((looking-at "^kind changed") - (setq current-vc-state 'edited) - (setq current-bzr-state 'kindchanged)) - ((looking-at "^modified") - (setq current-vc-state 'edited) - (setq current-bzr-state 'modified)) - ((looking-at "^renamed") - (setq current-vc-state 'edited) - (setq current-bzr-state 'renamed)) - ((looking-at "^ignored") - (setq current-vc-state 'ignored) - (setq current-bzr-state 'not-versioned)) - ((looking-at "^unknown") - (setq current-vc-state 'unregistered) - (setq current-bzr-state 'not-versioned)) - ((looking-at " ") - ;; file names are indented by two spaces - (when current-vc-state - (let ((file (expand-file-name - (buffer-substring-no-properties - (match-end 0) (line-end-position)) - bzr-root-directory))) - (vc-file-setprop file 'vc-state current-vc-state) - (vc-file-setprop file 'vc-bzr-state current-bzr-state) - (when (eq 'added current-bzr-state) - (vc-file-setprop file 'vc-working-revision "0")))) - (when (eq 'not-versioned current-bzr-state) - (let ((file (expand-file-name - (buffer-substring-no-properties - (match-end 0) (line-end-position)) - bzr-root-directory))) - (vc-file-setprop file 'vc-backend 'none) - (vc-file-setprop file 'vc-state nil)))) - (t - ;; skip this part of `bzr status' output - (setq current-vc-state nil) - (setq current-bzr-state nil))))))) - -(defun vc-bzr-dired-state-info (file) - "Bzr-specific version of `vc-dired-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-dired-state-info 'Bzr file))) - -;; XXX: this needs testing, it's probably incomplete. -(defun vc-bzr-after-dir-status (update-function) +(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-dir-printer (info) + "Pretty-printer for the vc-dir-fileinfo structure." + (let ((extra (vc-dir-fileinfo->extra info))) + (vc-default-dir-printer 'Bzr info) + (when extra + (insert (propertize + (format " (renamed from %s)" + (vc-bzr-extra-fileinfo->extra-name extra)) + 'face 'font-lock-comment-face))))) + +;; FIXME: this needs testing, it's probably incomplete. +(defun vc-bzr-after-dir-status (update-function relative-dir) (let ((status-str nil) - (file nil) - (translation '(("+N" . added) - ("-D" . removed) - (" M" . edited) - ;; XXX: what about ignored files? - (" D" . missing) - ("C " . conflict) - ("? " . unregistered))) + (translation '(("+N " . added) + ("-D " . removed) + (" M " . edited) ;; file text modified + (" *" . edited) ;; execute bit changed + (" M*" . edited) ;; text modified + execute bit changed + ;; FIXME: what about ignored files? + (" D " . missing) + ;; For conflicts, should we list the .THIS/.BASE/.OTHER? + ("C " . conflict) + ("? " . 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)) (goto-char (point-min)) (while (not (eobp)) (setq status-str - (buffer-substring-no-properties (point) (+ (point) 2))) + (buffer-substring-no-properties (point) (+ (point) 3))) (setq translated (cdr (assoc status-str translation))) - ;; For conflicts the file appears twice in the listing: once - ;; with the M flag and once with the C flag, so take care not - ;; to add it twice to `result'. Ugly. - (if (eq translated 'conflict) - (let* ((file - (buffer-substring-no-properties - ;;For files with conflicts the format is: - ;;C Text conflict in FILENAME - ;; Bah. - (+ (point) 21) (line-end-position))) - (entry (assoc file result))) - (when entry - (setf (nth 1 entry) 'conflict))) - (push (list (buffer-substring-no-properties - (+ (point) 4) - (line-end-position)) - translated) result)) + (cond + ((eq translated 'conflict) + ;; For conflicts the file appears twice in the listing: once + ;; with the M flag and once with the C flag, so take care + ;; not to add it twice to `result'. Ugly. + (let* ((file + (buffer-substring-no-properties + ;;For files with conflicts the format is: + ;;C Text conflict in FILENAME + ;; Bah. + (+ (point) 21) (line-end-position))) + (entry (assoc file result))) + (when entry + (setf (nth 1 entry) 'conflict)))) + ((eq translated 'renamed) + (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 (file-relative-name + (buffer-substring-no-properties + (+ (point) 4) + (line-end-position)) relative-dir) + translated) result))) (forward-line)) (funcall update-function result))) -;; XXX Experimental function for the vc-dired replacement. -;; XXX This probably needs some further refinement and testing. (defun vc-bzr-dir-status (dir update-function) "Return a list of conses (file . state) for DIR." - ;; XXX: Is this the right command to use? (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) + (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)) ;;; 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 @@ -713,12 +1000,12 @@ Optional argument LOCALP is always ignored." ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):" string) (completion-table-with-context (substring string 0 (match-end 0)) - '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)) @@ -729,10 +1016,11 @@ Optional argument LOCALP is always ignored." ((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. - (call-process vc-bzr-program nil '(t) nil "tags" "--show-ids") + (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids") ;; The output is ambiguous, unless we assume that revids do not ;; contain spaces. (goto-char (point-min)) @@ -740,13 +1028,25 @@ Optional argument LOCALP is always ignored." (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? - ) + ((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 - (complete-with-action action '("revno:" "revid:" "last:" "before:" - "tag:" "date:" "ancestor:" "branch:" - "submit:") + ;; 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 (eval-when-compile + (mapcar (lambda (s) (concat s ":")) + vc-bzr-revision-keywords)) string pred)))))) (eval-after-load "vc"