comparison lisp/vc-rcs.el @ 94809:76b523d99056

Teach the RCS back end to do directories.

94808:8b60ad9b42c3

;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; See vc.el

;; TODO:
;; - remove call to vc-expand-dirs by implementing our own (which can just
;;   list the RCS subdir instead).

;;; Code:

;;;
;;; Customization options

(defun vc-rcs-checkin (files rev comment)
  "RCS-specific version of `vc-backend-checkin'."
  (let ((switches (vc-switches 'RCS 'checkin)))
    ;; Now operate on the files
    (dolist (file files)
      (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 (not rev)

	 "-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-rcs-checkout-model (list file)) 'implicit) "-f")
		   (if editable "-l")
                   (if (stringp rev)
                       ;; a literal revision was specified
                       (concat "-r" rev)
                     (let ((workrev (vc-working-revision 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*"

		  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-rollback (files)
  "Roll back, undoing the most recent checkins of FILES."
  (if (not files)
      (error "RCS backend doesn't support directory-level rollback."))
  (dolist (file files)
	  (let* ((discard (vc-working-revision file))
		 (previous (if (vc-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? "

				  (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."
  (vc-do-command nil 0 "co" (vc-name file) "-f"
                 (concat (if (eq (vc-state file) 'edited) "-u" "-r")
                         (vc-working-revision file))))

(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)

		 (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)))

(defun vc-rcs-modify-change-comment (files rev comment)
  "Modify the change comments change on FILES on a specified REV."
  (dolist (file files)
    (vc-do-command nil 0 "rcs" (vc-name file)
		   (concat "-m" rev ":" comment))))


;;;
;;; History functions
;;;

(defun vc-rcs-print-log (files &optional buffer)
  "Get change log associated with FILE."
  (vc-do-command buffer 0 "rlog" (mapcar 'vc-name files)))

(defun vc-rcs-diff (files &optional oldvers newvers buffer)
  "Get a difference report using RCS between two sets of files."
  (apply 'vc-do-command (or buffer "*vc-diff*")
	 1		;; Always go synchronous, the repo is local

94809:76b523d99056

;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; See vc.el

;;; Code:

;;;
;;; Customization options

(defun vc-rcs-checkin (files rev comment)
  "RCS-specific version of `vc-backend-checkin'."
  (let ((switches (vc-switches 'RCS 'checkin)))
    ;; Now operate on the files
    (dolist (file (vc-expand-dirs files))
      (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 (not rev)

	 "-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. If FILE is a directory, 
attempt the checkout for all registered files beneath it."
  (if (file-directory-p file)
      (mapc 'vc-rcs-checkout (vc-expand-dirs (list 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-rcs-checkout-model (list file)) 'implicit) "-f")
		     (if editable "-l")
		     (if (stringp rev)
			 ;; a literal revision was specified
			 (concat "-r" rev)
		       (let ((workrev (vc-working-revision 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*"

		  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-rollback (files)
  "Roll back, undoing the most recent checkins of FILES.  Directories are 
expanded to all regidtered subfuiles in them."
  (if (not files)
      (error "RCS backend doesn't support directory-level rollback."))
  (dolist (file (vc-expand-dirs files))
	  (let* ((discard (vc-working-revision file))
		 (previous (if (vc-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? "

				  (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."
  (if (file-directory-p file)
      (mapc 'vc-rcs-revert (vc-expand-dirs (list file)))
    (vc-do-command nil 0 "co" (vc-name file) "-f"
		   (concat (if (eq (vc-state file) 'edited) "-u" "-r")
			   (vc-working-revision file)))))

(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)

		 (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.
If FUILEis a directory, steal the lock on all registered files beneath it.
Needs RCS 5.6.2 or later for -M."
  (if (file-directory-p file)
      (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file)))
    (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))))

(defun vc-rcs-modify-change-comment (files rev comment)
  "Modify the change comments change on FILES on a specified REV.  If FILE is a
directory the operation is applied to all registered files beneath it."
  (dolist (file (vc-expand-dirs files))
    (vc-do-command nil 0 "rcs" (vc-name file)
		   (concat "-m" rev ":" comment))))


;;;
;;; History functions
;;;

(defun vc-rcs-print-log (files &optional buffer)
  "Get change log associated with FILE.  If FILE is a
directory the operation is applied to all registered files beneath it."
  (vc-do-command buffer 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files))))

(defun vc-rcs-diff (files &optional oldvers newvers buffer)
  "Get a difference report using RCS between two sets of files."
  (apply 'vc-do-command (or buffer "*vc-diff*")
	 1		;; Always go synchronous, the repo is local