X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f0e7c067eb2d0354a16ec9f565c9dac7ed69260a..76a1a8a64f5b581d63b981361a8698c99de5dbdc:/lisp/vc-rcs.el diff --git a/lisp/vc-rcs.el b/lisp/vc-rcs.el index 92676717cd..00700c5a65 100644 --- a/lisp/vc-rcs.el +++ b/lisp/vc-rcs.el @@ -1,11 +1,12 @@ ;;; vc-rcs.el --- support for RCS version-control -;; Copyright (C) 1992,93,94,95,96,97,98,99,2000 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel -;; $Id: vc-rcs.el,v 1.15 2001/01/08 16:25:43 spiegel Exp $ +;; $Id$ ;; This file is part of GNU Emacs. @@ -21,10 +22,12 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Commentary: see vc.el +;;; Commentary: + +;; See vc.el ;;; Code: @@ -33,7 +36,8 @@ ;;; (eval-when-compile - (require 'cl)) + (require 'cl) + (require 'vc)) (defcustom vc-rcs-release nil "*The release number of your RCS installation, as a string. @@ -55,20 +59,8 @@ by \\[vc-rcs-register]." :version "21.1" :group 'vc) -(defcustom vc-rcs-checkin-switches nil - "*A string or list of strings specifying extra switches for RCS checkin. -These are passed to the checkin program by \\[vc-rcs-checkin]." - :type '(choice (const :tag "None" nil) - (string :tag "Argument String") - (repeat :tag "Argument List" - :value ("") - string)) - :version "21.1" - :group 'vc) - -(defcustom vc-rcs-checkout-switches nil - "*A string or list of strings specifying extra switches for RCS checkout. -These are passed to the checkout program by \\[vc-rcs-checkout]." +(defcustom vc-rcs-diff-switches nil + "*A string or list of strings specifying extra switches for rcsdiff under VC." :type '(choice (const :tag "None" nil) (string :tag "Argument String") (repeat :tag "Argument List" @@ -108,8 +100,13 @@ For a description of possible values, see `vc-check-master-templates'." ;;; State-querying functions ;;; -;;;###autoload -(progn (defun vc-rcs-registered (f) (vc-default-registered 'RCS f))) +;;; The autoload cookie below places vc-rcs-registered directly into +;;; loaddefs.el, so that vc-rcs.el does not need to be loaded for +;;; every file that is visited. The definition is repeated below +;;; so that Help and etags can find it. + +;;;###autoload (defun vc-rcs-registered (f) (vc-default-registered 'RCS f)) +(defun vc-rcs-registered (f) (vc-default-registered 'RCS f)) (defun vc-rcs-state (file) "Implementation of `vc-state' for RCS." @@ -125,7 +122,6 @@ For a description of possible values, see `vc-check-master-templates'." 'vc-workfile-version)))) (if (not (eq state 'up-to-date)) state - (require 'vc) (if (vc-workfile-unchanged-p file) 'up-to-date (if (eq (vc-checkout-model file) 'locking) @@ -148,16 +144,16 @@ For a description of possible values, see `vc-check-master-templates'." (cond ((string-match ".rw..-..-." (nth 8 (file-attributes file))) (vc-file-setprop file 'vc-checkout-model 'implicit) - (setq state - (if (vc-rcs-workfile-is-newer file) - 'edited + (setq state + (if (vc-rcs-workfile-is-newer file) + 'edited 'up-to-date))) ((string-match ".r-..-..-." (nth 8 (file-attributes file))) (vc-file-setprop file 'vc-checkout-model 'locking)))) state) (if (not (vc-mistrust-permissions file)) - (let* ((attributes (file-attributes file)) - (owner-uid (nth 2 attributes)) + (let* ((attributes (file-attributes file 'string)) + (owner-name (nth 2 attributes)) (permissions (nth 8 attributes))) (cond ((string-match ".r-..-..-." permissions) (vc-file-setprop file 'vc-checkout-model 'locking) @@ -166,8 +162,8 @@ For a description of possible values, see `vc-check-master-templates'." (if (eq (vc-checkout-model file) 'locking) (if (file-ownership-preserved-p file) 'edited - (vc-user-login-name owner-uid)) - (if (vc-rcs-workfile-is-newer file) + owner-name) + (if (vc-rcs-workfile-is-newer file) 'edited 'up-to-date))) (t @@ -191,7 +187,7 @@ When VERSION is given, perform check for that version." (unless version (setq version (vc-workfile-version file))) (with-temp-buffer (string= version - (if (vc-rcs-trunk-p version) + (if (vc-trunk-p version) (progn ;; Compare VERSION to the head version number. (vc-insert-file (vc-name file) "^[0-9]") @@ -199,17 +195,21 @@ When VERSION is given, perform check for that version." ;; If we are not on the trunk, we need to examine the ;; whole current branch. (vc-insert-file (vc-name file) "^desc") - (vc-rcs-find-most-recent-rev (vc-rcs-branch-part version)))))) + (vc-rcs-find-most-recent-rev (vc-branch-part version)))))) (defun vc-rcs-checkout-model (file) "RCS-specific version of `vc-checkout-model'." - (vc-rcs-consult-headers file) - (or (vc-file-getprop file 'vc-checkout-model) - (progn (vc-rcs-fetch-master-state file) - (vc-file-getprop file 'vc-checkout-model)))) + (let (result) + (when vc-consult-headers + (vc-file-setprop file 'vc-checkout-model nil) + (vc-rcs-consult-headers file) + (setq result (vc-file-getprop file 'vc-checkout-model))) + (or result + (progn (vc-rcs-fetch-master-state file) + (vc-file-getprop file 'vc-checkout-model))))) (defun vc-rcs-workfile-unchanged-p (file) - "RCS-specific implementation of vc-workfile-unchanged-p." + "RCS-specific implementation of `vc-workfile-unchanged-p'." ;; Try to use rcsdiff --brief. If rcsdiff does not understand that, ;; do a double take and remember the fact for the future (let* ((version (concat "-r" (vc-workfile-version file))) @@ -240,15 +240,7 @@ the RCS command (in that order). Automatically retrieve a read-only version of the file with keywords expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." - (let ((subdir (expand-file-name "RCS" (file-name-directory file))) - (switches (list - (if (stringp vc-register-switches) - (list vc-register-switches) - vc-register-switches) - (if (stringp vc-rcs-register-switches) - (list vc-rcs-register-switches) - vc-rcs-register-switches)))) - + (let ((subdir (expand-file-name "RCS" (file-name-directory file)))) (and (not (file-exists-p subdir)) (not (directory-files (file-name-directory file) nil ".*,v$" t)) @@ -259,7 +251,7 @@ expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." (and (vc-rcs-release-p "5.6.4") "-i") (concat (if vc-keep-workfiles "-u" "-r") rev) (and comment (concat "-t-" comment)) - switches) + (vc-switches 'RCS 'register)) ;; parse output to find master file name and workfile version (with-current-buffer "*vc*" (goto-char (point-min)) @@ -310,19 +302,17 @@ whether to remove it." (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS") ;; check whether RCS dir is empty, i.e. it does not ;; contain any files except "." and ".." - (not (directory-files dir nil + (not (directory-files dir nil "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*")) (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) (delete-directory dir)))) (defun vc-rcs-checkin (file rev comment) "RCS-specific version of `vc-backend-checkin'." - (let ((switches (if (stringp vc-checkin-switches) - (list vc-checkin-switches) - vc-checkin-switches))) + (let ((switches (vc-switches 'RCS 'checkin))) (let ((old-version (vc-workfile-version file)) new-version (default-branch (vc-file-getprop file 'vc-rcs-default-branch))) - ;; Force branch creation if an appropriate + ;; Force branch creation if an appropriate ;; default branch has been set. (and (not rev) default-branch @@ -330,6 +320,8 @@ whether to remove it." default-branch) (setq rev default-branch) (setq switches (cons "-f" switches))) + (if (and (not rev) old-version) + (setq rev (vc-branch-part old-version))) (apply 'vc-do-command nil 0 "ci" (vc-name file) ;; if available, use the secure check-in option (and (vc-rcs-release-p "5.6.4") "-j") @@ -352,11 +344,11 @@ whether to remove it." ;; branch accordingly (cond ((and old-version new-version - (not (string= (vc-rcs-branch-part old-version) - (vc-rcs-branch-part new-version)))) - (vc-rcs-set-default-branch file - (if (vc-rcs-trunk-p new-version) nil - (vc-rcs-branch-part new-version))) + (not (string= (vc-branch-part old-version) + (vc-branch-part new-version)))) + (vc-rcs-set-default-branch file + (if (vc-trunk-p new-version) nil + (vc-branch-part new-version))) ;; If this is an old RCS release, we might have ;; to remove a remaining lock. (if (not (vc-rcs-release-p "5.6.2")) @@ -365,18 +357,22 @@ whether to remove it." (vc-do-command nil 1 "rcs" (vc-name file) (concat "-u" old-version)))))))) -(defun vc-rcs-checkout (file &optional editable rev workfile) - "Retrieve a copy of a saved version of FILE into a workfile." - (let ((filename (or workfile file)) - (file-buffer (get-file-buffer file)) +(defun vc-rcs-find-version (file rev buffer) + (apply 'vc-do-command + buffer 0 "co" (vc-name file) + "-q" ;; suppress diagnostic output + (concat "-p" rev) + (vc-switches 'RCS 'checkout))) + +(defun vc-rcs-checkout (file &optional editable rev) + "Retrieve a copy of a saved version of FILE." + (let ((file-buffer (get-file-buffer file)) switches) - (message "Checking out %s..." filename) + (message "Checking out %s..." file) (save-excursion ;; Change buffers to get local value of vc-checkout-switches. (if file-buffer (set-buffer file-buffer)) - (setq switches (if (stringp vc-checkout-switches) - (list vc-checkout-switches) - vc-checkout-switches)) + (setq switches (vc-switches 'RCS 'checkout)) ;; Save this buffer's default-directory ;; and use save-excursion to make sure it is restored ;; in the same buffer it was saved in. @@ -384,68 +380,58 @@ whether to remove it." (save-excursion ;; Adjust the default-directory so that the check-out creates ;; the file in the right place. - (setq default-directory (file-name-directory filename)) - (if workfile ;; RCS - ;; RCS can't check out into arbitrary file names directly. - ;; Use `co -p' and make stdout point to the correct file. - (let ((vc-modes (logior (file-modes (vc-name file)) - (if editable 128 0))) - (failed t)) - (unwind-protect - (progn - (let ((coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion)) - (with-temp-file filename - (apply 'vc-do-command - (current-buffer) 0 "co" (vc-name file) - "-q" ;; suppress diagnostic output - (if editable "-l") - (concat "-p" rev) - switches))) - (set-file-modes filename - (logior (file-modes (vc-name file)) - (if editable 128 0))) - (setq failed nil)) - (and failed (file-exists-p filename) - (delete-file filename)))) - (let (new-version) - ;; if we should go to the head of the trunk, - ;; clear the default branch first - (and rev (string= rev "") - (vc-rcs-set-default-branch file nil)) - ;; now do the checkout - (apply 'vc-do-command - nil 0 "co" (vc-name file) - ;; If locking is not strict, force to overwrite - ;; the writable workfile. - (if (eq (vc-checkout-model file) 'implicit) "-f") - (if editable "-l") - (if rev (concat "-r" rev) - ;; if no explicit revision was specified, - ;; check out that of the working file - (let ((workrev (vc-workfile-version file))) - (if workrev (concat "-r" workrev) - nil))) - switches) - ;; determine the new workfile version - (with-current-buffer "*vc*" - (setq new-version - (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1))) - (vc-file-setprop file 'vc-workfile-version new-version) - ;; if necessary, adjust the default branch - (and rev (not (string= rev "")) - (vc-rcs-set-default-branch - file - (if (vc-rcs-latest-on-branch-p file new-version) - (if (vc-rcs-trunk-p new-version) nil - (vc-rcs-branch-part new-version)) - new-version)))))) - (message "Checking out %s...done" filename))))) - -(defun vc-rcs-revert (file) + (setq default-directory (file-name-directory file)) + (let (new-version) + ;; if we should go to the head of the trunk, + ;; clear the default branch first + (and rev (string= rev "") + (vc-rcs-set-default-branch file nil)) + ;; now do the checkout + (apply 'vc-do-command + nil 0 "co" (vc-name file) + ;; If locking is not strict, force to overwrite + ;; the writable workfile. + (if (eq (vc-checkout-model file) 'implicit) "-f") + (if editable "-l") + (if (stringp rev) + ;; a literal revision was specified + (concat "-r" rev) + (let ((workrev (vc-workfile-version file))) + (if workrev + (concat "-r" + (if (not rev) + ;; no revision specified: + ;; use current workfile version + workrev + ;; REV is t ... + (if (not (vc-trunk-p workrev)) + ;; ... go to head of current branch + (vc-branch-part workrev) + ;; ... go to head of trunk + (vc-rcs-set-default-branch file + nil) + "")))))) + switches) + ;; determine the new workfile version + (with-current-buffer "*vc*" + (setq new-version + (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1))) + (vc-file-setprop file 'vc-workfile-version new-version) + ;; if necessary, adjust the default branch + (and rev (not (string= rev "")) + (vc-rcs-set-default-branch + file + (if (vc-rcs-latest-on-branch-p file new-version) + (if (vc-trunk-p new-version) nil + (vc-branch-part new-version)) + new-version))))) + (message "Checking out %s...done" file))))) + +(defun vc-rcs-revert (file &optional contents-done) "Revert FILE to the version it was based on." (vc-do-command nil 0 "co" (vc-name file) "-f" - (concat "-u" (vc-workfile-version file)))) + (concat (if (eq (vc-state file) 'edited) "-u" "-r") + (vc-workfile-version file)))) (defun vc-rcs-cancel-version (file editable) "Undo the most recent checkin of FILE. @@ -487,8 +473,10 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (defun vc-rcs-steal-lock (file &optional rev) "Steal the lock on the current workfile for FILE and revision REV. Needs RCS 5.6.2 or later for -M." - (vc-do-command nil 0 "rcs" (vc-name file) "-M" - (concat "-u" rev) (concat "-l" rev))) + (vc-do-command nil 0 "rcs" (vc-name file) "-M" (concat "-u" rev)) + ;; Do a real checkout after stealing the lock, so that we see + ;; expanded headers. + (vc-do-command nil 0 "co" (vc-name file) "-f" (concat "-l" rev))) @@ -496,53 +484,216 @@ Needs RCS 5.6.2 or later for -M." ;;; History functions ;;; -(defun vc-rcs-print-log (file) +(defun vc-rcs-print-log (file &optional buffer) "Get change log associated with FILE." - (vc-do-command t 0 "rlog" (vc-name file))) - -(defun vc-rcs-show-log-entry (version) - (when (re-search-forward - ;; also match some context, for safety - (concat "----\nrevision " version - "\\(\tlocked by:.*\n\\|\n\\)date: ") nil t) - ;; set the display window so that - ;; the whole log entry is displayed - (let (start end lines) - (beginning-of-line) (forward-line -1) (setq start (point)) - (if (not (re-search-forward "^----*\nrevision" nil t)) - (setq end (point-max)) - (beginning-of-line) (forward-line -1) (setq end (point))) - (setq lines (count-lines start end)) - (cond - ;; if the global information and this log entry fit - ;; into the window, display from the beginning - ((< (count-lines (point-min) end) (window-height)) - (goto-char (point-min)) - (recenter 0) - (goto-char start)) - ;; if the whole entry fits into the window, - ;; display it centered - ((< (1+ lines) (window-height)) - (goto-char start) - (recenter (1- (- (/ (window-height) 2) (/ lines 2))))) - ;; otherwise (the entry is too large for the window), - ;; display from the start - (t - (goto-char start) - (recenter 0)))))) - -(defun vc-rcs-diff (file &optional oldvers newvers) + (vc-do-command buffer 0 "rlog" (vc-name file))) + +(defun vc-rcs-diff (file &optional oldvers newvers buffer) "Get a difference report using RCS between two versions of FILE." (if (not oldvers) (setq oldvers (vc-workfile-version file))) - ;; If we know that --brief is not supported, don't try it. - (let* ((diff-switches-list (if (listp diff-switches) - diff-switches - (list diff-switches))) - (options (append (list "-q" - (concat "-r" oldvers) - (and newvers (concat "-r" newvers))) - diff-switches-list))) - (apply 'vc-do-command t 1 "rcsdiff" file options))) + (apply 'vc-do-command (or buffer "*vc-diff*") 1 "rcsdiff" file + (append (list "-q" + (concat "-r" oldvers) + (and newvers (concat "-r" newvers))) + (vc-switches 'RCS 'diff)))) + +(defun vc-rcs-annotate-command (file buffer &optional revision) + "Annotate FILE, inserting the results in BUFFER. +Optional arg REVISION is a revision to annotate from." + (vc-setup-buffer buffer) + ;; Aside from the "head revision on the trunk", the instructions for + ;; each revision on the trunk are an ordered list of kill and insert + ;; commands necessary to go from the chronologically-following + ;; revision to this one. That is, associated with revision N are + ;; edits that applied to revision N+1 would result in revision N. + ;; + ;; On a branch, however, (some) things are inverted: the commands + ;; listed are those necessary to go from the chronologically-preceding + ;; revision to this one. That is, associated with revision N are + ;; edits that applied to revision N-1 would result in revision N. + ;; + ;; So, to get per-line history info, we apply reverse-chronological + ;; edits, starting with the head revision on the trunk, all the way + ;; back through the initial revision (typically "1.1" or similar), + ;; then apply forward-chronological edits -- keeping track of which + ;; revision is associated with each inserted line -- until we reach + ;; the desired revision for display (which may be either on the trunk + ;; or on a branch). + (let* ((tree (with-temp-buffer + (insert-file-contents (vc-rcs-registered file)) + (vc-rcs-parse))) + (revisions (cdr (assq 'revisions tree))) + ;; The revision N whose instructions we currently are processing. + (cur (cdr (assq 'head (cdr (assq 'headers tree))))) + ;; Alist from the parse tree for N. + (meta (cdr (assoc cur revisions))) + ;; Point and temporary string, respectively. + p s + ;; "Next-branch list". Nil means the desired revision to + ;; display lives on the trunk. Non-nil means it lives on a + ;; branch, in which case the value is a list of revision pairs + ;; (PARENT . CHILD), the first PARENT being on the trunk, that + ;; links each series of revisions in the path from the initial + ;; revision to the desired revision to display. + nbls + ;; "Path-accumulate-predicate plus revision/date/author". + ;; Until set, forward-chronological edits are not accumulated. + ;; Once set, its value (updated every revision) is used for + ;; the text property `:vc-rcs-r/d/a' for inserts during + ;; processing of forward-chronological instructions for N. + ;; See internal func `r/d/a'. + prda + ;; List of forward-chronological instructions, each of the + ;; form: (POS . ACTION), where POS is a buffer position. If + ;; ACTION is a string, it is inserted, otherwise it is taken as + ;; the number of characters to be deleted. + path + ;; N+1. When `cur' is "", this is the initial revision. + pre) + (unless revision + (setq revision cur)) + (unless (assoc revision revisions) + (error "No such revision: %s" revision)) + ;; Find which branches (if any) must be included in the edits. + (let ((par revision) + bpt kids) + (while (setq bpt (vc-branch-part par) + par (vc-branch-part bpt)) + (setq kids (cdr (assq 'branches (cdr (assoc par revisions))))) + ;; A branchpoint may have multiple children. Find the right one. + (while (not (string= bpt (vc-branch-part (car kids)))) + (setq kids (cdr kids))) + (push (cons par (car kids)) nbls))) + ;; Start with the full text. + (set-buffer buffer) + (insert (cdr (assq 'text meta))) + ;; Apply reverse-chronological edits on the trunk, computing and + ;; accumulating forward-chronological edits after some point, for + ;; later. + (flet ((r/d/a () (vector pre + (cdr (assq 'date meta)) + (cdr (assq 'author meta))))) + (while (when (setq pre cur cur (cdr (assq 'next meta))) + (not (string= "" cur))) + (setq + ;; Start accumulating the forward-chronological edits when N+1 + ;; on the trunk is either the desired revision to display, or + ;; the appropriate branchpoint for it. Do this before + ;; updating `meta' since `r/d/a' uses N+1's `meta' value. + prda (when (or prda (string= (if nbls (caar nbls) revision) pre)) + (r/d/a)) + meta (cdr (assoc cur revisions))) + ;; Edits in the parse tree specify a line number (in the buffer + ;; *BEFORE* editing occurs) to start from, but line numbers + ;; change as a result of edits. To DTRT, we apply edits in + ;; order of descending buffer position so that edits further + ;; down in the buffer occur first w/o corrupting specified + ;; buffer positions of edits occurring towards the beginning of + ;; the buffer. In this way we avoid using markers. A pleasant + ;; property of this approach is ability to push instructions + ;; onto `path' directly, w/o need to maintain rev boundaries. + (dolist (insn (cdr (assq :insn meta))) + (goto-line (pop insn)) + (setq p (point)) + (case (pop insn) + (k (setq s (buffer-substring-no-properties + p (progn (forward-line (car insn)) + (point)))) + (when prda + (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) + (delete-region p (point))) + (i (setq s (car insn)) + (when prda + (push `(,p . ,(length s)) path)) + (insert s))))) + ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is + ;; equivalent to pushing an insert instruction (of the entire buffer + ;; contents) onto `path' then erasing the buffer, but less wasteful. + (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a)) + ;; Now apply the forward-chronological edits for the trunk. + (dolist (insn path) + (goto-char (pop insn)) + (if (stringp insn) + (insert insn) + (delete-char insn))) + ;; Now apply the forward-chronological edits (directly from the + ;; parse-tree) for the branch(es), if necessary. We re-use vars + ;; `pre' and `meta' for the sake of internal func `r/d/a'. + (while nbls + (setq pre (cdr (pop nbls))) + (while (progn + (setq meta (cdr (assoc pre revisions)) + prda nil) + (dolist (insn (cdr (assq :insn meta))) + (goto-line (pop insn)) + (case (pop insn) + (k (delete-region + (point) (progn (forward-line (car insn)) + (point)))) + (i (insert (propertize + (car insn) + :vc-rcs-r/d/a + (or prda (setq prda (r/d/a)))))))) + (prog1 (not (string= (if nbls (caar nbls) revision) pre)) + (setq pre (cdr (assq 'next meta))))))))) + ;; Lastly, for each line, insert at bol nicely-formatted history info. + ;; We do two passes to collect summary information used to minimize + ;; the annotation's usage of screen real-estate: (1) Consider rendered + ;; width of revision plus author together as a unit; and (2) Omit + ;; author entirely if all authors are the same as the user. + (let ((ht (make-hash-table :test 'eq)) + (me (user-login-name)) + (maxw 0) + (all-me t) + rda w a) + (goto-char (point-max)) + (while (not (bobp)) + (forward-line -1) + (setq rda (get-text-property (point) :vc-rcs-r/d/a)) + (unless (gethash rda ht) + (setq a (aref rda 2) + all-me (and all-me (string= a me))) + (puthash rda (setq w (+ (length (aref rda 0)) + (length a))) + ht) + (setq maxw (max w maxw)))) + (let ((padding (make-string maxw 32))) + (flet ((pad (w) (substring-no-properties padding w)) + (render (rda &rest ls) + (propertize + (apply 'concat + (format-time-string "%Y-%m-%d" (aref rda 1)) + " " + (aref rda 0) + ls) + :vc-rcs-r/d/a rda))) + (maphash + (if all-me + (lambda (rda w) + (puthash rda (render rda (pad w) ": ") ht)) + (lambda (rda w) + (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht))) + ht))) + (while (not (eobp)) + (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht)) + (forward-line 1)))) + +(defun vc-rcs-annotate-current-time () + "Return the current time, based at midnight of the current day, and +encoded as fractional days." + (vc-annotate-convert-time + (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) + +(defun vc-rcs-annotate-time () + "Return the time of the next annotation (as fraction of days) +systime, or nil if there is none. Also, reposition point." + (unless (eobp) + (search-forward ": ") + (vc-annotate-convert-time + (aref (get-text-property (point) :vc-rcs-r/d/a) 1)))) + +(defun vc-rcs-annotate-extract-revision-at-line () + (aref (get-text-property (point) :vc-rcs-r/d/a) 0)) ;;; @@ -584,38 +735,6 @@ Needs RCS 5.6.2 or later for -M." ;;; Internal functions ;;; -(defun vc-rcs-trunk-p (rev) - "Return t if REV is an RCS revision on the trunk." - (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev)))) - -(defun vc-rcs-branch-part (rev) - "Return the branch part of an RCS revision number REV" - (substring rev 0 (string-match "\\.[0-9]+\\'" rev))) - -(defun vc-rcs-branch-p (rev) - "Return t if REV is an RCS branch revision" - (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev)))) - -(defun vc-rcs-minor-part (rev) - "Return the minor version number of an RCS revision number REV." - (string-match "[0-9]+\\'" rev) - (substring rev (match-beginning 0) (match-end 0))) - -(defun vc-rcs-previous-version (rev) - "Guess the previous RCS version number" - (let ((branch (vc-rcs-branch-part rev)) - (minor-num (string-to-number (vc-rcs-minor-part rev)))) - (if (> minor-num 1) - ;; version does probably not start a branch or release - (concat branch "." (number-to-string (1- minor-num))) - (if (vc-rcs-trunk-p rev) - ;; we are at the beginning of the trunk -- - ;; don't know anything to return here - "" - ;; we are at the beginning of a branch -- - ;; return version of starting point - (vc-rcs-branch-part branch))))) - (defun vc-rcs-workfile-is-newer (file) "Return non-nil if FILE is newer than its RCS master. This likely means that FILE has been changed with respect @@ -638,7 +757,7 @@ to its master version." (setq latest-rev rev) (setq value (match-string 1))))) (or value - (vc-rcs-branch-part branch)))) + (vc-branch-part branch)))) (defun vc-rcs-fetch-master-state (file &optional workfile-version) "Compute the master file's idea of the state of FILE. @@ -648,7 +767,10 @@ This function sets the properties `vc-workfile-version' and `vc-checkout-model' to their correct values, based on the master file." (with-temp-buffer - (vc-insert-file (vc-name file) "^[0-9]") + (if (or (not (vc-insert-file (vc-name file) "^[0-9]")) + (progn (goto-char (point-min)) + (not (looking-at "^head[ \t\n]+[^;]+;$")))) + (error "File %s is not an RCS master file" (vc-name file))) (let ((workfile-is-latest nil) (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1))) (vc-file-setprop file 'vc-rcs-default-branch default-branch) @@ -696,7 +818,7 @@ file." 'needs-patch)) ;; locked by the calling user ((and (stringp locking-user) - (string= locking-user (vc-user-login-name))) + (string= locking-user (vc-user-login-name file))) (if (or (eq (vc-checkout-model file) 'locking) workfile-is-latest (vc-rcs-latest-on-branch-p file workfile-version)) @@ -785,7 +907,8 @@ Returns: nil if no headers were found (vc-file-setprop file 'vc-state (cond ((eq locking-user 'none) 'up-to-date) - ((string= locking-user (vc-user-login-name)) 'edited) + ((string= locking-user (vc-user-login-name file)) + 'edited) (t locking-user))) ;; If the file has headers, we don't want to query the ;; master file, because that would eliminate all the @@ -837,7 +960,6 @@ CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)." (not (eq installation 'unknown))) (vc-release-greater-or-equal installation release)))) - (defun vc-rcs-system-release () "Return the RCS release installed on this system, as a string. Return symbol UNKNOWN if the release cannot be deducted. The user can @@ -861,6 +983,273 @@ variable `vc-rcs-release' is set to the returned value." (vc-do-command nil 0 "rcs" (vc-name file) (concat "-b" branch)) (vc-file-setprop file 'vc-rcs-default-branch branch)) +(defun vc-rcs-parse (&optional buffer) + "Parse current buffer, presumed to be in RCS-style masterfile format. +Optional arg BUFFER specifies another buffer to parse. Return an alist +of two elements, w/ keys `headers' and `revisions' and values in turn +sub-alists. For `headers', the values unless otherwise specified are +strings and the keys are: + + desc -- description + head -- latest revision + branch -- the branch the \"head revision\" lies on; + absent if the head revision lies on the trunk + access -- ??? + symbols -- sub-alist of (SYMBOL . REVISION) elements + locks -- if file is checked out, something like \"ttn:1.7\" + strict -- t if \"strict locking\" is in effect, otherwise nil + comment -- may be absent; typically something like \"# \" or \"; \" + expand -- may be absent; ??? + +For `revisions', the car is REVISION (string), the cdr a sub-alist, +with string values (unless otherwise specified) and keys: + + date -- a time value (like that returned by `encode-time'); as a + special case, a year value less than 100 is augmented by 1900 + author -- username + state -- typically \"Exp\" or \"Rel\" + branches -- list of revisions that begin branches from this revision + next -- on the trunk: the chronologically-preceding revision, or \"\"; + on a branch: the chronologically-following revision, or \"\" + log -- change log entry + text -- for the head revision on the trunk, the body of the file; + other revisions have `:insn' instead + :insn -- for non-head revisions, a list of parsed instructions + in one of two forms, in both cases START meaning \"first + go to line START\": + - `(START k COUNT)' -- kill COUNT lines + - `(START i TEXT)' -- insert TEXT (a string) + The list is in descending order by START. + +The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." + (setq buffer (get-buffer (or buffer (current-buffer)))) + (set-buffer buffer) + ;; An RCS masterfile can be viewed as containing four regular (for the + ;; most part) sections: (a) the "headers", (b) the "rev headers", (c) + ;; the "description" and (d) the "rev bodies", in that order. In the + ;; returned alist (see docstring), elements from (b) and (d) are + ;; combined pairwise to form the "revisions", while those from (a) and + ;; (c) are simply combined to form the "headers". + ;; + ;; Loosely speaking, each section contains a series of alternating + ;; "tags" and "printed representations". In the (b) and (d), many + ;; such series can appear, and a revision number on a line by itself + ;; precedes the series of tags and printed representations associated + ;; with it. + ;; + ;; In (a) and (b), the printed representations (with the exception of + ;; the `comment' tag in the headers) terminate with a semicolon, which + ;; is NOT part of the "value" finally associated with the tag. All + ;; other printed representations are in "@@-format"; there is an "@", + ;; the middle part (to be translated into the value), another "@" and + ;; a newline. Each "@@" in the middle part indicates the position of + ;; a single "@" (and consequently the requirement of an additional + ;; initial step when translating to the value). + ;; + ;; Parser state includes vars that collect parts of the return value... + (let ((desc nil) (headers nil) (revs nil) + ;; ... as well as vars that support a single-pass, tag-assisted, + ;; minimal-data-copying scan. Basically -- skirting around the + ;; grouping by revision required in (b) and (d) -- we repeatedly + ;; and context-sensitively read a tag (that MUST be present), + ;; determine the bounds of the printed representation, translate + ;; it into a value, and push the tag plus value onto one of the + ;; collection vars. Finally, we return the parse tree + ;; incorporating the values of the collection vars (see "rv"). + ;; + ;; A symbol or string to keep track of context (for error messages). + context + ;; A symbol, the current tag. + tok + ;; Region (begin and end buffer positions) of the printed + ;; representation for the current tag. + b e + ;; A list of buffer positions where "@@" can be found within the + ;; printed representation region. For each location, we push two + ;; elements onto the list, 1+ and 2+ the location, respectively, + ;; with the 2+ appearing at the head. In this way, the expression + ;; `(,e ,@@-holes ,b) + ;; describes regions that can be concatenated (in reverse order) + ;; to "de-@@-format" the printed representation as the first step + ;; to translating it into some value. See internal func `gather'. + @-holes) + (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' + (at (tag) (save-excursion (eq tag (read buffer)))) + (to-eol () (buffer-substring-no-properties + (point) (progn (forward-line 1) + (1- (point))))) + (to-semi () (setq b (point) + e (progn (search-forward ";") + (1- (point))))) + (to-one@ () (setq @-holes nil + b (progn (search-forward "@") (point)) + e (progn (while (and (search-forward "@") + (= ?@ (char-after)) + (progn + (push (point) @-holes) + (forward-char 1) + (push (point) @-holes)))) + (1- (point))))) + (tok+val (set-b+e name &optional proc) + (unless (eq name (setq tok (read buffer))) + (error "Missing `%s' while parsing %s" name context)) + (sw) + (funcall set-b+e) + (cons tok (if proc + (funcall proc) + (buffer-substring-no-properties b e)))) + (k-semi (name &optional proc) (tok+val 'to-semi name proc)) + (gather () (let ((pairs `(,e ,@@-holes ,b)) + acc) + (while pairs + (push (buffer-substring-no-properties + (cadr pairs) (car pairs)) + acc) + (setq pairs (cddr pairs))) + (apply 'concat acc))) + (k-one@ (name &optional later) (tok+val 'to-one@ name + (if later + (lambda () t) + 'gather)))) + (save-excursion + (goto-char (point-min)) + ;; headers + (setq context 'headers) + (flet ((hpush (name &optional proc) + (push (k-semi name proc) headers))) + (hpush 'head) + (when (at 'branch) + (hpush 'branch)) + (hpush 'access) + (hpush 'symbols + (lambda () + (mapcar (lambda (together) + (let ((two (split-string together ":"))) + (setcar two (intern (car two))) + (setcdr two (cadr two)) + two)) + (split-string + (buffer-substring-no-properties b e))))) + (hpush 'locks)) + (push `(strict . ,(when (at 'strict) + (search-forward ";") + t)) + headers) + (when (at 'comment) + (push (k-one@ 'comment) headers) + (search-forward ";")) + (when (at 'expand) + (push (k-one@ 'expand) headers) + (search-forward ";")) + (setq headers (nreverse headers)) + ;; rev headers + (sw) (setq context 'rev-headers) + (while (looking-at "[0-9]") + (push `(,(to-eol) + ,(k-semi 'date + (lambda () + (let ((ls (mapcar 'string-to-number + (split-string + (buffer-substring-no-properties + b e) + "\\.")))) + ;; Hack the year -- verified to be the + ;; same algorithm used in RCS 5.7. + (when (< (car ls) 100) + (setcar ls (+ 1900 (car ls)))) + (apply 'encode-time (nreverse ls))))) + ,@(mapcar 'k-semi '(author state)) + ,(k-semi 'branches + (lambda () + (split-string + (buffer-substring-no-properties b e)))) + ,(k-semi 'next)) + revs) + (sw)) + (setq revs (nreverse revs)) + ;; desc + (sw) (setq context 'desc + desc (k-one@ 'desc)) + ;; rev bodies + (let (acc + ;; Element of `revs' that initially holds only header info. + ;; "Pairwise combination" occurs when we add body info. + rev + ;; Components of the editing commands (aside from the actual + ;; text) that comprise the `text' printed representations + ;; (not including the "head" revision). + cmd start act + ;; Ascending (reversed) `@-holes' which the internal func + ;; `incg' pops to effect incremental gathering. + asc + ;; Function to extract text (for the `a' command), either + ;; `incg' or `buffer-substring-no-properties'. (This is + ;; for speed; strictly speaking, it is sufficient to use + ;; only the former since it behaves identically to the + ;; latter in the absense of "@@".) + sub) + (flet ((incg (beg end) (let ((b beg) (e end) @-holes) + (while (and asc (< (car asc) e)) + (push (pop asc) @-holes)) + ;; Self-deprecate when work is done. + ;; Folding many dimensions into one. + ;; Thanks B.Mandelbrot, for complex sum. + ;; O beauteous math! --the Unvexed Bum + (unless asc + (setq sub 'buffer-substring-no-properties)) + (gather)))) + (while (and (sw) + (not (eobp)) + (setq context (to-eol) + rev (or (assoc context revs) + (error "Rev `%s' has body but no head" + context)))) + (push (k-one@ 'log) (cdr rev)) + ;; For rev body `text' tags, delay translation slightly... + (push (k-one@ 'text t) (cdr rev)) + ;; ... until we decide which tag and value is appropriate to + ;; collect. For the "head" revision, compute the value of the + ;; `text' printed representation by simple `gather'. For all + ;; other revisions, replace the `text' tag+value with `:insn' + ;; plus value, always scanning in-place. + (if (string= context (cdr (assq 'head headers))) + (setcdr (cadr rev) (gather)) + (if @-holes + (setq asc (nreverse @-holes) + sub 'incg) + (setq sub 'buffer-substring-no-properties)) + (goto-char b) + (setq acc nil) + (while (< (point) e) + (forward-char 1) + (setq cmd (char-before) + start (read (current-buffer)) + act (read (current-buffer))) + (forward-char 1) + (push (case cmd + (?d + ;; `d' means "delete lines". + ;; For Emacs spirit, we use `k' for "kill". + `(,start k ,act)) + (?a + ;; `a' means "append after this line" but + ;; internally we normalize it so that START + ;; specifies the actual line for insert, thus + ;; requiring less hair in the realization algs. + ;; For Emacs spirit, we use `i' for "insert". + `(,(1+ start) i + ,(funcall sub (point) (progn (forward-line act) + (point))))) + (t (error "Bad command `%c' in `text' for rev `%s'" + cmd context))) + acc)) + (goto-char (1+ e)) + (setcar (cdr rev) (cons :insn acc))))))) + ;; rv + `((headers ,desc ,@headers) + (revisions ,@revs))))) + (provide 'vc-rcs) +;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf ;;; vc-rcs.el ends here