X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0d42eb3e961e612b1b04e32e99c2998dd4d5d3be..01fcc3a532872b29784a4d888ab9cc1aef0eed01:/lisp/vc/vc-bzr.el?ds=sidebyside diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 5488e53e32..d0912cb719 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1,6 +1,6 @@ ;;; vc-bzr.el --- VC backend for the bzr revision control system -*- lexical-binding: t -*- -;; Copyright (C) 2006-2012 Free Software Foundation, Inc. +;; Copyright (C) 2006-2013 Free Software Foundation, Inc. ;; Author: Dave Love ;; Riccardo Murri @@ -46,7 +46,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc) ;; for vc-exec-after (require 'vc-dir)) @@ -102,9 +102,9 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and `LC_MESSAGES=C' to the environment. If BZR-COMMAND is \"status\", prepends `vc-bzr-status-switches' to ARGS." (let ((process-environment - (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) - "LC_MESSAGES=C" ; Force English output - process-environment))) + `("BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) + "LC_MESSAGES=C" ; Force English output + ,@process-environment))) (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program file-or-list bzr-command (if (and (string-equal "status" bzr-command) @@ -123,8 +123,8 @@ Use the current Bzr root directory as the ROOT argument to `vc-do-async-command', and specify an output buffer named \"*vc-bzr : ROOT*\". Return this buffer." (let* ((process-environment - (list* "BZR_PROGRESS_BAR=none" "LC_MESSAGES=C" - process-environment)) + `("BZR_PROGRESS_BAR=none" "LC_MESSAGES=C" + ,@process-environment)) (root (vc-bzr-root default-directory)) (buffer (format "*vc-bzr : %s*" (expand-file-name root)))) (apply 'vc-do-async-command buffer root @@ -150,12 +150,6 @@ Use the current Bzr root directory as the ROOT argument to (defconst vc-bzr-admin-branchconf (concat vc-bzr-admin-dirname "/branch/branch.conf")) -;;;###autoload (defun vc-bzr-registered (file) -;;;###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 (file) "Return the root directory of the bzr repository containing FILE." ;; Cache technique copied from vc-arch.el. @@ -208,86 +202,97 @@ in the repository root directory of FILE." ;; + working ( = packed_stat ) ;; parent = common ( as above ) + history ( = rev_id ) ;; kinds = (r)elocated, (a)bsent, (d)irectory, (f)ile, (l)ink - (let ((root (vc-bzr-root file))) - (when root ; Short cut. - (let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) - (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 - ;; y/n. Whether or not the current copy - ;; was executable the last time bzr checked? - "[^\0]*\0" - "[^\0]*\0" ;? - ;; Parent information. Absent in a new repo. - "\\(?:\\([^\0]*\\)\0" ;"a/f/d" a=added? - "\\([^\0]*\\)\0" ;sha1 again? - "\\([^\0]*\\)\0" ;size again? - ;; y/n. Whether or not the repo thinks - ;; the file should be executable? - "\\([^\0]*\\)\0" - "[^\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) - ;; If there is no parent, this must be a new repo. - ;; If file is in dirstate, can only be added (b#8025). - ((or (not (match-beginning 4)) - (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)) - ;; For a file, does the executable state match? - ;; (Bug#7544) - (or (not - (eq (char-after (match-beginning 1)) ?f)) - (let ((exe - (memq - ?x - (mapcar - 'identity - (nth 8 (file-attributes file)))))) - (if (eq (char-after (match-beginning 7)) - ?y) - exe - (not exe))))) - (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)))) - ;; The dirstate file can't be read, or some other problem. - (error (vc-bzr-state file))))))) - + (let* ((root (vc-bzr-root file)) + (dirstate (expand-file-name vc-bzr-admin-dirstate root))) + (when root ; Short cut. + (condition-case err + (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))) + (cond + ((not + (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 + ;; y/n. Whether or not the current copy + ;; was executable the last time bzr checked? + "[^\0]*\0" + "[^\0]*\0" ;? + ;; Parent information. Absent in a new repo. + "\\(?:\\([^\0]*\\)\0" ;"a/f/d" a=added? + "\\([^\0]*\\)\0" ;sha1 again? + "\\([^\0]*\\)\0" ;size again? + ;; y/n. Whether or not the repo thinks + ;; the file should be executable? + "\\([^\0]*\\)\0" + "[^\0]*\0\\)?" ;last revid? + ;; There are more fields when merges are pending. + ) + nil t)) + 'unregistered) + ;; 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). + ((eq (char-after (match-beginning 1)) ?a) 'removed) + ;; If there is no parent, this must be a new repo. + ;; If file is in dirstate, can only be added (b#8025). + ((or (not (match-beginning 4)) + (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) + (save-match-data (vc-bzr-sha1 file))) + ;; For a file, does the executable state match? + ;; (Bug#7544) + (or (not + (eq (char-after (match-beginning 1)) ?f)) + (let ((exe + (memq + ?x + (mapcar + 'identity + (nth 8 (file-attributes file)))))) + (if (eq (char-after (match-beginning 7)) + ?y) + exe + (not exe))))) + (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))))) + ;; The dirstate file can't be read, or some other problem. + (error + (message "Falling back on \"slow\" status detection (%S)" err) + (vc-bzr-state file)))))) + +;; This is a cheap approximation that is autoloaded. If it finds a +;; possible match it loads this file and runs the real function. +;; It requires vc-bzr-admin-checkout-format-file to be autoloaded too. +;;;###autoload (defun vc-bzr-registered (file) +;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file) +;;;###autoload (progn +;;;###autoload (load "vc-bzr" nil t) +;;;###autoload (vc-bzr-registered file)))) (defun vc-bzr-registered (file) "Return non-nil if FILE is registered with bzr." @@ -308,7 +313,7 @@ in the repository root directory of FILE." (when rootdir (file-relative-name filename* rootdir)))) -(defvar vc-bzr-error-regex-alist +(defvar vc-bzr-error-regexp-alist '(("^\\( M[* ]\\|+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1) ("^C \\(.+\\)" 2) ("^Text conflict in \\(.+\\)" 1 nil nil 2) @@ -344,14 +349,7 @@ prompt for the Bzr command to run." command (cadr args) args (cddr args))) (let ((buf (apply 'vc-bzr-async-command command args))) - (with-current-buffer buf - (vc-exec-after - `(progn - (let ((compilation-error-regexp-alist - vc-bzr-error-regex-alist)) - (compilation-mode)) - (set (make-local-variable 'compilation-error-regexp-alist) - vc-bzr-error-regex-alist)))) + (with-current-buffer buf (vc-exec-after '(vc-compilation-mode 'bzr))) (vc-set-async-update buf)))) (defun vc-bzr-merge-branch () @@ -382,14 +380,7 @@ default if it is available." (command (cadr cmd)) (args (cddr cmd))) (let ((buf (apply 'vc-bzr-async-command command args))) - (with-current-buffer buf - (vc-exec-after - `(progn - (let ((compilation-error-regexp-alist - vc-bzr-error-regex-alist)) - (compilation-mode)) - (set (make-local-variable 'compilation-error-regexp-alist) - vc-bzr-error-regex-alist)))) + (with-current-buffer buf (vc-exec-after '(vc-compilation-mode 'bzr))) (vc-set-async-update buf)))) (defun vc-bzr-status (file) @@ -545,7 +536,9 @@ in the branch repository (or whose status not be determined)." ;; FIXME: maybe it's overkill to check if both these ;; files exist. (and (file-exists-p branch-format-file) - (file-exists-p lastrev-file))))) + (file-exists-p lastrev-file) + (equal (emacs-bzr-version-dirstate l-c-parent-dir) + (emacs-bzr-version-dirstate rootdir)))))) t))) (with-temp-buffer (insert-file-contents branch-format-file) @@ -564,13 +557,17 @@ in the branch repository (or whose status not be determined)." (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" + ;; Fallback to calling "bzr revno --tree". + ;; The "--tree" matters for lightweight checkouts not on the same + ;; revision as the parent. (let* ((result (vc-bzr-command-discarding-stderr - vc-bzr-program "revno" (file-relative-name file))) + vc-bzr-program "revno" "--tree" + (file-relative-name file))) (exitcode (car result)) (output (cdr result))) (cond - ((eq exitcode 0) (substring output 0 -1)) + ((and (eq exitcode 0) (not (zerop (length output)))) + (substring output 0 -1)) (t nil)))))) (defun vc-bzr-create-repo () @@ -623,15 +620,24 @@ or a superior directory.") (declare-function log-edit-extract-headers "log-edit" (headers string)) +(defun vc-bzr--sanitize-header (arg) + ;; Newlines in --fixes (and probably other fields as well) trigger a nasty + ;; Bazaar bug; see https://bugs.launchpad.net/bzr/+bug/1094180. + (lambda (str) (list arg + (replace-regexp-in-string "\\`[ \t]+\\|[ \t]+\\'" + "" (replace-regexp-in-string + "\n[ \t]?" " " str))))) + (defun vc-bzr-checkin (files rev comment) "Check FILES 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")) - (apply 'vc-bzr-command "commit" nil 0 - files (cons "-m" (log-edit-extract-headers '(("Author" . "--author") - ("Date" . "--commit-time") - ("Fixes" . "--fixes")) - comment)))) + (apply 'vc-bzr-command "commit" nil 0 files + (cons "-m" (log-edit-extract-headers + `(("Author" . ,(vc-bzr--sanitize-header "--author")) + ("Date" . ,(vc-bzr--sanitize-header "--commit-time")) + ("Fixes" . ,(vc-bzr--sanitize-header "--fixes"))) + comment)))) (defun vc-bzr-find-revision (file rev buffer) "Fetch revision REV of file FILE and put it into BUFFER." @@ -858,7 +864,7 @@ stream. Standard error output is discarded." (apply #'process-file command nil (list (current-buffer) nil) nil args) (buffer-substring (point-min) (point-max))))) -(defstruct (vc-bzr-extra-fileinfo +(cl-defstruct (vc-bzr-extra-fileinfo (:copier nil) (:constructor vc-bzr-create-extra-fileinfo (extra-name)) (:conc-name vc-bzr-extra-fileinfo->))