X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7849e1791b45b99565a0d828bff0dac686c0e230..4f5ab6d5eb93dfb674e6bc0315cf56a7a2a5552b:/lisp/vc-rcs.el diff --git a/lisp/vc-rcs.el b/lisp/vc-rcs.el index 34dbb927c6..e591baf3a2 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, 2004 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel -;; $Id: vc-rcs.el,v 1.8 2000/10/01 11:17:42 spiegel Exp $ +;; $Id$ ;; This file is part of GNU Emacs. @@ -21,15 +22,22 @@ ;; 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: +;;; +;;; Customization options +;;; + (eval-when-compile - (require 'cl)) + (require 'cl) + (require 'vc)) (defcustom vc-rcs-release nil "*The release number of your RCS installation, as a string. @@ -51,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" @@ -75,7 +71,7 @@ These are passed to the checkout program by \\[vc-rcs-checkout]." (defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$")) "*Header keywords to be inserted by `vc-insert-headers'." - :type 'string + :type '(repeat string) :version "21.1" :group 'vc) @@ -99,8 +95,18 @@ For a description of possible values, see `vc-check-master-templates'." :version "21.1" :group 'vc) -;;;###autoload -(progn (defun vc-rcs-registered (f) (vc-default-registered 'RCS f))) + +;;; +;;; State-querying functions +;;; + +;;; 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." @@ -114,11 +120,13 @@ For a description of possible values, see `vc-check-master-templates'." (vc-rcs-fetch-master-state file (vc-file-getprop file 'vc-workfile-version)))) - (if (eq state 'up-to-date) - (if (vc-workfile-unchanged-p file) - 'up-to-date - 'unlocked-changes) - state))) + (if (not (eq state 'up-to-date)) + state + (if (vc-workfile-unchanged-p file) + 'up-to-date + (if (eq (vc-checkout-model file) 'locking) + 'unlocked-changes + 'edited))))) (defun vc-rcs-state-heuristic (file) "State heuristic for RCS." @@ -136,9 +144,9 @@ 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)))) @@ -155,7 +163,7 @@ For a description of possible values, see `vc-check-master-templates'." (if (file-ownership-preserved-p file) 'edited (vc-user-login-name owner-uid)) - (if (vc-rcs-workfile-is-newer file) + (if (vc-rcs-workfile-is-newer file) 'edited 'up-to-date))) (t @@ -164,16 +172,6 @@ For a description of possible values, see `vc-check-master-templates'." (vc-rcs-state file)))) (vc-rcs-state file))))) -(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 -to its master version." - (let ((file-time (nth 5 (file-attributes file))) - (master-time (nth 5 (file-attributes (vc-name file))))) - (or (> (nth 0 file-time) (nth 0 master-time)) - (and (= (nth 0 file-time) (nth 0 master-time)) - (> (nth 1 file-time) (nth 1 master-time)))))) - (defun vc-rcs-workfile-version (file) "RCS-specific version of `vc-workfile-version'." (or (and vc-consult-headers @@ -183,14 +181,569 @@ to its master version." (vc-rcs-fetch-master-state file) (vc-file-getprop file 'vc-workfile-version)))) +(defun vc-rcs-latest-on-branch-p (file &optional version) + "Return non-nil if workfile version of FILE is the latest on its branch. +When VERSION is given, perform check for that version." + (unless version (setq version (vc-workfile-version file))) + (with-temp-buffer + (string= version + (if (vc-trunk-p version) + (progn + ;; Compare VERSION to the head version number. + (vc-insert-file (vc-name file) "^[0-9]") + (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) + ;; 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-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'." + ;; 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))) + (status (if (eq vc-rcsdiff-knows-brief 'no) + (vc-do-command nil 1 "rcsdiff" file version) + (vc-do-command nil 2 "rcsdiff" file "--brief" version)))) + (if (eq status 2) + (if (not vc-rcsdiff-knows-brief) + (setq vc-rcsdiff-knows-brief 'no + status (vc-do-command nil 1 "rcsdiff" file version)) + (error "rcsdiff failed")) + (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes))) + ;; The workfile is unchanged if rcsdiff found no differences. + (zerop status))) + + +;;; +;;; State-changing functions +;;; + +(defun vc-rcs-register (file &optional rev comment) + "Register FILE into the RCS version-control system. +REV is the optional revision number for the file. COMMENT can be used +to provide an initial description of FILE. + +`vc-register-switches' and `vc-rcs-register-switches' are passed to +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)))) + (and (not (file-exists-p subdir)) + (not (directory-files (file-name-directory file) + nil ".*,v$" t)) + (yes-or-no-p "Create RCS subdirectory? ") + (make-directory subdir)) + (apply 'vc-do-command nil 0 "ci" file + ;; if available, use the secure registering option + (and (vc-rcs-release-p "5.6.4") "-i") + (concat (if vc-keep-workfiles "-u" "-r") rev) + (and comment (concat "-t-" comment)) + (vc-switches 'RCS 'register)) + ;; parse output to find master file name and workfile version + (with-current-buffer "*vc*" + (goto-char (point-min)) + (let ((name (if (looking-at (concat "^\\(.*\\) <-- " + (file-name-nondirectory file))) + (match-string 1)))) + (if (not name) + ;; if we couldn't find the master name, + ;; run vc-rcs-registered to get it + ;; (will be stored into the vc-name property) + (vc-rcs-registered file) + (vc-file-setprop file 'vc-name + (if (file-name-absolute-p name) + name + (expand-file-name + name + (file-name-directory file)))))) + (vc-file-setprop file 'vc-workfile-version + (if (re-search-forward + "^initial revision: \\([0-9.]+\\).*\n" + nil t) + (match-string 1)))))) + +(defun vc-rcs-responsible-p (file) + "Return non-nil if RCS thinks it would be responsible for registering FILE." + ;; TODO: check for all the patterns in vc-rcs-master-templates + (file-directory-p (expand-file-name "RCS" (file-name-directory file)))) + +(defun vc-rcs-receive-file (file rev) + "Implementation of receive-file for RCS." + (let ((checkout-model (vc-checkout-model file))) + (vc-rcs-register file rev "") + (when (eq checkout-model 'implicit) + (vc-rcs-set-non-strict-locking file)) + (vc-rcs-set-default-branch file (concat rev ".1")))) + +(defun vc-rcs-unregister (file) + "Unregister FILE from RCS. +If this leaves the RCS subdirectory empty, ask the user +whether to remove it." + (let* ((master (vc-name file)) + (dir (file-name-directory master)) + (backup-info (find-backup-file-name master))) + (if (not backup-info) + (delete-file master) + (rename-file master (car backup-info) 'ok-if-already-exists) + (dolist (f (cdr backup-info)) (ignore-errors (delete-file f)))) + (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 + "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*")) + (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) + (delete-directory dir)))) -;;; internal code +(defun vc-rcs-checkin (file rev comment) + "RCS-specific version of `vc-backend-checkin'." + (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 + ;; default branch has been set. + (and (not rev) + default-branch + (string-match (concat "^" (regexp-quote old-version) "\\.") + 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") + (concat (if vc-keep-workfiles "-u" "-r") rev) + (concat "-m" comment) + switches) + (vc-file-setprop file 'vc-workfile-version nil) + + ;; determine the new workfile version + (set-buffer "*vc*") + (goto-char (point-min)) + (when (or (re-search-forward + "new revision: \\([0-9.]+\\);" nil t) + (re-search-forward + "reverting to previous revision \\([0-9.]+\\)" nil t)) + (setq new-version (match-string 1)) + (vc-file-setprop file 'vc-workfile-version new-version)) + + ;; if we got to a different branch, adjust the default + ;; branch accordingly + (cond + ((and old-version 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")) + ;; exit status of 1 is also accepted. + ;; It means that the lock was removed before. + (vc-do-command nil 1 "rcs" (vc-name file) + (concat "-u" old-version)))))))) + +(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..." file) + (save-excursion + ;; Change buffers to get local value of vc-checkout-switches. + (if file-buffer (set-buffer file-buffer)) + (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. + (let ((default-directory default-directory)) + (save-excursion + ;; Adjust the default-directory so that the check-out creates + ;; the file in the right place. + (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 (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. +EDITABLE non-nil means previous version should be locked." + (let* ((target (vc-workfile-version file)) + (previous (if (vc-trunk-p target) "" (vc-branch-part target))) + (config (current-window-configuration)) + (done nil)) + (vc-do-command nil 0 "rcs" (vc-name file) (concat "-o" target)) + ;; Check out the most recent remaining version. If it fails, because + ;; the whole branch got deleted, do a double-take and check out the + ;; version where the branch started. + (while (not done) + (condition-case err + (progn + (vc-do-command nil 0 "co" (vc-name file) "-f" + (concat (if editable "-l" "-u") previous)) + (setq done t)) + (error (set-buffer "*vc*") + (goto-char (point-min)) + (if (search-forward "no side branches present for" nil t) + (progn (setq previous (vc-branch-part previous)) + (vc-rcs-set-default-branch file previous) + ;; vc-do-command popped up a window with + ;; the error message. Get rid of it, by + ;; restoring the old window configuration. + (set-window-configuration config)) + ;; No, it was some other error: re-signal it. + (signal (car err) (cdr err)))))))) + +(defun vc-rcs-merge (file first-version &optional second-version) + "Merge changes into current working copy of FILE. +The changes are between FIRST-VERSION and SECOND-VERSION." + (vc-do-command nil 1 "rcsmerge" (vc-name file) + "-kk" ; ignore keyword conflicts + (concat "-r" first-version) + (if second-version (concat "-r" 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)) + ;; 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))) + + + +;;; +;;; History functions +;;; + +(defun vc-rcs-print-log (file &optional buffer) + "Get change log associated with FILE." + (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))) + (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)) + + +;;; +;;; Snapshot system +;;; + +(defun vc-rcs-assign-name (file name) + "Assign to FILE's latest version a given NAME." + (vc-do-command nil 0 "rcs" (vc-name file) (concat "-n" name ":"))) + + +;;; +;;; Miscellaneous +;;; + +(defun vc-rcs-check-headers () + "Check if the current file has any headers in it." + (save-excursion + (goto-char (point-min)) + (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ +\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) + +(defun vc-rcs-clear-headers () + "Implementation of vc-clear-headers for RCS." + (let ((case-fold-search nil)) + (goto-char (point-min)) + (while (re-search-forward + (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|" + "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$") + nil t) + (replace-match "$\\1$")))) + +(defun vc-rcs-rename-file (old new) + ;; Just move the master file (using vc-rcs-master-templates). + (vc-rename-master (vc-name old) new vc-rcs-master-templates)) + + +;;; +;;; Internal functions +;;; + +(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 +to its master version." + (let ((file-time (nth 5 (file-attributes file))) + (master-time (nth 5 (file-attributes (vc-name file))))) + (or (> (nth 0 file-time) (nth 0 master-time)) + (and (= (nth 0 file-time) (nth 0 master-time)) + (> (nth 1 file-time) (nth 1 master-time)))))) (defun vc-rcs-find-most-recent-rev (branch) "Find most recent revision on BRANCH." @@ -204,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. @@ -214,30 +767,34 @@ 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]") - (let ((workfile-is-latest nil)) + (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) (unless workfile-version - (let ((default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1))) - ;; Workfile version not known yet. Determine that first. It - ;; is either the head of the trunk, the head of the default - ;; branch, or the "default branch" itself, if that is a full - ;; revision number. - (cond - ;; no default branch - ((or (not default-branch) (string= "" default-branch)) + ;; Workfile version not known yet. Determine that first. It + ;; is either the head of the trunk, the head of the default + ;; branch, or the "default branch" itself, if that is a full + ;; revision number. + (cond + ;; no default branch + ((or (not default-branch) (string= "" default-branch)) + (setq workfile-version + (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) + (setq workfile-is-latest t)) + ;; default branch is actually a revision + ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$" + default-branch) + (setq workfile-version default-branch)) + ;; else, search for the head of the default branch + (t (vc-insert-file (vc-name file) "^desc") (setq workfile-version - (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) - (setq workfile-is-latest t)) - ;; default branch is actually a revision - ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$" - default-branch) - (setq workfile-version default-branch)) - ;; else, search for the head of the default branch - (t (vc-insert-file (vc-name file) "^desc") - (setq workfile-version - (vc-rcs-find-most-recent-rev default-branch)) - (setq workfile-is-latest t))) - (vc-file-setprop file 'vc-workfile-version workfile-version))) + (vc-rcs-find-most-recent-rev default-branch)) + (setq workfile-is-latest t))) + (vc-file-setprop file 'vc-workfile-version workfile-version)) ;; Check strict locking (goto-char (point-min)) (vc-file-setprop file 'vc-checkout-model @@ -256,12 +813,7 @@ file." (if (or workfile-is-latest (vc-rcs-latest-on-branch-p file workfile-version)) ;; workfile version is latest on branch - (if (eq (vc-checkout-model file) 'locking) - 'up-to-date - (require 'vc) - (if (vc-workfile-unchanged-p file) - 'up-to-date - 'edited)) + 'up-to-date ;; workfile version is not latest on branch 'needs-patch)) ;; locked by the calling user @@ -372,180 +924,6 @@ Returns: nil if no headers were found (vc-file-setprop file 'vc-checkout-model 'implicit))) status)))) -(defun vc-rcs-workfile-unchanged-p (file) - "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))) - (status (if (eq vc-rcsdiff-knows-brief 'no) - (vc-do-command nil 1 "rcsdiff" file version) - (vc-do-command nil 2 "rcsdiff" file "--brief" version)))) - (if (eq status 2) - (if (not vc-rcsdiff-knows-brief) - (setq vc-rcsdiff-knows-brief 'no - status (vc-do-command nil 1 "rcsdiff" file version)) - (error "rcsdiff failed")) - (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes))) - ;; The workfile is unchanged if rcsdiff found no differences. - (zerop status))) - -(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-latest-on-branch-p (file &optional version) - "Return non-nil if workfile version of FILE is the latest on its branch. -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) - (progn - ;; Compare VERSION to the head version number. - (vc-insert-file (vc-name file) "^[0-9]") - (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) - ;; 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)))))) - -(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-print-log (file) - "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-assign-name (file name) - "Assign to FILE's latest version a given NAME." - (vc-do-command nil 0 "rcs" (vc-name file) (concat "-n" name ":"))) - -(defun vc-rcs-merge (file first-version &optional second-version) - "Merge changes into current working copy of FILE. -The changes are between FIRST-VERSION and SECOND-VERSION." - (vc-do-command nil 1 "rcsmerge" (vc-name file) - "-kk" ; ignore keyword conflicts - (concat "-r" first-version) - (if second-version (concat "-r" second-version)))) - -(defun vc-rcs-check-headers () - "Check if the current file has any headers in it." - (save-excursion - (goto-char (point-min)) - (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ -\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) - -(defun vc-rcs-clear-headers () - "Implementation of vc-clear-headers for RCS." - (let ((case-fold-search nil)) - (goto-char (point-min)) - (while (re-search-forward - (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|" - "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$") - nil t) - (replace-match "$\\1$")))) - -(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))) - -(defun vc-rcs-cancel-version (file writable) - "Undo the most recent checkin of FILE. -WRITABLE non-nil means previous version should be locked." - (let* ((target (vc-workfile-version file)) - (previous (if (vc-trunk-p target) "" (vc-branch-part target))) - (config (current-window-configuration)) - (done nil)) - (vc-do-command nil 0 "rcs" (vc-name file) (concat "-o" target)) - ;; Check out the most recent remaining version. If it fails, because - ;; the whole branch got deleted, do a double-take and check out the - ;; version where the branch started. - (while (not done) - (condition-case err - (progn - (vc-do-command nil 0 "co" (vc-name file) "-f" - (concat (if writable "-l" "-u") previous)) - (setq done t)) - (error (set-buffer "*vc*") - (goto-char (point-min)) - (if (search-forward "no side branches present for" nil t) - (progn (setq previous (vc-branch-part previous)) - (vc-do-command nil 0 "rcs" (vc-name file) - (concat "-b" previous)) - ;; vc-do-command popped up a window with - ;; the error message. Get rid of it, by - ;; restoring the old window configuration. - (set-window-configuration config)) - ;; No, it was some other error: re-signal it. - (signal (car err) (cdr err)))))))) - -(defun vc-rcs-revert (file) - "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)))) - -(defun vc-rcs-rename-file (old new) - ;; Just move the master file (using vc-rcs-master-templates). - (vc-rename-master (vc-name old) new vc-rcs-master-templates)) - (defun vc-release-greater-or-equal (r1 r2) "Compare release numbers, represented as strings. Release components are assumed cardinal numbers, not decimal fractions @@ -581,51 +959,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-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 ((old-version (vc-workfile-version file)) new-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") - (concat (if vc-keep-workfiles "-u" "-r") rev) - (concat "-m" comment) - ;; allow creation of branches with no changes; - ;; this is used by vc-rcs-receive-file if the - ;; base version cannot be found - (if (and (stringp rev) (string-match ".1.1$" rev)) "-f") - switches) - (vc-file-setprop file 'vc-workfile-version nil) - - ;; determine the new workfile version - (set-buffer "*vc*") - (goto-char (point-min)) - (when (or (re-search-forward - "new revision: \\([0-9.]+\\);" nil t) - (re-search-forward - "reverting to previous revision \\([0-9.]+\\)" nil t)) - (setq new-version (match-string 1)) - (vc-file-setprop file 'vc-workfile-version new-version)) - - ;; if we got to a different branch, adjust the default - ;; branch accordingly - (cond - ((and old-version new-version - (not (string= (vc-rcs-branch-part old-version) - (vc-rcs-branch-part new-version)))) - (vc-do-command nil 0 "rcs" (vc-name file) - (if (vc-rcs-trunk-p new-version) "-b" - (concat "-b" (vc-rcs-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")) - ;; exit status of 1 is also accepted. - ;; It means that the lock was removed before. - (vc-do-command nil 1 "rcs" (vc-name file) - (concat "-u" old-version)))))))) - (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 @@ -640,211 +973,282 @@ variable `vc-rcs-release' is set to the returned value." (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1))) 'unknown)))) -(defun vc-rcs-diff (file &optional oldvers newvers) - "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))) - -(defun vc-rcs-responsible-p (file) - "Return non-nil if RCS thinks it would be responsible for registering FILE." - ;; TODO: check for all the patterns in vc-rcs-master-templates - (file-directory-p (expand-file-name "RCS" (file-name-directory file)))) - -(defun vc-rcs-register (file &optional rev comment) - "Register FILE into the RCS version-control system. -REV is the optional revision number for the file. COMMENT can be used -to provide an initial description of FILE. +(defun vc-rcs-set-non-strict-locking (file) + (vc-do-command nil 0 "rcs" file "-U") + (vc-file-setprop file 'vc-checkout-model 'implicit) + (set-file-modes file (logior (file-modes file) 128))) -`vc-register-switches' and `vc-rcs-register-switches' are passed to -the RCS command (in that order). +(defun vc-rcs-set-default-branch (file branch) + (vc-do-command nil 0 "rcs" (vc-name file) (concat "-b" branch)) + (vc-file-setprop file 'vc-rcs-default-branch branch)) -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)))) - - (and (not (file-exists-p subdir)) - (not (directory-files (file-name-directory file) - nil ".*,v$" t)) - (yes-or-no-p "Create RCS subdirectory? ") - (make-directory subdir)) - (apply 'vc-do-command nil 0 "ci" file - ;; if available, use the secure registering option - (and (vc-rcs-release-p "5.6.4") "-i") - (concat (if vc-keep-workfiles "-u" "-r") rev) - (and comment (concat "-t-" comment)) - switches) - ;; parse output to find master file name and workfile version - (with-current-buffer "*vc*" - (goto-char (point-min)) - (let ((name (if (looking-at (concat "^\\(.*\\) <-- " - (file-name-nondirectory file))) - (match-string 1)))) - (if (not name) - ;; if we couldn't find the master name, - ;; run vc-rcs-registered to get it - ;; (will be stored into the vc-name property) - (vc-rcs-registered file) - (vc-file-setprop file 'vc-name - (if (file-name-absolute-p name) - name - (expand-file-name - name - (file-name-directory file)))))) - (vc-file-setprop file 'vc-workfile-version - (if (re-search-forward - "^initial revision: \\([0-9.]+\\).*\n" - nil t) - (match-string 1)))))) +(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: -(defun vc-rcs-unregister (file) - "Unregister FILE from RCS. -If this leaves the RCS subdirectory empty, ask the user -whether to remove it." - (let* ((master (vc-name file)) - (dir (file-name-directory master)) - (backup-info (find-backup-file-name master))) - (if (not backup-info) - (delete-file master) - (rename-file master (car backup-info) 'ok-if-already-exists) - (dolist (f (cdr backup-info)) (ignore-errors (delete-file f)))) - (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 - "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*")) - (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) - (delete-directory dir)))) + 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; ??? -(defun vc-rcs-receive-file (file move) - "Implementation of receive-file for RCS." - (let ((old-backend (vc-backend file)) - (rev (vc-workfile-version file)) - (state (vc-state file)) - (checkout-model (vc-checkout-model file)) - (comment (and move (vc-call comment-history file)))) - (if move (vc-unregister file)) - (vc-file-clearprops file) - (if (not (vc-rcs-registered file)) - (progn - ;; TODO: If the file was 'edited under the old backend, - ;; this should actually register the version - ;; it was based on. - (vc-rcs-register file rev "") - (vc-file-setprop file 'vc-backend 'RCS) - (if (eq checkout-model 'implicit) - (vc-rcs-set-non-strict-locking file)) - (if (not move) - (vc-do-command nil 0 "rcs" file (concat "-b" rev ".1")))) - (vc-file-setprop file 'vc-backend 'RCS) - (vc-file-setprop file 'vc-state 'edited) - (set-file-modes file - (logior (file-modes file) 128))) - (when (or move (eq state 'edited)) - (vc-file-setprop file 'vc-state 'edited) - ;; Explicit branch revision number will cause vc-rcs-checkin - ;; to use "ci -f". This is a trick to force creation of - ;; the branch, even if we couldn't use the unmodified base - ;; version for registration above. - (vc-checkin file (concat rev ".1.1") comment (stringp comment))))) +For `revisions', the car is REVISION (string), the cdr a sub-alist, +with string values (unless otherwise specified) and keys: -(defun vc-rcs-set-non-strict-locking (file) - (vc-do-command nil 0 "rcs" file "-U") - (vc-file-setprop file 'vc-checkout-model 'implicit) - (set-file-modes file (logior (file-modes file) 128))) + 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. -(defun vc-rcs-checkout (file &optional writable 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)) - switches) - (message "Checking out %s..." filename) - (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)) - ;; Save this buffer's default-directory - ;; and use save-excursion to make sure it is restored - ;; in the same buffer it was saved in. - (let ((default-directory default-directory)) - (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 writable 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 writable "-l") - (concat "-p" rev) - switches))) - (set-file-modes filename - (logior (file-modes (vc-name file)) - (if writable 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-do-command nil 0 "rcs" (vc-name file) "-b")) - ;; 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 writable "-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-do-command - nil 0 "rcs" (vc-name file) - (concat "-b" - (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))))) +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