X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b1a765b3a8586cd53c21579982c8fbc0ce534336..9ea6c4df441d85be44dadad4fbd57d2c0f3be4f1:/lisp/vc/vc-rcs.el diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 20b292f5fe..ba1336424e 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -1,6 +1,6 @@ ;;; vc-rcs.el --- support for RCS version-control -*- lexical-binding:t -*- -;; Copyright (C) 1992-2014 Free Software Foundation, Inc. +;; Copyright (C) 1992-2015 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel @@ -76,7 +76,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." :version "21.1" :group 'vc-rcs) -(defcustom vc-rcs-header '("\$Id\$") +(defcustom vc-rcs-header '("$Id\ $") "Header keywords to be inserted by `vc-insert-headers'." :type '(repeat string) :version "24.1" ; no longer consult the obsolete vc-header-alist @@ -226,12 +226,10 @@ When VERSION is given, perform check for that version." (defun vc-rcs-register (files &optional comment) "Register FILES into the RCS version-control system. +Automatically retrieve a read-only version of the file with keywords expanded. COMMENT can be used to provide an initial description for each FILES. Passes either `vc-rcs-register-switches' or `vc-register-switches' -to the RCS command. - -Automatically retrieve a read-only version of the file with keywords -expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." +to the RCS command." (let (subdir name) (dolist (file files) (and (not (file-exists-p @@ -244,7 +242,10 @@ expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." (apply #'vc-do-command "*vc*" 0 "ci" file ;; if available, use the secure registering option (and (vc-rcs-release-p "5.6.4") "-i") - (and comment (concat "-t-" comment)) + "-u" + ;; Some old MS-Windows ports of RCS crash when "ci -i" is + ;; invoked without -t; indulge them. + (concat "-t-" (or comment "")) (vc-switches 'RCS 'register)) ;; parse output to find master file name and workfile version (with-current-buffer "*vc*" @@ -289,46 +290,43 @@ expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." "Unregister FILE from RCS. If this leaves the RCS subdirectory empty, ask the user whether to remove it." - (let* ((master (vc-master-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)))) - -;; It used to be possible to pass in a value for the variable rev, but -;; nothing in the rest of VC used this capability. Removing it makes the -;; backend interface simpler for all modes. -;; -(defun vc-rcs-checkin (files comment) + (unless (memq (vc-state file) '(nil unregistered)) + (let* ((master (vc-master-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))))) + +(defun vc-rcs-checkin (files comment &optional rev) "RCS-specific version of `vc-backend-checkin'." - (let (rev (switches (vc-switches 'RCS 'checkin))) + (let ((switches (vc-switches 'RCS 'checkin))) ;; Now operate on the files (dolist (file (vc-expand-dirs files 'RCS)) (let ((old-version (vc-working-revision 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 default-branch + (and (not rev) + default-branch (string-match (concat "^" (regexp-quote old-version) "\\.") default-branch) (setq rev default-branch) (setq switches (cons "-f" switches))) - (if old-version - (setq rev (vc-branch-part old-version)) - (error "can't find current branch")) + (if (and (not rev) old-version) + (setq rev (vc-branch-part old-version))) (apply #'vc-do-command "*vc*" 0 "ci" (vc-master-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 "-u" rev) (concat "-m" comment) switches) (vc-file-setprop file 'vc-working-revision nil) @@ -433,43 +431,6 @@ attempt the checkout for all registered files beneath it." new-version))))) (message "Checking out %s...done" file)))))) -(defun vc-rcs-rollback (files) - "Roll back, undoing the most recent checkins of FILES. Directories are -expanded to all registered subfiles in them." - (if (not files) - (error "RCS backend doesn't support directory-level rollback")) - (dolist (file (vc-expand-dirs files 'RCS)) - (let* ((discard (vc-working-revision file)) - (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard))) - (config (current-window-configuration)) - (done nil)) - (if (null (yes-or-no-p (format "Remove version %s from %s history? " - discard file))) - (error "Aborted")) - (message "Removing revision %s from %s." discard file) - (vc-do-command "*vc*" 0 "rcs" (vc-master-name file) (concat "-o" discard)) - ;; 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 "*vc*" 0 "co" (vc-master-name file) "-f" - (concat "-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-revert (file &optional _contents-done) "Revert FILE to the version it was based on. If FILE is a directory, revert all registered files beneath it." @@ -573,7 +534,7 @@ files beneath it." (vc-rcs-print-log-cleanup)) (when limit 'limit-unsupported)) -(defun vc-rcs-diff (files &optional async oldvers newvers buffer) +(defun vc-rcs-diff (files &optional oldvers newvers buffer async) "Get a difference report using RCS between two sets of files." (apply #'vc-do-command (or buffer "*vc-diff*") (if async 'async 1) @@ -795,7 +756,7 @@ Optional arg REVISION is a revision to annotate from." (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht)) (forward-line 1)))) -(declare-function vc-annotate-convert-time "vc-annotate" (time)) +(declare-function vc-annotate-convert-time "vc-annotate" (&optional time)) (defun vc-rcs-annotate-current-time () "Return the current time, based at midnight of the current day, and @@ -1009,74 +970,75 @@ otherwise determine the workfile version based on the master file. This function sets the properties `vc-working-revision' and `vc-checkout-model' to their correct values, based on the master file." - (with-temp-buffer - (if (or (not (vc-insert-file (vc-master-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-master-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 working-revision - ;; 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 working-revision - (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 working-revision default-branch)) - ;; else, search for the head of the default branch - (t (vc-insert-file (vc-master-name file) "^desc") + (when (and (file-regular-p file) (vc-master-name file)) + (with-temp-buffer + (if (or (not (vc-insert-file (vc-master-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-master-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 working-revision + ;; 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 working-revision - (vc-rcs-find-most-recent-rev default-branch)) - (setq workfile-is-latest t))) - (vc-file-setprop file 'vc-working-revision working-revision)) - ;; Check strict locking - (goto-char (point-min)) - (vc-file-setprop file 'vc-checkout-model - (if (re-search-forward ";[ \t\n]*strict;" nil t) - 'locking 'implicit)) - ;; Compute state of workfile version - (goto-char (point-min)) - (let ((locking-user - (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):" - (regexp-quote working-revision) - "[^0-9.]") - 1))) - (cond - ;; not locked - ((not locking-user) - (if (or workfile-is-latest - (vc-rcs-latest-on-branch-p file working-revision)) - ;; workfile version is latest on branch - 'up-to-date - ;; workfile version is not latest on branch - 'needs-update)) - ;; locked by the calling user - ((and (stringp locking-user) - (string= locking-user (vc-user-login-name file))) - ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping. - (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking) - workfile-is-latest - (vc-rcs-latest-on-branch-p file working-revision)) - 'edited - ;; Locking is not used for the file, but the owner does - ;; have a lock, and there is a higher version on the current - ;; branch. Not sure if this can occur, and if it is right - ;; to use `needs-merge' in this case. - 'needs-merge)) - ;; locked by somebody else - ((stringp locking-user) - locking-user) - (t - (error "Error getting state of RCS file"))))))) + (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 working-revision default-branch)) + ;; else, search for the head of the default branch + (t (vc-insert-file (vc-master-name file) "^desc") + (setq working-revision + (vc-rcs-find-most-recent-rev default-branch)) + (setq workfile-is-latest t))) + (vc-file-setprop file 'vc-working-revision working-revision)) + ;; Check strict locking + (goto-char (point-min)) + (vc-file-setprop file 'vc-checkout-model + (if (re-search-forward ";[ \t\n]*strict;" nil t) + 'locking 'implicit)) + ;; Compute state of workfile version + (goto-char (point-min)) + (let ((locking-user + (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):" + (regexp-quote working-revision) + "[^0-9.]") + 1))) + (cond + ;; not locked + ((not locking-user) + (if (or workfile-is-latest + (vc-rcs-latest-on-branch-p file working-revision)) + ;; workfile version is latest on branch + 'up-to-date + ;; workfile version is not latest on branch + 'needs-update)) + ;; locked by the calling user + ((and (stringp locking-user) + (string= locking-user (vc-user-login-name file))) + ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping. + (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking) + workfile-is-latest + (vc-rcs-latest-on-branch-p file working-revision)) + 'edited + ;; Locking is not used for the file, but the owner does + ;; have a lock, and there is a higher version on the current + ;; branch. Not sure if this can occur, and if it is right + ;; to use `needs-merge' in this case. + 'needs-merge)) + ;; locked by somebody else + ((stringp locking-user) + locking-user) + (t + (error "Error getting state of RCS file")))))))) (defun vc-rcs-consult-headers (file) "Search for RCS headers in FILE, and set properties accordingly. @@ -1152,12 +1114,12 @@ Returns: nil if no headers were found (defun vc-release-greater-or-equal (r1 r2) "Compare release numbers, represented as strings. Release components are assumed cardinal numbers, not decimal fractions -\(5.10 is a higher release than 5.9\). Omitted fields are considered -lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end +\(5.10 is a higher release than 5.9). Omitted fields are considered +lower \(5.6.7 is earlier than 5.6.7.1). Comparison runs till the end of the string is found, or a non-numeric component shows up \(5.6.7 is earlier than \"5.6.7 beta\", which is probably not what you want in -some cases\). This code is suitable for existing RCS release numbers. -CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)." +some cases). This code is suitable for existing RCS release numbers. +CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5)." (let (v1 v2 i1 i2) (catch 'done (or (and (string-match "^\\.?\\([0-9]+\\)" r1)