X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1e8995158740b15936887264a3d7183beb5c51d9..5b5afd508a5ca3643e1cd435fa60d197b7c2f9f7:/lisp/vc-bzr.el diff --git a/lisp/vc-bzr.el b/lisp/vc-bzr.el index dc8004c25a..5ed46431fd 100644 --- a/lisp/vc-bzr.el +++ b/lisp/vc-bzr.el @@ -2,20 +2,15 @@ ;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. -;; NOTE: THIS IS A MODIFIED VERSION OF Dave Love's vc-bzr.el, -;; which you can find at: http://www.loveshack.ukfsn.org/emacs/vc-bzr.el -;; I could not get in touch with Dave Love by email, so -;; I am releasing my changes separately. -- Riccardo - ;; Author: Dave Love , Riccardo Murri ;; Keywords: tools ;; Created: Sept 2006 -;; Version: 2007-05-24 +;; Version: 2007-09-05 ;; URL: http://launchpad.net/vc-bzr ;; This file 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 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, @@ -31,9 +26,6 @@ ;;; Commentary: -;; NOTE: THIS IS A MODIFIED VERSION OF Dave Love's vc-bzr.el, -;; which you can find at: http://www.loveshack.ukfsn.org/emacs/vc-bzr.el - ;; See concerning bzr. ;; Load this library to register bzr support in VC. It covers basic VC @@ -63,11 +55,11 @@ ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. -(put 'BZR 'vc-functions nil) +(put 'Bzr 'vc-functions nil) (defgroup vc-bzr nil "VC bzr backend." -;; :version "22" + :version "22.2" :group 'vc) (defcustom vc-bzr-program "bzr" @@ -96,120 +88,208 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment." (let ((process-environment (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) "LC_ALL=C" ; Force English output - process-environment)) - ;; bzr may attempt some kind of user interaction if its stdin/stdout - ;; is connected to a PTY; therefore, ask Emacs to use a pipe to - ;; communicate with it. - ;; This is redundant because vc-do-command does it already. --Stef - (process-connection-type nil)) + process-environment))) (apply 'vc-do-command buffer okstatus vc-bzr-program file-or-list bzr-command (append vc-bzr-program-args args)))) ;;;###autoload -(defconst vc-bzr-admin-dirname ".bzr") ; FIXME: "_bzr" on w32? +(defconst vc-bzr-admin-dirname ".bzr" ; FIXME: "_bzr" on w32? + "Name of the directory containing Bzr repository status files.") +;;;###autoload +(defconst vc-bzr-admin-checkout-format-file + (concat vc-bzr-admin-dirname "/checkout/format")) +(defconst vc-bzr-admin-dirstate + (concat vc-bzr-admin-dirname "/checkout/dirstate")) +(defconst vc-bzr-admin-branch-format-file + (concat vc-bzr-admin-dirname "/branch/format")) +(defconst vc-bzr-admin-revhistory + (concat vc-bzr-admin-dirname "/branch/revision-history")) +(defconst vc-bzr-admin-lastrev + (concat vc-bzr-admin-dirname "/branch/last-revision")) ;;;###autoload (defun vc-bzr-registered (file) -;;;###autoload (if (vc-find-root file vc-bzr-admin-dirname) +;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file) ;;;###autoload (progn ;;;###autoload (load "vc-bzr") ;;;###autoload (vc-bzr-registered file)))) -(defun vc-bzr-root-dir (file) - "Return the root directory in the hierarchy above FILE. -Return nil if there isn't one." - (vc-find-root file vc-bzr-admin-dirname)) +(defun vc-bzr-root (file) + "Return the root directory of the bzr repository containing FILE." + ;; Cache technique copied from vc-arch.el. + (or (vc-file-getprop file 'bzr-root) + (vc-file-setprop + file 'bzr-root + (vc-find-root file vc-bzr-admin-checkout-format-file)))) (defun vc-bzr-registered (file) - "Return non-nil if FILE is registered with bzr." - (if (vc-bzr-root-dir file) ; Short cut. - (vc-bzr-state file))) ; Expensive. - -(defun vc-bzr-buffer-nonblank-p (&optional buffer) - "Return non-nil if BUFFER contains any non-blank characters." - (or (> (buffer-size buffer) 0) - (save-excursion - (set-buffer (or buffer (current-buffer))) - (goto-char (point-min)) - (re-search-forward "[^ \t\n]" (point-max) t)))) + "Return non-nil if FILE is registered with bzr. + +For speed, this function tries first to parse Bzr internal file +`checkout/dirstate', but it may fail if Bzr internal file format +has changed. As a safeguard, the `checkout/dirstate' file is +only parsed if it contains the string `#bazaar dirstate flat +format 3' in the first line. + +If the `checkout/dirstate' file cannot be parsed, fall back to +running `vc-bzr-state'." + (lexical-let ((root (vc-bzr-root file))) + (when root ; Short cut. + ;; 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))) + (re-search-forward + (concat "^\0" + (if reldir (regexp-quote (directory-file-name reldir))) + "\0" + (regexp-quote (file-name-nondirectory relfile)) + "\0") + nil t))))))))) (defconst vc-bzr-state-words - "added\\|ignored\\|modified\\|removed\\|renamed\\|unknown" + "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown" "Regexp matching file status words as reported in `bzr' output.") +(defun vc-bzr-file-name-relative (filename) + "Return file name FILENAME stripped of the initial Bzr repository path." + (lexical-let* + ((filename* (expand-file-name filename)) + (rootdir (vc-bzr-root (file-name-directory filename*)))) + (when rootdir + (file-relative-name filename* rootdir)))) + ;; FIXME: Also get this in a non-registered sub-directory. -(defun vc-bzr-state (file) +;; It already works for me. -- Riccardo +(defun vc-bzr-status (file) + "Return FILE status according to Bzr. +Return value is a cons (STATUS . WARNING), where WARNING is a +string or nil, and STATUS is one of the symbols: `added', +`ignored', `kindchanged', `modified', `removed', `renamed', `unknown', +which directly correspond to `bzr status' output, or 'unchanged +for files whose copy in the working tree is identical to the one +in the branch repository, or nil for files that are not +registered with Bzr. + +If any error occurred in running `bzr status', then return nil." (with-temp-buffer - (cd (file-name-directory file)) - (let ((ret (vc-bzr-command "status" t 255 file)) - (state 'up-to-date)) - ;; the only secure status indication in `bzr status' output - ;; is a couple of lines following the pattern:: - ;; | : - ;; | - ;; if the file is up-to-date, we get no status report from `bzr', - ;; so if the regexp search for the above pattern fails, we consider - ;; the file to be up-to-date. - (goto-char (point-min)) - (when - (re-search-forward - (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+" - (file-name-nondirectory file) "[ \t\n]*$") - (point-max) t) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (goto-char start) - (setq state - (cond - ((not (equal ret 0)) nil) - ((looking-at "added\\|renamed\\|modified\\|removed") 'edited) - ((looking-at "unknown\\|ignored") nil))) - ;; erase the status text that matched - (delete-region start end))) - (when (vc-bzr-buffer-nonblank-p) - ;; "bzr" will output some warnings and informational messages - ;; to the user to stderr; due to Emacs' `vc-do-command' (and, - ;; it seems, `start-process' itself), we cannot catch stderr - ;; and stdout into different buffers. So, if there's anything - ;; left in the buffer after removing the above status - ;; keywords, let us just presume that any other message from - ;; "bzr" is a user warning, and display it. - (message "Warnings in `bzr' output: %s" - (buffer-substring (point-min) (point-max)))) - (when state - (vc-file-setprop file 'vc-workfile-version - (vc-bzr-workfile-version file)) - (vc-file-setprop file 'vc-state state)) - state))) + (let ((ret (condition-case nil + (vc-bzr-command "status" t 0 file) + (file-error nil))) ; vc-bzr-program not found. + (status 'unchanged)) + ;; the only secure status indication in `bzr status' output + ;; is a couple of lines following the pattern:: + ;; | : + ;; | + ;; if the file is up-to-date, we get no status report from `bzr', + ;; so if the regexp search for the above pattern fails, we consider + ;; the file to be up-to-date. + (goto-char (point-min)) + (when (re-search-forward + ;; bzr prints paths relative to the repository root. + (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+" + (regexp-quote (vc-bzr-file-name-relative file)) + (if (file-directory-p file) "/?" "") + "[ \t\n]*$") + nil t) + (lexical-let ((statusword (match-string 1))) + ;; Erase the status text that matched. + (delete-region (match-beginning 0) (match-end 0)) + (setq status + (and (equal ret 0) ; Seems redundant. --Stef + (intern (replace-regexp-in-string " " "" + statusword)))))) + (when status + (goto-char (point-min)) + (skip-chars-forward " \n\t") ;Throw away spaces. + (cons status + ;; "bzr" will output warnings and informational messages to + ;; stderr; due to Emacs' `vc-do-command' (and, it seems, + ;; `start-process' itself) limitations, we cannot catch stderr + ;; and stdout into different buffers. So, if there's anything + ;; left in the buffer after removing the above status + ;; keywords, let us just presume that any other message from + ;; "bzr" is a user warning, and display it. + (unless (eobp) (buffer-substring (point) (point-max)))))))) -(defun vc-bzr-workfile-unchanged-p (file) - (eq 'up-to-date (vc-bzr-state file))) +(defun vc-bzr-state (file) + (lexical-let ((result (vc-bzr-status file))) + (when (consp result) + (if (cdr result) + (message "Warnings in `bzr' output: %s" (cdr result))) + (cdr (assq (car result) + '((added . edited) + (kindchanged . edited) + (renamed . edited) + (modified . edited) + (removed . edited) + (ignored . nil) + (unknown . nil) + (unchanged . up-to-date))))))) -(defun vc-bzr-workfile-version (file) - ;; Looks like this could be obtained via counting lines in - ;; .bzr/branch/revision-history. - (with-temp-buffer - (vc-bzr-command "revno" t 0 file) - (goto-char (point-min)) - (buffer-substring (point) (line-end-position)))) +(defun vc-bzr-workfile-unchanged-p (file) + (eq 'unchanged (car (vc-bzr-status file)))) + +(defun vc-bzr-working-revision (file) + (lexical-let* + ((rootdir (vc-bzr-root file)) + (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file + rootdir)) + (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir)) + (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) + (with-temp-buffer + (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) + (number-to-string (count-lines (line-end-position) (point-max)))) + ((looking-at "Bazaar Branch Format 6 (bzr 0.15)") + ;; 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)))))) + ;; fallback to calling "bzr revno" + (lexical-let* + ((result (vc-bzr-command-discarding-stderr + vc-bzr-program "revno" file)) + (exitcode (car result)) + (output (cdr result))) + (cond + ((eq exitcode 0) (substring output 0 -1)) + (t nil)))))) (defun vc-bzr-checkout-model (file) 'implicit) (defun vc-bzr-create-repo () - "Create a new BZR repository." + "Create a new Bzr repository." (vc-bzr-command "init" nil 0 nil)) (defun vc-bzr-register (files &optional rev comment) "Register FILE under bzr. Signal an error unless REV is nil. COMMENT is ignored." - (if rev (error "Can't register explicit version with bzr")) + (if rev (error "Can't register explicit revision with bzr")) (vc-bzr-command "add" nil 0 files)) ;; Could run `bzr status' in the directory and see if it succeeds, but ;; that's relatively expensive. -(defalias 'vc-bzr-responsible-p 'vc-bzr-root-dir +(defalias 'vc-bzr-responsible-p 'vc-bzr-root "Return non-nil if FILE is (potentially) controlled by bzr. The criterion is that there is a `.bzr' directory in the same or a superior directory.") @@ -233,7 +313,7 @@ or a superior directory.") (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 version with bzr")) + (if rev (error "Can't check in a specific revision with bzr")) (vc-bzr-command "commit" nil 0 files "-m" comment)) (defun vc-bzr-checkout (file &optional editable rev destfile) @@ -243,14 +323,14 @@ EDITABLE is ignored." (setq destfile (vc-version-backup-file-name file rev))) (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (with-temp-file destfile - (if rev - (vc-bzr-command "cat" t 0 file "-r" rev) - (vc-bzr-command "cat" t 0 file))))) + (with-temp-file destfile + (if rev + (vc-bzr-command "cat" t 0 file "-r" rev) + (vc-bzr-command "cat" t 0 file))))) (defun vc-bzr-revert (file &optional contents-done) (unless contents-done - (with-temp-buffer (vc-bzr-command "revert" t 'async file)))) + (with-temp-buffer (vc-bzr-command "revert" t 0 file)))) (defvar log-view-message-re) (defvar log-view-file-re) @@ -279,33 +359,29 @@ EDITABLE is ignored." "Get bzr change log for FILES into specified BUFFER." ;; Fixme: This might need the locale fixing up if things like `revno' ;; got localized, but certainly it shouldn't use LC_ALL=C. - ;; NB. Can't be async -- see `vc-bzr-post-command-function'. (vc-bzr-command "log" buffer 0 files) ;; FIXME: Until Emacs-23, VC was missing a hook to sort out the mode for ;; the buffer, or at least set the regexps right. (unless (fboundp 'vc-default-log-view-mode) (add-hook 'log-view-mode-hook 'vc-bzr-log-view-mode))) -(defun vc-bzr-show-log-entry (version) - "Find entry for patch name VERSION in bzr change log buffer." +(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 (concat "^-+\nrevno: " version "$") nil t) + (if (re-search-forward (concat "^-+\nrevno: " revision "$") nil t) (beginning-of-line 0) (goto-char (point-min))))) -;; Fixem: vc-bzr-wash-log - (autoload 'vc-diff-switches-list "vc" nil nil t) (defun vc-bzr-diff (files &optional rev1 rev2 buffer) "VC bzr backend for diff." - (let ((working (vc-workfile-version (car files)))) + (let ((working (vc-working-revision (if (consp files) (car files) files)))) (if (and (equal rev1 working) (not rev2)) (setq rev1 nil)) (if (and (not rev1) rev2) (setq rev1 working)) - ;; NB. Can't be async -- see `vc-bzr-post-command-function'. ;; bzr diff produces condition code 1 for some reason. (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*") 1 files "--diff-options" (mapconcat 'identity (vc-diff-switches-list bzr) @@ -317,10 +393,9 @@ EDITABLE is ignored." (defalias 'vc-bzr-diff-tree 'vc-bzr-diff) -;; Fixme: implement vc-bzr-dir-state, vc-bzr-dired-state-info -;; Fixme: vc-{next,previous}-version need fixing in vc.el to deal with -;; straight integer versions. +;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with +;; straight integer revisions. (defun vc-bzr-delete-file (file) "Delete FILE and delete it in the bzr repository." @@ -337,18 +412,18 @@ EDITABLE is ignored." "Internal use.") (make-variable-buffer-local 'vc-bzr-annotation-table) -(defun vc-bzr-annotate-command (file buffer &optional version) +(defun vc-bzr-annotate-command (file buffer &optional revision) "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 "-l" "--all" - (if version (list "-r" version))) + (apply #'vc-bzr-command "annotate" buffer 0 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]+\\) \\(.+\\) +\\([0-9]\\{8\\}\\) |" + (while (re-search-forward "^\\( *[0-9]+\\) +\\(.+\\) +\\([0-9]\\{8\\}\\) |" nil t) (let* ((rev (match-string 1)) (author (match-string 2)) @@ -356,9 +431,6 @@ property containing author and date information." (key (match-string 0)) (tag (gethash key vc-bzr-annotation-table))) (unless tag - (save-match-data - (string-match " +\\'" author) - (setq author (substring author 0 (match-beginning 0)))) (setq tag (propertize rev 'help-echo (concat "Author: " author ", date: " date) 'mouse-face 'highlight)) @@ -368,11 +440,11 @@ property containing author and date information." ;; Definition from Emacs 22 (unless (fboundp 'vc-annotate-convert-time) -(defun vc-annotate-convert-time (time) - "Convert a time value to a floating-point number of days. + (defun vc-annotate-convert-time (time) + "Convert a time value to a floating-point number of days. The argument TIME is a list as returned by `current-time' or `encode-time', only the first two elements of that list are considered." - (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))) + (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))) (defun vc-bzr-annotate-time () (when (re-search-forward "^ *[0-9]+ |" nil t) @@ -399,17 +471,16 @@ Return nil if current line isn't annotated." (if next-time (- (vc-annotate-convert-time (current-time)) next-time)))) -;; FIXME: `bzr root' will return the real path to the repository root, -;; that is, it can differ from the buffer's current directory name -;; if there are any symbolic links. -(defun vc-bzr-root (dir) - "Return the root directory of the bzr repository containing DIR." - ;; Cache technique copied from vc-arch.el. - (or (vc-file-getprop dir 'bzr-root) - (vc-file-setprop - dir 'bzr-root - (substring - (shell-command-to-string (concat vc-bzr-program " root " dir)) 0 -1)))) +(defun vc-bzr-command-discarding-stderr (command &rest args) + "Execute shell command COMMAND (with ARGS); return its output and exitcode. +Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is +the (numerical) exit code of the process, and OUTPUT is a string +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) + (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 @@ -440,7 +511,7 @@ Optional argument LOCALP is always ignored." (vc-file-setprop file 'vc-state 'up-to-date) ;; XXX: is this correct? what happens if one ;; mixes different SCMs in the same dir? - (vc-file-setprop file 'vc-backend '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 @@ -453,6 +524,9 @@ Optional argument LOCALP is always ignored." ((looking-at "^added") (setq current-vc-state 'edited) (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)) @@ -472,7 +546,7 @@ Optional argument LOCALP is always ignored." (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-workfile-version "0")))) + (vc-file-setprop file 'vc-working-revision "0")))) (when (eq 'not-versioned current-bzr-state) (let ((file (expand-file-name (buffer-substring-no-properties @@ -492,19 +566,10 @@ Optional argument LOCALP is always ignored." (if bzr-state (concat "(" (symbol-name bzr-state) ")") ;; else fall back to default vc representation - (vc-default-dired-state-info 'BZR file))))) - -;; In case of just `(load "vc-bzr")', but that's probably the wrong -;; way to do it. -(add-to-list 'vc-handled-backends 'BZR) + (vc-default-dired-state-info 'Bzr file))))) (eval-after-load "vc" - '(add-to-list 'vc-directory-exclusion-list ".bzr" t)) - -(defconst vc-bzr-unload-hook - (lambda () - (setq vc-handled-backends (delq 'BZR vc-handled-backends)) - (remove-hook 'vc-post-command-functions 'vc-bzr-post-command-function))) + '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t)) (provide 'vc-bzr) ;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06