X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b6e7b3c6cabb12da0d69bed715b49670df7b847d..85b5a0254674475e1fbd5b51c8ed8b5fa67f3c8e:/lisp/vc.el diff --git a/lisp/vc.el b/lisp/vc.el index 900eae7aee..eadd64fe91 100644 --- a/lisp/vc.el +++ b/lisp/vc.el @@ -1,10 +1,12 @@ ;;; vc.el --- drive a version-control system from within Emacs -;; Copyright (C) 1992, 93, 94, 95, 96, 97 Free Software Foundation, Inc. +;; Copyright (C) 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc. ;; Author: Eric S. Raymond ;; Maintainer: Andre Spiegel +;; $Id: vc.el,v 1.235 1998/07/09 03:24:06 rms Exp spiegel $ + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -30,7 +32,7 @@ ;; Paul Eggert , Sebastian Kremer , ;; and Richard Stallman contributed valuable criticism, support, and testing. ;; CVS support was added by Per Cederqvist -;; in Jan-Feb 1994. Further enhancements came from ttn.netcom.com and +;; in Jan-Feb 1994. Further enhancements came from ttn@netcom.com and ;; Andre Spiegel . ;; ;; Supported version-control systems presently include SCCS, RCS, and CVS. @@ -110,6 +112,13 @@ If FORM3 is `RCS', use FORM2 for CVS as well as RCS. :type 'boolean :group 'vc) +(defcustom vc-default-init-version "1.1" + "*A string used as the default version number when a new file is registered. +This can be overriden by giving a prefix argument to \\[vc-register]." + :type 'string + :group 'vc + :version "20.3") + (defcustom vc-command-messages nil "*If non-nil, display run messages from back-end commands." :type 'boolean @@ -145,6 +154,18 @@ These are passed to the checkin program by \\[vc-register]." string)) :group 'vc) +(defcustom vc-dired-recurse t + "*If non-nil, show directory trees recursively in VC Dired." + :type 'boolean + :group 'vc + :version "20.3") + +(defcustom vc-dired-terse-display t + "*If non-nil, show only locked files in VC Dired." + :type 'boolean + :group 'vc + :version "20.3") + (defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS") "*List of directory names to be ignored while recursively walking file trees." :type '(repeat string) @@ -200,9 +221,10 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'." ;;;###autoload (defcustom vc-checkin-hook nil - "*Normal hook (List of functions) run after a checkin is done. + "*Normal hook (list of functions) run after a checkin is done. See `run-hooks'." :type 'hook + :options '(vc-comment-to-change-log) :group 'vc) ;;;###autoload @@ -309,27 +331,6 @@ If nil, VC itself computes this value when it is first needed." (defvar vc-comment-ring-index nil) (defvar vc-last-comment-match nil) -;; Back-portability to Emacs 18 - -(defun file-executable-p-18 (f) - (let ((modes (file-modes f))) - (and modes (not (zerop (logand 292)))))) - -(defun file-regular-p-18 (f) - (let ((attributes (file-attributes f))) - (and attributes (not (car attributes))))) - -; Conditionally rebind some things for Emacs 18 compatibility -(if (not (boundp 'minor-mode-map-alist)) - (progn - (setq compilation-old-error-list nil) - (fset 'file-executable-p 'file-executable-p-18) - (fset 'shrink-window-if-larger-than-buffer 'beginning-of-buffer) - )) - -(if (not (fboundp 'file-regular-p)) - (fset 'file-regular-p 'file-regular-p-18)) - ;;; Find and compare backend releases (defun vc-backend-release (backend) @@ -400,10 +401,34 @@ If nil, VC itself computes this value when it is first needed." ;; return t if REV is a revision on the trunk (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev)))) +(defun vc-branch-p (rev) + ;; return t if REV is a branch revision + (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev)))) + (defun vc-branch-part (rev) ;; return the branch part of a revision number REV (substring rev 0 (string-match "\\.[0-9]+\\'" rev))) +(defun vc-minor-part (rev) + ;; return the minor version number of a revision number REV + (string-match "[0-9]+\\'" rev) + (substring rev (match-beginning 0) (match-end 0))) + +(defun vc-previous-version (rev) + ;; guess the previous version number + (let ((branch (vc-branch-part rev)) + (minor-num (string-to-number (vc-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-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-branch-part branch))))) + ;; File property caching (defun vc-clear-context () @@ -469,13 +494,22 @@ If nil, VC itself computes this value when it is first needed." ;; CVS t)) -(defun vc-registration-error (file) - (if file - (error "File %s is not under version control" file) - (error "Buffer %s is not associated with a file" (buffer-name)))) +(defun vc-ensure-vc-buffer () + ;; Make sure that the current buffer visits a version-controlled file. + (if vc-dired-mode + (set-buffer (find-file-noselect (dired-get-filename))) + (while vc-parent-buffer + (pop-to-buffer vc-parent-buffer)) + (if (not (buffer-file-name)) + (error "Buffer %s is not associated with a file" (buffer-name)) + (if (not (vc-backend (buffer-file-name))) + (error "File %s is not under version control" (buffer-file-name)))))) (defvar vc-binary-assoc nil) - +(defvar vc-binary-suffixes + (if (memq system-type '(ms-dos windows-nt)) + '(".exe" ".com" ".bat" ".cmd" ".btm" "") + '(""))) (defun vc-find-binary (name) "Look for a command anywhere on the subprocess-command search path." (or (cdr (assoc name vc-binary-assoc)) @@ -484,32 +518,41 @@ If nil, VC itself computes this value when it is first needed." (function (lambda (s) (if s - (let ((full (concat s "/" name))) - (if (file-executable-p full) - (progn - (setq vc-binary-assoc - (cons (cons name full) vc-binary-assoc)) - (throw 'found full))))))) + (let ((full (concat s "/" name)) + (suffixes vc-binary-suffixes) + candidate) + (while suffixes + (setq candidate (concat full (car suffixes))) + (if (and (file-executable-p candidate) + (not (file-directory-p candidate))) + (progn + (setq vc-binary-assoc + (cons (cons name candidate) vc-binary-assoc)) + (throw 'found candidate)) + (setq suffixes (cdr suffixes)))))))) exec-path) nil))) (defun vc-do-command (buffer okstatus command file last &rest flags) "Execute a version-control command, notifying user and checking for errors. -Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil. -The command is successful if its exit status does not exceed OKSTATUS. - (If OKSTATUS is nil, that means to ignore errors.) -The last argument of the command is the master name of FILE if LAST is -`MASTER', or the workfile of FILE if LAST is `WORKFILE'; this is appended -to an optional list of FLAGS." +Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil. The +command is considered successful if its exit status does not exceed +OKSTATUS (if OKSTATUS is nil, that means to ignore errors). FILE is +the name of the working file (may also be nil, to execute commands +that don't expect a file name). If FILE is non-nil, the argument LAST +indicates what filename should actually be passed to the command: if +it is `MASTER', the name of FILE's master file is used, if it is +`WORKFILE', then FILE is passed through unchanged. If an optional +list of FLAGS is present, that is inserted into the command line +before the filename." (and file (setq file (expand-file-name file))) (if (not buffer) (setq buffer "*vc*")) (if vc-command-messages (message "Running %s on %s..." command file)) (let ((obuf (current-buffer)) (camefrom (current-buffer)) (squeezed nil) - (vc-file (and file (vc-name file))) (olddir default-directory) - status) + vc-file status) (set-buffer (get-buffer-create buffer)) (set (make-local-variable 'vc-parent-buffer) camefrom) (set (make-local-variable 'vc-parent-buffer-name) @@ -521,9 +564,9 @@ to an optional list of FLAGS." (mapcar (function (lambda (s) (and s (setq squeezed (append squeezed (list s)))))) flags) - (if (and vc-file (eq last 'MASTER)) + (if (and (eq last 'MASTER) file (setq vc-file (vc-name file))) (setq squeezed (append squeezed (list vc-file)))) - (if (eq last 'WORKFILE) + (if (and file (eq last 'WORKFILE)) (progn (let* ((pwd (expand-file-name default-directory)) (preflen (length pwd))) @@ -589,6 +632,15 @@ to an optional list of FLAGS." ;; to beginning of OSTRING (- (point) (length context-string)))))))) +(defun vc-context-matches-p (posn context) + ;; Returns t if POSN matches CONTEXT, nil otherwise. + (let* ((context-string (nth 2 context)) + (len (length context-string)) + (end (+ posn len))) + (if (> end (1+ (buffer-size))) + nil + (string= context-string (buffer-substring posn end))))) + (defun vc-buffer-context () ;; Return a list '(point-context mark-context reparse); from which ;; vc-restore-buffer-context can later restore the context. @@ -649,12 +701,15 @@ to an optional list of FLAGS." (setq compilation-error-list (cdr compilation-error-list)))))) (setq reparse (cdr reparse))) - ;; Restore point and mark - (let ((new-point (vc-find-position-by-context point-context))) - (if new-point (goto-char new-point))) - (if mark-context - (let ((new-mark (vc-find-position-by-context mark-context))) - (if new-mark (set-mark new-mark)))))) + ;; if necessary, restore point and mark + (if (not (vc-context-matches-p (point) point-context)) + (let ((new-point (vc-find-position-by-context point-context))) + (if new-point (goto-char new-point)))) + (and mark-active + mark-context + (not (vc-context-matches-p (mark) mark-context)) + (let ((new-mark (vc-find-position-by-context mark-context))) + (if new-mark (set-mark new-mark)))))) (defun vc-revert-buffer1 (&optional arg no-confirm) ;; Revert buffer, try to keep point and mark where user expects them in spite @@ -663,8 +718,14 @@ to an optional list of FLAGS." (interactive "P") (widen) (let ((context (vc-buffer-context))) - ;; t means don't call normal-mode; that's to preserve various minor modes. - (revert-buffer arg no-confirm t) + ;; Use save-excursion here, because it may be able to restore point + ;; and mark properly even in cases where vc-restore-buffer-context + ;; would fail. However, save-excursion might also get it wrong -- + ;; in this case, vc-restore-buffer-context gives it a second try. + (save-excursion + ;; t means don't call normal-mode; + ;; that's to preserve various minor modes. + (revert-buffer arg no-confirm t)) (vc-restore-buffer-context context))) @@ -694,18 +755,13 @@ to an optional list of FLAGS." (defun vc-next-action-on-file (file verbose &optional comment) ;;; If comment is specified, it will be used as an admin or checkin comment. - (let ((vc-file (vc-name file)) - (vc-type (vc-backend file)) + (let ((vc-type (vc-backend file)) owner version buffer) (cond - ;; if there is no master file corresponding, create one - ((not vc-file) - (vc-register verbose comment) - (if vc-initial-comment - (setq vc-log-after-operation-hook - 'vc-checkout-writable-buffer-hook) - (vc-checkout-writable-buffer file))) + ;; If the file is not under version control, register it + ((not vc-type) + (vc-register verbose comment)) ;; CVS: changes to the master file need to be ;; merged back into the working file @@ -730,14 +786,13 @@ to an optional list of FLAGS." "Buffer %s modified; merge file on disc anyhow? " (buffer-name buffer))))) (error "Merge aborted")) - (if (not (zerop (vc-backend-merge-news file))) - ;; Overlaps detected - what now? Should use some - ;; fancy RCS conflict resolving package, or maybe - ;; emerge, but for now, simply warn the user with a - ;; message. - (message "Conflicts detected!")) - (and buffer - (vc-resynch-buffer file t (not (buffer-modified-p buffer))))) + (let ((status (vc-backend-merge-news file))) + (and buffer + (vc-resynch-buffer file t + (not (buffer-modified-p buffer)))) + (if (not (zerop status)) + (if (y-or-n-p "Conflicts detected. Resolve them now? ") + (vc-resolve-conflicts))))) (error "%s needs update" (buffer-name)))) ;; For CVS files with implicit checkout: if unmodified, don't do anything @@ -808,8 +863,16 @@ to an optional list of FLAGS." (find-file-other-window file) (find-file file)) - ;; give luser a chance to save before checking in. - (vc-buffer-sync) + ;; If the file on disk is newer, then the user just + ;; said no to rereading it. So the user probably wishes to + ;; overwrite the file with the buffer's contents, and check + ;; that in. + (if (not (verify-visited-file-modtime (current-buffer))) + (if (yes-or-no-p "Replace file on disk with buffer contents? ") + (write-file (buffer-file-name)) + (error "Aborted")) + ;; if buffer is not saved, give user a chance to do it + (vc-buffer-sync)) ;; Revert if file is unchanged and buffer is too. ;; If buffer is modified, that means the user just said no @@ -835,23 +898,24 @@ to an optional list of FLAGS." (defun vc-next-action-dired (file rev comment) ;; Do a vc-next-action-on-file on all the marked files, possibly ;; passing on the log comment we've just entered. - (let ((configuration (current-window-configuration)) - (dired-buffer (current-buffer)) + (let ((dired-buffer (current-buffer)) (dired-dir default-directory)) (dired-map-over-marks - (let ((file (dired-get-filename)) p - (default-directory default-directory)) + (let ((file (dired-get-filename))) (message "Processing %s..." file) ;; Adjust the default directory so that checkouts ;; go to the right place. - (setq default-directory (file-name-directory file)) - (vc-next-action-on-file file nil comment) - (set-buffer dired-buffer) - (setq default-directory dired-dir) - (vc-dired-update-line file) - (set-window-configuration configuration) + (let ((default-directory (file-name-directory file))) + (vc-next-action-on-file file nil comment) + (set-buffer dired-buffer)) + ;; Make sure that files don't vanish + ;; after they are checked in. + (let ((vc-dired-terse-mode nil)) + (dired-do-redisplay file)) + (set-window-configuration vc-dired-window-configuration) (message "Processing %s...done" file)) - nil t))) + nil t)) + (dired-move-to-filename)) ;; Here's the major entry point. @@ -869,7 +933,7 @@ lock steals will raise an error. For RCS and SCCS files: If the file is not already registered, this registers it for version -control and then retrieves a writable, locked copy for editing. +control. If the file is registered and not locked by anyone, this checks out a writable and locked file ready for editing. If the file is checked out and locked by the calling user, this @@ -898,6 +962,8 @@ merge in the changes into your working copy." (catch 'nogo (if vc-dired-mode (let ((files (dired-get-marked-files))) + (set (make-local-variable 'vc-dired-window-configuration) + (current-window-configuration)) (if (string= "" (mapconcat (function (lambda (f) @@ -915,8 +981,8 @@ merge in the changes into your working copy." (while vc-parent-buffer (pop-to-buffer vc-parent-buffer)) (if buffer-file-name - (vc-next-action-on-file buffer-file-name verbose) - (vc-registration-error nil)))) + (vc-next-action-on-file buffer-file-name verbose) + (error "Buffer %s is not associated with a file" (buffer-name))))) ;;; These functions help the vc-next-action entry point @@ -950,9 +1016,13 @@ merge in the changes into your working copy." (setq backup-inhibited t))) (vc-admin buffer-file-name - (and override - (read-string - (format "Initial version level for %s: " buffer-file-name)))) + (or (and override + (read-string + (format "Initial version level for %s: " buffer-file-name))) + vc-default-init-version) + comment) + ;; Recompute backend property (it may have been set to nil before). + (setq vc-buffer-backend (vc-backend (buffer-file-name))) ) (defun vc-resynch-window (file &optional keep noquery) @@ -965,21 +1035,27 @@ merge in the changes into your working copy." (and (string= buffer-file-name file) (if keep (progn - ;; temporarily remove vc-find-file-hook, so that - ;; we don't lose the properties - (remove-hook 'find-file-hooks 'vc-find-file-hook) (vc-revert-buffer1 t noquery) - (add-hook 'find-file-hooks 'vc-find-file-hook) + (and view-read-only + (if (file-writable-p file) + (and view-mode + (let ((view-old-buffer-read-only nil)) + (view-mode-exit))) + (and (not view-mode) + (not (eq (get major-mode 'mode-class) 'special)) + (view-mode-enter)))) (vc-mode-line buffer-file-name)) (kill-buffer (current-buffer))))) (defun vc-resynch-buffer (file &optional keep noquery) ;; if FILE is currently visited, resynch its buffer - (let ((buffer (get-file-buffer file))) - (if buffer - (save-excursion - (set-buffer buffer) - (vc-resynch-window file keep noquery))))) + (if (string= buffer-file-name file) + (vc-resynch-window file keep noquery) + (let ((buffer (get-file-buffer file))) + (if buffer + (save-excursion + (set-buffer buffer) + (vc-resynch-window file keep noquery)))))) (defun vc-start-entry (file rev comment msg action &optional after-hook) ;; Accept a comment for an operation on FILE revision REV. If COMMENT @@ -1073,19 +1149,21 @@ The optional argument REV may be a string specifying the new version level \(if nil increment the current level). The file is either retained with write permissions zeroed, or deleted (according to the value of `vc-keep-workfiles'). If the back-end is CVS, a writable workfile is always kept. -COMMENT is a comment string; if omitted, a buffer is -popped up to accept a comment." +COMMENT is a comment string; if omitted, a buffer is popped up to accept a +comment. + +Runs the normal hook `vc-checkin-hook'." (vc-start-entry file rev comment "Enter a change comment." 'vc-backend-checkin 'vc-checkin-hook)) -;;; Here is a checkin hook that may prove useful to sites using the -;;; ChangeLog facility supported by Emacs. (defun vc-comment-to-change-log (&optional whoami file-name) "Enter last VC comment into change log file for current buffer's file. Optional arg (interactive prefix) non-nil means prompt for user name and site. Second arg is file name of change log. \ -If nil, uses `change-log-default-name'." +If nil, uses `change-log-default-name'. + +May be useful as a `vc-checkin-hook' to update change logs automatically." (interactive (if current-prefix-arg (list current-prefix-arg (prompt-for-change-log-name)))) @@ -1133,9 +1211,6 @@ If nil, uses `change-log-default-name'." ;; Check and record the comment, if any. (if (not nocomment) (progn - (goto-char (point-max)) - (if (not (bolp)) - (newline)) ;; Comment too long? (vc-backend-logentry-check vc-log-file) ;; Record the comment in the comment ring @@ -1154,20 +1229,25 @@ If nil, uses `change-log-default-name'." (log-version vc-log-version) (log-entry (buffer-string)) (after-hook vc-log-after-operation-hook)) - ;; Return to "parent" buffer of this checkin and remove checkin window (pop-to-buffer vc-parent-buffer) - (let ((logbuf (get-buffer "*VC-log*"))) - (delete-windows-on logbuf) - (kill-buffer logbuf)) ;; OK, do it to it (save-excursion (funcall log-operation log-file log-version log-entry)) + ;; Remove checkin window (after the checkin so that if that fails + ;; we don't zap the *VC-log* buffer and the typing therein). + (let ((logbuf (get-buffer "*VC-log*"))) + (cond (logbuf + (delete-windows-on logbuf (selected-frame)) + ;; Kill buffer and delete any other dedicated windows/frames. + (kill-buffer logbuf)))) ;; Now make sure we see the expanded headers (if buffer-file-name (vc-resynch-window buffer-file-name vc-keep-workfiles t)) + (if vc-dired-mode + (dired-move-to-filename)) (run-hooks after-hook 'vc-finish-logentry-hook))) ;; Code for access to the comment ring @@ -1242,51 +1322,68 @@ checked in version of that file. This uses no arguments. With a prefix argument, it reads the file name to use and two version designators specifying which versions to compare." (interactive (list current-prefix-arg t)) - (if vc-dired-mode - (set-buffer (find-file-noselect (dired-get-filename)))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) + (vc-ensure-vc-buffer) (if historic (call-interactively 'vc-version-diff) - (if (or (null buffer-file-name) (null (vc-name buffer-file-name))) - (error - "There is no version-control master associated with this buffer")) (let ((file buffer-file-name) unchanged) - (if nil ;;; (not (vc-locking-user file)) - ;; This seems like feeping creaturism -- rms. - ;; if the file is not locked, ask for older version to compare with - (let ((old (read-string - "File is unchanged; version to compare with: "))) - (vc-version-diff file old "")) - (vc-buffer-sync not-urgent) - (setq unchanged (vc-workfile-unchanged-p buffer-file-name)) - (if unchanged - (message "No changes to %s since latest version" file) - (vc-backend-diff file) - ;; Ideally, we'd like at this point to parse the diff so that - ;; the buffer effectively goes into compilation mode and we - ;; can visit the old and new change locations via next-error. - ;; Unfortunately, this is just too painful to do. The basic - ;; problem is that the `old' file doesn't exist to be - ;; visited. This plays hell with numerous assumptions in - ;; the diff.el and compile.el machinery. - (set-buffer "*vc-diff*") - (setq default-directory (file-name-directory file)) - (if (= 0 (buffer-size)) - (progn - (setq unchanged t) - (message "No changes to %s since latest version" file)) - (pop-to-buffer "*vc-diff*") - (goto-char (point-min)) - (shrink-window-if-larger-than-buffer))) - (not unchanged))))) + (vc-buffer-sync not-urgent) + (setq unchanged (vc-workfile-unchanged-p buffer-file-name)) + (if unchanged + (message "No changes to %s since latest version" file) + (vc-backend-diff file) + ;; Ideally, we'd like at this point to parse the diff so that + ;; the buffer effectively goes into compilation mode and we + ;; can visit the old and new change locations via next-error. + ;; Unfortunately, this is just too painful to do. The basic + ;; problem is that the `old' file doesn't exist to be + ;; visited. This plays hell with numerous assumptions in + ;; the diff.el and compile.el machinery. + (set-buffer "*vc-diff*") + (setq default-directory (file-name-directory file)) + (if (= 0 (buffer-size)) + (progn + (setq unchanged t) + (message "No changes to %s since latest version" file)) + (pop-to-buffer "*vc-diff*") + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer))) + (not unchanged)))) (defun vc-version-diff (file rel1 rel2) "For FILE, report diffs between two stored versions REL1 and REL2 of it. If FILE is a directory, generate diffs between versions for all registered files in or below it." - (interactive "FFile or directory to diff: \nsOlder version: \nsNewer version: ") + (interactive + (let ((file (read-file-name (if buffer-file-name + "File or dir to diff: (default visited file) " + "File or dir to diff: ") + default-directory buffer-file-name t)) + (rel1-default nil) (rel2-default nil)) + ;; compute default versions based on the file state + (cond + ;; if it's a directory, don't supply any version defauolt + ((file-directory-p file) + nil) + ;; if the file is locked, use current version as older version + ((vc-locking-user file) + (setq rel1-default (vc-workfile-version file))) + ;; if the file is not locked, use last and previous version as default + (t + (setq rel1-default (vc-previous-version (vc-workfile-version file))) + (setq rel2-default (vc-workfile-version file)))) + ;; construct argument list + (list file + (read-string (if rel1-default + (concat "Older version: (default " + rel1-default ") ") + "Older version: ") + nil nil rel1-default) + (read-string (if rel2-default + (concat "Newer version: (default " + rel2-default ") ") + "Newer version (default: current source): ") + nil nil rel2-default)))) (if (string-equal rel1 "") (setq rel1 nil)) (if (string-equal rel2 "") (setq rel2 nil)) (if (file-directory-p file) @@ -1328,19 +1425,14 @@ files in or below it." If the current buffer is named `F', the version is named `F.~REV~'. If `F.~REV~' already exists, it is used instead of being re-created." (interactive "sVersion to visit (default is latest version): ") - (if vc-dired-mode - (set-buffer (find-file-noselect (dired-get-filename)))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) - (if (and buffer-file-name (vc-name buffer-file-name)) - (let* ((version (if (string-equal rev "") - (vc-latest-version buffer-file-name) - rev)) - (filename (concat buffer-file-name ".~" version "~"))) - (or (file-exists-p filename) - (vc-backend-checkout buffer-file-name nil version filename)) - (find-file-other-window filename)) - (vc-registration-error buffer-file-name))) + (vc-ensure-vc-buffer) + (let* ((version (if (string-equal rev "") + (vc-latest-version buffer-file-name) + rev)) + (filename (concat buffer-file-name ".~" version "~"))) + (or (file-exists-p filename) + (vc-backend-checkout buffer-file-name nil version filename)) + (find-file-other-window filename))) ;; Header-insertion code @@ -1350,10 +1442,7 @@ If `F.~REV~' already exists, it is used instead of being re-created." Headers desired are inserted at the start of the buffer, and are pulled from the variable `vc-header-alist'." (interactive) - (if vc-dired-mode - (find-file-other-window (dired-get-filename))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) + (vc-ensure-vc-buffer) (save-excursion (save-restriction (widen) @@ -1382,199 +1471,376 @@ the variable `vc-header-alist'." ;; Don't lose point and mark during this. (let ((context (vc-buffer-context)) (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$")) + ;; save-excursion may be able to relocate point and mark properly. + ;; If it fails, vc-restore-buffer-context will give it a second try. + (save-excursion + (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$"))) (vc-restore-buffer-context context))) +;;;###autoload +(defun vc-merge () + (interactive) + (vc-ensure-vc-buffer) + (vc-buffer-sync) + (let* ((file buffer-file-name) + (backend (vc-backend file)) + first-version second-version locking-user) + (if (eq backend 'SCCS) + (error "Sorry, merging is not implemented for SCCS") + (setq locking-user (vc-locking-user file)) + (if (eq (vc-checkout-model file) 'manual) + (if (not locking-user) + (if (not (y-or-n-p + (format "File must be %s for merging. %s now? " + (if (eq backend 'RCS) "locked" "writable") + (if (eq backend 'RCS) "Lock" "Check out")))) + (error "Merge aborted") + (vc-checkout file t)) + (if (not (string= locking-user (vc-user-login-name))) + (error "File is locked by %s" locking-user)))) + (setq first-version (read-string "Branch or version to merge from: ")) + (if (and (>= (elt first-version 0) ?0) + (<= (elt first-version 0) ?9)) + (if (not (vc-branch-p first-version)) + (setq second-version + (read-string "Second version: " + (concat (vc-branch-part first-version) "."))) + ;; We want to merge an entire branch. Set versions + ;; accordingly, so that vc-backend-merge understands us. + (setq second-version first-version) + ;; first-version must be the starting point of the branch + (setq first-version (vc-branch-part first-version)))) + (let ((status (vc-backend-merge file first-version second-version))) + (if (and (eq (vc-checkout-model file) 'implicit) + (not (vc-locking-user file))) + (vc-file-setprop file 'vc-locking-user nil)) + (vc-resynch-buffer file t t) + (if (not (zerop status)) + (if (y-or-n-p "Conflicts detected. Resolve them now? ") + (vc-resolve-conflicts "WORKFILE" "MERGE SOURCE") + (message "File contains conflict markers")) + (message "Merge successful")))))) + +;;;###autoload +(defun vc-resolve-conflicts (&optional name-A name-B) + "Invoke ediff to resolve conflicts in the current buffer. +The conflicts must be marked with rcsmerge conflict markers." + (interactive) + (vc-ensure-vc-buffer) + (let* ((found nil) + (file-name (file-name-nondirectory buffer-file-name)) + (your-buffer (generate-new-buffer + (concat "*" file-name + " " (or name-A "WORKFILE") "*"))) + (other-buffer (generate-new-buffer + (concat "*" file-name + " " (or name-B "CHECKED-IN") "*"))) + (result-buffer (current-buffer))) + (save-excursion + (set-buffer your-buffer) + (erase-buffer) + (insert-buffer result-buffer) + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote file-name) "\n") nil t) + (setq found t) + (replace-match "") + (if (not (re-search-forward "^=======\n" nil t)) + (error "Malformed conflict marker")) + (replace-match "") + (let ((start (point))) + (if (not (re-search-forward "^>>>>>>> [0-9.]+\n" nil t)) + (error "Malformed conflict marker")) + (delete-region start (point)))) + (if (not found) + (progn + (kill-buffer your-buffer) + (kill-buffer other-buffer) + (error "No conflict markers found"))) + (set-buffer other-buffer) + (erase-buffer) + (insert-buffer result-buffer) + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote file-name) "\n") nil t) + (let ((start (match-beginning 0))) + (if (not (re-search-forward "^=======\n" nil t)) + (error "Malformed conflict marker")) + (delete-region start (point)) + (if (not (re-search-forward "^>>>>>>> [0-9.]+\n" nil t)) + (error "Malformed conflict marker")) + (replace-match ""))) + (let ((config (current-window-configuration)) + (ediff-default-variant 'default-B)) + + ;; Fire up ediff. + + (set-buffer (ediff-merge-buffers your-buffer other-buffer)) + + ;; Ediff is now set up, and we are in the control buffer. + ;; Do a few further adjustments and take precautions for exit. + + (make-local-variable 'vc-ediff-windows) + (setq vc-ediff-windows config) + (make-local-variable 'vc-ediff-result) + (setq vc-ediff-result result-buffer) + (make-local-variable 'ediff-quit-hook) + (setq ediff-quit-hook + (function + (lambda () + (let ((buffer-A ediff-buffer-A) + (buffer-B ediff-buffer-B) + (buffer-C ediff-buffer-C) + (result vc-ediff-result) + (windows vc-ediff-windows)) + (ediff-cleanup-mess) + (set-buffer result) + (erase-buffer) + (insert-buffer buffer-C) + (kill-buffer buffer-A) + (kill-buffer buffer-B) + (kill-buffer buffer-C) + (set-window-configuration windows) + (message "Conflict resolution finished; you may save the buffer"))))) + (message "Please resolve conflicts now; exit ediff when done") + nil)))) + ;; The VC directory major mode. Coopt Dired for this. ;; All VC commands get mapped into logical equivalents. (define-derived-mode vc-dired-mode dired-mode "Dired under VC" - "The major mode used in VC directory buffers. It is derived from Dired. -All Dired commands operate normally. Users currently locking listed files -are listed in place of the file's owner and group. -Keystrokes bound to VC commands will execute as though they had been called -on a buffer attached to the file named in the current Dired buffer line." + "The major mode used in VC directory buffers. It works like Dired, +but lists only files under version control, with the current VC state of +each file being indicated in the place of the file's link count, owner, +group and size. Subdirectories are also listed, and you may insert them +into the buffer as desired, like in Dired. + All Dired commands operate normally, with the exception of `v', which +is redefined as the version control prefix, so that you can type +`vl', `v=' etc. to invoke `vc-print-log', `vc-diff', and the like on +the file named in the current Dired buffer line. `vv' invokes +`vc-next-action' on this file, or on all files currently marked. +There is a special command, `*l', to mark all files currently locked." + (make-local-hook 'dired-after-readin-hook) + (add-hook 'dired-after-readin-hook 'vc-dired-hook nil t) + ;; The following is slightly modified from dired.el, + ;; because file lines look a bit different in vc-dired-mode. + (set (make-local-variable 'dired-move-to-filename-regexp) + (let* + ((l "\\([A-Za-z]\\|[^\0-\177]\\)") + ;; In some locales, month abbreviations are as short as 2 letters, + ;; and they can be padded on the right with spaces. + (month (concat l l "+ *")) + ;; Recognize any non-ASCII character. + ;; The purpose is to match a Kanji character. + (k "[^\0-\177]") + ;; (k "[^\x00-\x7f\x80-\xff]") + (s " ") + (yyyy "[0-9][0-9][0-9][0-9]") + (mm "[ 0-1][0-9]") + (dd "[ 0-3][0-9]") + (HH:MM "[ 0-2][0-9]:[0-5][0-9]") + (western (concat "\\(" month s dd "\\|" dd s month "\\)" + s "\\(" HH:MM "\\|" s yyyy "\\)")) + (japanese (concat mm k s dd k s "\\(" s HH:MM "\\|" yyyy k "\\)"))) + (concat s "\\(" western "\\|" japanese "\\)" s))) + (and (boundp 'vc-dired-switches) + vc-dired-switches + (set (make-local-variable 'dired-actual-switches) + vc-dired-switches)) + (set (make-local-variable 'vc-dired-terse-mode) vc-dired-terse-display) (setq vc-dired-mode t)) (define-key vc-dired-mode-map "\C-xv" vc-prefix-map) -(define-key vc-dired-mode-map "g" 'vc-dired-update) -(define-key vc-dired-mode-map "=" 'vc-diff) +(define-key vc-dired-mode-map "v" vc-prefix-map) + +(defun vc-dired-toggle-terse-mode () + "Toggle terse display in VC Dired." + (interactive) + (if (not vc-dired-mode) + nil + (setq vc-dired-terse-mode (not vc-dired-terse-mode)) + (if vc-dired-terse-mode + (vc-dired-hook) + (revert-buffer)))) + +(define-key vc-dired-mode-map "vt" 'vc-dired-toggle-terse-mode) + +(defun vc-dired-mark-locked () + "Mark all files currently locked." + (interactive) + (dired-mark-if (let ((f (dired-get-filename nil t))) + (and f + (not (file-directory-p f)) + (vc-locking-user f))) + "locked file")) + +(define-key vc-dired-mode-map "*l" 'vc-dired-mark-locked) + +(defun vc-fetch-cvs-status (dir) + (let ((default-directory dir)) + ;; Don't specify DIR in this command, the default-directory is + ;; enough. Otherwise it might fail with remote repositories. + (vc-do-command "*vc-info*" 0 "cvs" nil nil "status") + (save-excursion + (set-buffer (get-buffer "*vc-info*")) + (goto-char (point-min)) + (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t) + (narrow-to-region (match-beginning 0) (match-end 0)) + (vc-parse-cvs-status) + (goto-char (point-max)) + (widen))))) (defun vc-dired-state-info (file) ;; Return the string that indicates the version control status ;; on a VC dired line. - (let ((cvs-state (and (eq (vc-backend file) 'CVS) - (vc-cvs-status file)))) - (if cvs-state - (cond ((eq cvs-state 'up-to-date) nil) - ((eq cvs-state 'needs-checkout) "patch") - ((eq cvs-state 'locally-modified) "modified") - ((eq cvs-state 'needs-merge) "merge") - ((eq cvs-state 'unresolved-conflict) "conflict") - ((eq cvs-state 'locally-added) "added")) - (vc-locking-user file)))) + (let* ((cvs-state (and (eq (vc-backend file) 'CVS) + (vc-cvs-status file))) + (state + (if cvs-state + (cond ((eq cvs-state 'up-to-date) nil) + ((eq cvs-state 'needs-checkout) "patch") + ((eq cvs-state 'locally-modified) "modified") + ((eq cvs-state 'needs-merge) "merge") + ((eq cvs-state 'unresolved-conflict) "conflict") + ((eq cvs-state 'locally-added) "added")) + (vc-locking-user file)))) + (if state (concat "(" state ")")))) (defun vc-dired-reformat-line (x) - ;; Hack a directory-listing line, plugging in locking-user info in - ;; place of the user and group info. Should have the beneficial - ;; side-effect of shortening the listing line. Each call starts with - ;; point immediately following the dired mark area on the line to be - ;; hacked. - ;; - ;; Simplest possible one: - ;; (insert (concat x "\t"))) - ;; + ;; Reformat a directory-listing line, replacing various columns with + ;; version control information. ;; This code, like dired, assumes UNIX -l format. - (let ((pos (point)) limit perm owner date-and-file) + (beginning-of-line) + (let ((pos (point)) limit perm date-and-file) (end-of-line) (setq limit (point)) (goto-char pos) - (cond - ((or - (re-search-forward ;; owner and group -"\\([drwxlts-]+ \\) *[0-9]+ \\([^ ]+\\) +[^ ]+ +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)" - limit t) - (re-search-forward ;; only owner displayed -"\\([drwxlts-]+ \\) *[0-9]+ \\([^ ]+\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)" - limit t)) - (setq perm (match-string 1) - owner (match-string 2) - date-and-file (match-string 3))) - ((re-search-forward ;; OS/2 -l format, no links, owner, group -"\\([drwxlts-]+ \\) *[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)" - limit t) + (when + (or + (re-search-forward ;; owner and group + "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[^ ]+ +[0-9]+\\( .*\\)" + limit t) + (re-search-forward ;; only owner displayed + "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[0-9]+\\( .*\\)" + limit t) + (re-search-forward ;; OS/2 -l format, no links, owner, group + "^\\(..[drwxlts-]+ \\) *[0-9]+\\( .*\\)" + limit t)) (setq perm (match-string 1) - date-and-file (match-string 2)))) - (if x (setq x (concat "(" x ")"))) - (let ((rep (substring (concat x " ") 0 10))) - (replace-match (concat perm rep date-and-file))))) - -(defun vc-dired-update-line (file) - ;; Update the vc-dired listing line of file -- it is assumed - ;; that point is already on this line. Don't use dired-do-redisplay - ;; for this, because it cannot handle the way vc-dired deals with - ;; subdirectories. - (beginning-of-line) - (forward-char 2) - (let ((start (point))) - (forward-line 1) - (beginning-of-line) - (delete-region start (point)) - (insert-directory file dired-listing-switches) - (forward-line -1) - (end-of-line) - (delete-char (- (length file))) - (insert (substring file (length (expand-file-name default-directory)))) - (goto-char start)) - (vc-dired-reformat-line (vc-dired-state-info file))) - -(defun vc-dired-update (verbose) - (interactive "P") - (vc-directory default-directory verbose)) + date-and-file (match-string 2)) + (setq x (substring (concat x " ") 0 10)) + (replace-match (concat perm x date-and-file))))) + +(defun vc-dired-hook () + ;; Called by dired after any portion of a vc-dired buffer has been read in. + ;; Reformat the listing according to version control. + (message "Getting version information... ") + (let (subdir filename (buffer-read-only nil) cvs-dir) + (goto-char (point-min)) + (while (not (eq (point) (point-max))) + (cond + ;; subdir header line + ((setq subdir (dired-get-subdir)) + (if (file-directory-p (concat subdir "/CVS")) + (progn + (vc-fetch-cvs-status (file-name-as-directory subdir)) + (setq cvs-dir t)) + (setq cvs-dir nil)) + (forward-line 1) + ;; erase (but don't remove) the "total" line + (let ((start (point))) + (end-of-line) + (delete-region start (point)) + (beginning-of-line) + (forward-line 1))) + ;; directory entry + ((setq filename (dired-get-filename nil t)) + (cond + ;; subdir + ((file-directory-p filename) + (cond + ((member (file-name-nondirectory filename) + vc-directory-exclusion-list) + (let ((pos (point))) + (dired-kill-tree filename) + (goto-char pos) + (dired-kill-line))) + (vc-dired-terse-mode + ;; Don't show directories in terse mode. Don't use + ;; dired-kill-line to remove it, because in recursive listings, + ;; that would remove the directory contents as well. + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + ((string-match "\\`\\.\\.?\\'" (file-name-nondirectory filename)) + (dired-kill-line)) + (t + (vc-dired-reformat-line nil) + (forward-line 1)))) + ;; ordinary file + ((if cvs-dir + (and (eq (vc-file-getprop filename 'vc-backend) 'CVS) + (or (not vc-dired-terse-mode) + (not (eq (vc-cvs-status filename) 'up-to-date)))) + (and (vc-backend filename) + (or (not vc-dired-terse-mode) + (vc-locking-user filename)))) + (vc-dired-reformat-line (vc-dired-state-info filename)) + (forward-line 1)) + (t + (dired-kill-line)))) + ;; any other line + (t (forward-line 1)))) + (vc-dired-purge)) + (message "Getting version information... done") + (save-restriction + (widen) + (cond ((eq (count-lines (point-min) (point-max)) 1) + (goto-char (point-min)) + (message "No files locked under %s" default-directory))))) + +(defun vc-dired-purge () + ;; Remove empty subdirs + (let (subdir) + (goto-char (point-min)) + (while (setq subdir (dired-get-subdir)) + (forward-line 2) + (if (dired-get-filename nil t) + (if (not (dired-next-subdir 1 t)) + (goto-char (point-max))) + (forward-line -2) + (if (not (string= (dired-current-directory) default-directory)) + (dired-do-kill-lines t "") + ;; We cannot remove the top level directory. + ;; Just make it look a little nicer. + (forward-line 1) + (kill-line) + (if (not (dired-next-subdir 1 t)) + (goto-char (point-max)))))) + (goto-char (point-min)))) -;;; Note in Emacs 18 the following defun gets overridden -;;; with the symbol 'vc-directory-18. See below. ;;;###autoload -(defun vc-directory (dirname verbose) - "Show version-control status of the current directory and subdirectories. -Normally it creates a Dired buffer that lists only the locked files -in all these directories. With a prefix argument, it lists all files." +(defun vc-directory (dirname read-switches) (interactive "DDired under VC (directory): \nP") - (require 'dired) - (setq dirname (expand-file-name dirname)) - ;; force a trailing slash - (if (not (eq (elt dirname (1- (length dirname))) ?/)) - (setq dirname (concat dirname "/"))) - (let (nonempty - (dl (length dirname)) - (filelist nil) (statelist nil) - (old-dir default-directory) - dired-buf - dired-buf-mod-count) - (vc-file-tree-walk - dirname - (function - (lambda (f) - (if (vc-registered f) - (let ((state (vc-dired-state-info f))) - (and (or verbose state) - (setq filelist (cons (substring f dl) filelist)) - (setq statelist (cons state statelist)))))))) - (save-window-excursion - (save-excursion - ;; This uses a semi-documented feature of dired; giving a switch - ;; argument forces the buffer to refresh each time. - (setq dired-buf - (dired-internal-noselect - (cons dirname (nreverse filelist)) - dired-listing-switches 'vc-dired-mode)) - (setq nonempty (not (eq 0 (length filelist)))))) - (switch-to-buffer dired-buf) - ;; Make a few modifications to the header - (setq buffer-read-only nil) - (goto-char (point-min)) - (forward-line 1) ;; Skip header line - (let ((start (point))) ;; Erase (but don't remove) the - (end-of-line) ;; "wildcard" line. - (delete-region start (point))) - (beginning-of-line) - (if nonempty - (progn - ;; Plug the version information into the individual lines - (mapcar - (function - (lambda (x) - (forward-char 2) ;; skip dired's mark area - (vc-dired-reformat-line x) - (forward-line 1))) ;; go to next line - (nreverse statelist)) - (setq buffer-read-only t) - (goto-char (point-min)) - (dired-next-line 2) - ) - (dired-next-line 1) - (insert " ") - (setq buffer-read-only t) - (message "No files are currently %s under %s" - (if verbose "registered" "locked") dirname)) - )) - -;; Emacs 18 version -(defun vc-directory-18 (verbose) - "Show version-control status of all files under the current directory." - (interactive "P") - (let (nonempty (dir default-directory)) - (save-excursion - (set-buffer (get-buffer-create "*vc-status*")) - (erase-buffer) - (cd dir) - (vc-file-tree-walk - default-directory - (function (lambda (f) - (if (vc-registered f) - (let ((user (vc-locking-user f))) - (if (or user verbose) - (insert (format - "%s %s\n" - (concat user) f)))))))) - (setq nonempty (not (zerop (buffer-size))))) - - (if nonempty - (progn - (pop-to-buffer "*vc-status*" t) - (goto-char (point-min)) - (shrink-window-if-larger-than-buffer))) - (message "No files are currently %s under %s" - (if verbose "registered" "locked") default-directory)) - ) - -(or (boundp 'minor-mode-map-alist) - (fset 'vc-directory 'vc-directory-18)) + (let ((vc-dired-switches (concat dired-listing-switches + (if vc-dired-recurse "R" "")))) + (if read-switches + (setq vc-dired-switches + (read-string "Dired listing switches: " + vc-dired-switches))) + (require 'dired) + (require 'dired-aux) + ;; force a trailing slash + (if (not (eq (elt dirname (1- (length dirname))) ?/)) + (setq dirname (concat dirname "/"))) + (switch-to-buffer + (dired-internal-noselect (expand-file-name dirname) + (or vc-dired-switches dired-listing-switches) + 'vc-dired-mode)))) ;; Named-configuration support for SCCS @@ -1582,9 +1848,7 @@ in all these directories. With a prefix argument, it lists all files." (save-excursion (find-file (expand-file-name vc-name-assoc-file - (file-name-as-directory - (expand-file-name (vc-backend-subdirectory-name file) - (file-name-directory file))))) + (file-name-directory (vc-name file)))) (goto-char (point-max)) (insert name "\t:\t" file "\t" rev "\n") (basic-save-buffer) @@ -1596,9 +1860,7 @@ in all these directories. With a prefix argument, it lists all files." (find-file (expand-file-name vc-name-assoc-file - (file-name-as-directory - (expand-file-name (vc-backend-subdirectory-name file) - (file-name-directory file))))) + (file-name-directory (vc-name file)))) (goto-char (point-min)) ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname)) (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t) @@ -1620,9 +1882,7 @@ in all these directories. With a prefix argument, it lists all files." (vc-insert-file (expand-file-name vc-name-assoc-file - (file-name-as-directory - (expand-file-name (vc-backend-subdirectory-name file) - (file-name-directory file))))) + (file-name-directory (vc-name file)))) (prog1 (car (vc-parse-buffer (list (list (concat name "\t:\t" file "\t\\(.+\\)") 1)))) @@ -1703,105 +1963,83 @@ locked are updated to the latest versions." (defun vc-print-log () "List the change log of the current buffer in a window." (interactive) - (if vc-dired-mode - (set-buffer (find-file-noselect (dired-get-filename)))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) - (if (and buffer-file-name (vc-name buffer-file-name)) - (let ((file buffer-file-name)) - (vc-backend-print-log file) - (pop-to-buffer (get-buffer-create "*vc*")) - (setq default-directory (file-name-directory file)) - (goto-char (point-max)) (forward-line -1) - (while (looking-at "=*\n") - (delete-char (- (match-end 0) (match-beginning 0))) - (forward-line -1)) - (goto-char (point-min)) - (if (looking-at "[\b\t\n\v\f\r ]+") - (delete-char (- (match-end 0) (match-beginning 0)))) - (shrink-window-if-larger-than-buffer) - ;; move point to the log entry for the current version - (and (not (eq (vc-backend file) 'SCCS)) - (re-search-forward - ;; also match some context, for safety - (concat "----\nrevision " (vc-workfile-version file) - "\\(\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))))) - ) - (vc-registration-error buffer-file-name) - ) - ) + (vc-ensure-vc-buffer) + (let ((file buffer-file-name)) + (vc-backend-print-log file) + (pop-to-buffer (get-buffer-create "*vc*")) + (setq default-directory (file-name-directory file)) + (goto-char (point-max)) (forward-line -1) + (while (looking-at "=*\n") + (delete-char (- (match-end 0) (match-beginning 0))) + (forward-line -1)) + (goto-char (point-min)) + (if (looking-at "[\b\t\n\v\f\r ]+") + (delete-char (- (match-end 0) (match-beginning 0)))) + (shrink-window-if-larger-than-buffer) + ;; move point to the log entry for the current version + (and (not (eq (vc-backend file) 'SCCS)) + (re-search-forward + ;; also match some context, for safety + (concat "----\nrevision " (vc-workfile-version file) + "\\(\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))))))) ;;;###autoload (defun vc-revert-buffer () - "Revert the current buffer's file back to the latest checked-in version. + "Revert the current buffer's file back to the version it was based on. This asks for confirmation if the buffer contents are not identical -to that version. -If the back-end is CVS, this will give you the most recent revision of -the file on the branch you are editing." +to that version. Note that for RCS and CVS, this function does not +automatically pick up newer changes found in the master file; +use C-u \\[vc-next-action] RET to do so." (interactive) - (if vc-dired-mode - (find-file-other-window (dired-get-filename))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) + (vc-ensure-vc-buffer) (let ((file buffer-file-name) ;; This operation should always ask for confirmation. (vc-suppress-confirm nil) (obuf (current-buffer)) (changed (vc-diff nil t))) - (if (and changed (not (yes-or-no-p "Discard changes? "))) - (progn + (if changed + (unwind-protect + (if (not (yes-or-no-p "Discard changes? ")) + (error "Revert cancelled")) (if (and (window-dedicated-p (selected-window)) (one-window-p t 'selected-frame)) (make-frame-invisible (selected-frame)) - (delete-window)) - (error "Revert cancelled")) - (set-buffer obuf)) - (if changed - (if (and (window-dedicated-p (selected-window)) - (one-window-p t 'selected-frame)) - (make-frame-invisible (selected-frame)) - (delete-window))) + (delete-window)))) + (set-buffer obuf) (vc-backend-revert file) - (vc-resynch-window file t t) - ) - ) + (vc-resynch-window file t t))) ;;;###autoload (defun vc-cancel-version (norevert) "Get rid of most recently checked in version of this file. A prefix argument means do not revert the buffer afterwards." (interactive "P") - (if vc-dired-mode - (find-file-other-window (dired-get-filename))) - (while vc-parent-buffer - (pop-to-buffer vc-parent-buffer)) + (vc-ensure-vc-buffer) (cond - ((not (vc-registered (buffer-file-name))) - (vc-registration-error (buffer-file-name))) ((eq (vc-backend (buffer-file-name)) 'CVS) (error "Unchecking files under CVS is dangerous and not supported in VC")) ((vc-locking-user (buffer-file-name)) @@ -1876,7 +2114,7 @@ A prefix argument means do not revert the buffer afterwards." (error "Already editing new file name")) (if (file-exists-p new) (error "New file already exists")) - (let ((oldmaster (vc-name old))) + (let ((oldmaster (vc-name old)) newmaster) (if oldmaster (progn (if (vc-locking-user old) @@ -1885,23 +2123,32 @@ A prefix argument means do not revert the buffer afterwards." ;; This had FILE, I changed it to OLD. -- rms. (file-symlink-p (vc-backend-subdirectory-name old))) (error "This is not a safe thing to do in the presence of symbolic links")) - (rename-file - oldmaster - (let ((backend (vc-backend old)) - (newdir (or (file-name-directory new) "")) - (newbase (file-name-nondirectory new))) - (catch 'found - (mapcar - (function - (lambda (s) - (if (eq backend (cdr s)) - (let* ((newmaster (format (car s) newdir newbase)) - (newmasterdir (file-name-directory newmaster))) - (if (or (not newmasterdir) - (file-directory-p newmasterdir)) - (throw 'found newmaster)))))) - vc-master-templates) - (error "New file lacks a version control directory")))))) + (setq newmaster + (let ((backend (vc-backend old)) + (newdir (or (file-name-directory new) "")) + (newbase (file-name-nondirectory new))) + (catch 'found + (mapcar + (function + (lambda (s) + (if (eq backend (cdr s)) + (let* ((newmaster (format (car s) newdir newbase)) + (newmasterdir (file-name-directory newmaster))) + (if (or (not newmasterdir) + (file-directory-p newmasterdir)) + (throw 'found newmaster)))))) + vc-master-templates) + (error "New file lacks a version control directory")))) + ;; Handle the SCCS PROJECTDIR feature. It is odd that this + ;; is a special case, but a more elegant solution would require + ;; significant changes in other parts of VC. + (if (eq (vc-backend old) 'SCCS) + (let ((project-dir (vc-sccs-project-dir))) + (if project-dir + (setq newmaster + (concat project-dir + (file-name-nondirectory newmaster)))))) + (rename-file oldmaster newmaster))) (if (or (not oldmaster) (file-exists-p old)) (rename-file old new))) ; ?? Renaming a file might change its contents due to keyword expansion. @@ -1960,12 +2207,7 @@ default directory." (changelog (find-change-log)) ;; Presumably not portable to non-Unixy systems, along with rcs2log: (tempfile (make-temp-name - (concat (file-name-as-directory - (directory-file-name (or (getenv "TMPDIR") - (getenv "TMP") - (getenv "TEMP") - "/tmp"))) - "vc"))) + (expand-file-name "vc" temporary-file-directory))) (full-name (or add-log-full-name (user-full-name) (user-login-name) @@ -2096,8 +2338,9 @@ mode-specific menu. `vc-annotate-color-map' and `vc-annotate-very-old-color' defines the mapping of time to colors. `vc-annotate-background' specifies the background color." (interactive "p") - (if (not (eq (vc-buffer-backend) 'CVS)) ; This only works with CVS - (vc-registration-error (buffer-file-name))) + (vc-ensure-vc-buffer) + (if (not (eq (vc-backend (buffer-file-name)) 'CVS)) + (error "Sorry, vc-annotate is only implemented for CVS")) (message "Annotating...") (let ((temp-buffer-name (concat "*cvs annotate " (buffer-name) "*")) (temp-buffer-show-function 'vc-annotate-display) @@ -2107,35 +2350,35 @@ colors. `vc-annotate-background' specifies the background color." "annotate" (file-name-nondirectory (buffer-file-name))))) (message "Annotating... done")) -(defun vc-annotate-car-last-cons (assoc-list) - "Return car of last cons in ASSOC-LIST." - (if (not (eq nil (cdr assoc-list))) - (vc-annotate-car-last-cons (cdr assoc-list)) - (car (car assoc-list)))) +(defun vc-annotate-car-last-cons (a-list) + "Return car of last cons in association list A-LIST." + (if (not (eq nil (cdr a-list))) + (vc-annotate-car-last-cons (cdr a-list)) + (car (car a-list)))) -;; Return an association list with span factor applied to the -;; time-span of assoc-list. Optionaly quantize to the factor of -;; quantize. -(defun vc-annotate-time-span (assoc-list span &optional quantize) +(defun vc-annotate-time-span (a-list span &optional quantize) +"Return an association list with factor SPAN applied to the time-span +of association list A-LIST. Optionaly quantize to the factor of +QUANTIZE." ;; Apply span to each car of every cons - (if (not (eq nil assoc-list)) - (append (list (cons (* (car (car assoc-list)) span) - (cdr (car assoc-list)))) + (if (not (eq nil a-list)) + (append (list (cons (* (car (car a-list)) span) + (cdr (car a-list)))) (vc-annotate-time-span (nthcdr (cond (quantize) ; optional (1)) ; Default to cdr - assoc-list) span quantize)))) - -(defun vc-annotate-compcar (threshold &rest args) - "Test successive cars of ARGS against THRESHOLD. -Return the first cons which CAR is not less than THRESHOLD, nil otherwise" - ;; If no list is exhausted, - (if (and (not (memq 'nil args)) (< (car (car (car args))) threshold)) - ;; apply to CARs. - (apply 'vc-annotate-compcar threshold - ;; Recurse for rest of elements. - (mapcar 'cdr args)) - ;; Return the proper result - (car (car args)))) + a-list) span quantize)))) + +(defun vc-annotate-compcar (threshold a-list) + "Test successive cons cells of association list A-LIST against +THRESHOLD. Return the first cons cell which car is not less than +THRESHOLD, nil otherwise" + (let ((i 1) + (tmp-cons (car a-list))) + (while (and tmp-cons (< (car tmp-cons) threshold)) + (setq tmp-cons (car (nthcdr i a-list))) + (setq i (+ i 1))) + tmp-cons)) ; Return the appropriate value + (defun vc-annotate-display (buffer &optional color-map) "Do the VC-Annotate display in BUFFER using COLOR-MAP." @@ -2154,29 +2397,23 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (let* ((local-month-numbers '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) - ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) - ;; XEmacs use extents, GNU Emacs overlays. - (overlay-or-extent (if (string-match "XEmacs" emacs-version) - (cons 'make-extent 'set-extent-property) - (cons 'make-overlay 'overlay-put))) - (make-overlay-or-extent (car overlay-or-extent)) - (set-property-overlay-or-extent (cdr overlay-or-extent))) - + ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))) (set-buffer buffer) (display-buffer buffer) (if (not vc-annotate-mode) ; Turn on vc-annotate-mode if not done (vc-annotate-mode)) (goto-char (point-min)) ; Position at the top of the buffer. - (while (re-search-forward - "^[0-9]+\\(\.[0-9]+\\)*\\s-+(\\sw+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " + (while (re-search-forward + "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " +;; "^[0-9]+\\(\.[0-9]+\\)*\\s-+(\\sw+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " nil t) (let* (;; Unfortunately, order is important. match-string will ;; be corrupted by extent functions in XEmacs. Access ;; string-matches first. - (day (string-to-number (match-string 2))) - (month (cdr (assoc (match-string 3) local-month-numbers))) - (year-tmp (string-to-number (match-string 4))) + (day (string-to-number (match-string 1))) + (month (cdr (assoc (match-string 2) local-month-numbers))) + (year-tmp (string-to-number (match-string 3))) (year (+ (if (> 100 year-tmp) 1900 0) year-tmp)) ; Possible millenium problem (high (- (car (current-time)) (car (encode-time 0 0 0 day month year)))) @@ -2187,19 +2424,16 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (face-name (concat "vc-annotate-face-" (substring (cdr color) 1))) ;; Make the face if not done. (face (cond ((intern-soft face-name)) - ((make-face (intern face-name))))) - (point (point)) - (foo (forward-line 1)) - (overlay (cond ((if (string-match "XEmacs" emacs-version) - (extent-at point) - (car (overlays-at point )))) - ((apply make-overlay-or-extent point (point) nil))))) - - (if vc-annotate-background - (set-face-background face vc-annotate-background)) - (set-face-foreground face (cdr color)) - (apply set-property-overlay-or-extent overlay - 'face face nil))))) + ((let ((tmp-face (make-face (intern face-name)))) + (set-face-foreground tmp-face (cdr color)) + (if vc-annotate-background + (set-face-background tmp-face vc-annotate-background)) + tmp-face)))) ; Return the face + (point (point))) + + (forward-line 1) + (overlay-put (make-overlay point (point) nil) 'face face))))) + ;; Collect back-end-dependent stuff here @@ -2212,31 +2446,34 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (or vc-default-back-end (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS))) (message "Registering %s..." file) - (let ((switches - (if (stringp vc-register-switches) - (list vc-register-switches) - vc-register-switches)) - (backend - (cond - ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end) - ((file-exists-p "RCS") 'RCS) - ((file-exists-p "SCCS") 'SCCS) - ((file-exists-p "CVS") 'CVS) - (t vc-default-back-end)))) + (let* ((switches + (if (stringp vc-register-switches) + (list vc-register-switches) + vc-register-switches)) + (project-dir) + (backend + (cond + ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end) + ((file-exists-p "RCS") 'RCS) + ((file-exists-p "CVS") 'CVS) + ((file-exists-p "SCCS") 'SCCS) + ((setq project-dir (vc-sccs-project-dir)) 'SCCS) + (t vc-default-back-end)))) (cond ((eq backend 'SCCS) - ;; If there is no SCCS subdirectory yet, create it. - ;; (SCCS could do without it, but VC requires it to be there.) - (if (not (file-exists-p "SCCS")) (make-directory "SCCS")) - (apply 'vc-do-command nil 0 "admin" file 'MASTER ;; SCCS - (and rev (concat "-r" rev)) - "-fb" - (concat "-i" file) - (and comment (concat "-y" comment)) - (format - (car (rassq 'SCCS vc-master-templates)) - (or (file-name-directory file) "") - (file-name-nondirectory file)) - switches) + (let ((vc-name + (if project-dir (concat project-dir + "s." (file-name-nondirectory file)) + (format + (car (rassq 'SCCS vc-master-templates)) + (or (file-name-directory file) "") + (file-name-nondirectory file))))) + (apply 'vc-do-command nil 0 "admin" nil nil ;; SCCS + (and rev (concat "-r" rev)) + "-fb" + (concat "-i" file) + (and comment (concat "-y" comment)) + vc-name + switches)) (delete-file file) (if vc-keep-workfiles (vc-do-command nil 0 "get" file 'MASTER))) @@ -2401,12 +2638,11 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (and rev (not (string= rev "")) (concat "-r" rev)) switches) - ;; If no revision was specified, simply make the file writable. - (and writable - (or (eq (vc-checkout-model file) 'manual) - (zerop (logand 128 (file-modes file)))) - (set-file-modes file (logior 128 (file-modes file))))) - (if rev (vc-file-setprop file 'vc-workfile-version nil)))) + ;; If no revision was specified, call "cvs edit" to make + ;; the file writeable. + (and writable (eq (vc-checkout-model file) 'manual) + (vc-do-command nil 0 "cvs" file 'WORKFILE "edit"))) + (if rev (vc-file-setprop file 'vc-workfile-version nil)))) (cond ((not workfile) (vc-file-clear-masterprops file) @@ -2531,14 +2767,18 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" ;; if this was an explicit check-in, remove the sticky tag (if rev (vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A")) + ;; Forget the checkout model, because we might have assumed + ;; a wrong one when we found the file. After commit, we can + ;; tell it from the permissions of the file + ;; (see vc-checkout-model). + (vc-file-setprop file 'vc-checkout-model nil) (vc-file-setprop file 'vc-locking-user 'none) (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))))))) (message "Checking in %s...done" file)) (defun vc-backend-revert (file) - ;; Revert file to latest checked-in version. - ;; (for RCS, to workfile version) + ;; Revert file to the version it was based on. (message "Reverting %s..." file) (vc-file-clear-masterprops file) (vc-backend-dispatch @@ -2546,14 +2786,18 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" ;; SCCS (progn (vc-do-command nil 0 "unget" file 'MASTER nil) - (vc-do-command nil 0 "get" file 'MASTER nil)) + (vc-do-command nil 0 "get" file 'MASTER nil) + ;; Checking out explicit versions is not supported under SCCS, yet. + ;; We always "revert" to the latest version; therefore + ;; vc-workfile-version is cleared here so that it gets recomputed. + (vc-file-setprop file 'vc-workfile-version nil)) ;; RCS (vc-do-command nil 0 "co" file 'MASTER "-f" (concat "-u" (vc-workfile-version file))) ;; CVS - (progn - (delete-file file) - (vc-do-command nil 0 "cvs" file 'WORKFILE "update"))) + ;; Check out via standard output (caused by the final argument + ;; FILE below), so that no sticky tag is set. + (vc-backend-checkout file nil (vc-workfile-version file) file)) (vc-file-setprop file 'vc-locking-user 'none) (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) (message "Reverting %s...done" file) @@ -2661,9 +2905,7 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (and newvers (concat "-r" newvers)) (if (listp diff-switches) diff-switches - (list diff-switches))))) - (t - (vc-registration-error file))))) + (list diff-switches)))))))) (defun vc-backend-merge-news (file) ;; Merge in any new changes made to FILE. @@ -2691,23 +2933,27 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (vc-file-setprop file 'vc-workfile-version (match-string 1))) ;; get file status (if (re-search-forward - (concat "^\\([CMU]\\) " - (regexp-quote (file-name-nondirectory file))) + (concat "^\\(\\([CMU]\\) \\)?" + (regexp-quote (file-name-nondirectory file)) + "\\( already contains the differences between \\)?") nil t) (cond ;; Merge successful, we are in sync with repository now - ((string= (match-string 1) "U") - (vc-file-setprop file 'vc-locking-user 'none) + ((or (string= (match-string 2) "U") + ;; Special case: file contents in sync with + ;; repository anyhow: + (match-string 3)) + (vc-file-setprop file 'vc-locking-user 'none) (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) 0) ;; indicate success to the caller ;; Merge successful, but our own changes are still in the file - ((string= (match-string 1) "M") + ((string= (match-string 2) "M") (vc-file-setprop file 'vc-locking-user (vc-file-owner file)) (vc-file-setprop file 'vc-checkout-time 0) 0) ;; indicate success to the caller ;; Conflicts detected! - ((string= (match-string 1) "C") + ((string= (match-string 2) "C") (vc-file-setprop file 'vc-locking-user (vc-file-owner file)) (vc-file-setprop file 'vc-checkout-time 0) 1) ;; signal the error to the caller @@ -2716,6 +2962,32 @@ Return the first cons which CAR is not less than THRESHOLD, nil otherwise" (error "Couldn't analyze cvs update result")))) (message "Merging changes into %s...done" file))) +(defun vc-backend-merge (file first-version &optional second-version) + ;; Merge the changes between FIRST-VERSION and SECOND-VERSION into + ;; the current working copy of FILE. It is assumed that FILE is + ;; locked and writable (vc-merge ensures this). + (vc-backend-dispatch file + ;; SCCS + (error "Sorry, merging is not implemented for SCCS") + ;; RCS + (vc-do-command nil 1 "rcsmerge" file 'MASTER + "-kk" ;; ignore keyword conflicts + (concat "-r" first-version) + (if second-version (concat "-r" second-version))) + ;; CVS + (progn + (vc-do-command nil 0 "cvs" file 'WORKFILE + "update" "-kk" + (concat "-j" first-version) + (concat "-j" second-version)) + (save-excursion + (set-buffer (get-buffer "*vc*")) + (goto-char (point-min)) + (if (re-search-forward "conflicts during merge" nil t) + 1 ;; signal error + 0 ;; signal success + ))))) + (defun vc-check-headers () "Check if the current file has any headers in it." (interactive)