(require 'vc-hooks)
(require 'ring)
(eval-when-compile (require 'dired))
(if (not (assoc 'vc-parent-buffer minor-mode-alist))
(setq minor-mode-alist
(cons '(vc-parent-buffer vc-parent-buffer-name)
minor-mode-alist)))
(defmacro vc-backend-dispatch (f s r c)
"Execute FORM1, FORM2 or FORM3 for SCCS, RCS or CVS respectively.
If FORM3 is `RCS', use FORM2 for CVS as well as RCS.
\(CVS shares some code with RCS)."
(list 'let (list (list 'type (list 'vc-backend f)))
(list 'cond
(list (list 'eq 'type (quote 'SCCS)) s) (list (list 'eq 'type (quote 'RCS)) r) (list (list 'eq 'type (quote 'CVS)) (if (eq c 'RCS) r c))
)))
(defgroup vc nil
"Version-control system in Emacs."
:group 'tools)
(defcustom vc-suppress-confirm nil
"*If non-nil, treat user as expert; suppress yes-no prompts on some things."
:type 'boolean
:group 'vc)
(defcustom vc-delete-logbuf-window t
"*If non-nil, delete the *VC-log* buffer and window after each logical action.
If nil, bury that buffer instead.
This is most useful if you have multiple windows on a frame and would like to
preserve the setting."
:type 'boolean
:group 'vc)
(defcustom vc-initial-comment nil
"*If non-nil, prompt for initial comment when a file is registered."
: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
:group 'vc)
(defcustom vc-checkin-switches nil
"*A string or list of strings specifying extra switches for checkin.
These are passed to the checkin program by \\[vc-checkin]."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
string))
:group 'vc)
(defcustom vc-checkout-switches nil
"*A string or list of strings specifying extra switches for checkout.
These are passed to the checkout program by \\[vc-checkout]."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
string))
:group 'vc)
(defcustom vc-register-switches nil
"*A string or list of strings; extra switches for registering a file.
These are passed to the checkin program by \\[vc-register]."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
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)
:group 'vc)
(defconst vc-maximum-comment-ring-size 32
"Maximum number of saved comments in the comment ring.")
(defvar diff-switches "-c"
"*A string or list of strings specifying switches to be be passed to diff.")
(defcustom vc-annotate-color-map
'(( 26.3672 . "#FF0000")
( 52.7344 . "#FF3800")
( 79.1016 . "#FF7000")
(105.4688 . "#FFA800")
(131.8359 . "#FFE000")
(158.2031 . "#E7FF00")
(184.5703 . "#AFFF00")
(210.9375 . "#77FF00")
(237.3047 . "#3FFF00")
(263.6719 . "#07FF00")
(290.0391 . "#00FF31")
(316.4063 . "#00FF69")
(342.7734 . "#00FFA1")
(369.1406 . "#00FFD9")
(395.5078 . "#00EEFF")
(421.8750 . "#00B6FF")
(448.2422 . "#007EFF"))
"*Association list of age versus color, for \\[vc-annotate].
Ages are given in units of 2**-16 seconds.
Default is eighteen steps using a twenty day increment."
:type 'sexp
:group 'vc)
(defcustom vc-annotate-very-old-color "#0046FF"
"*Color for lines older than CAR of last cons in `vc-annotate-color-map'."
:type 'string
:group 'vc)
(defcustom vc-annotate-background "black"
"*Background color for \\[vc-annotate].
Default color is used if nil."
:type 'string
:group 'vc)
(defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01)
"*Menu elements for the mode-specific menu of VC-Annotate mode.
List of factors, used to expand/compress the time scale. See `vc-annotate'."
:type 'sexp
:group 'vc)
(defcustom vc-checkin-hook nil
"*Normal hook (list of functions) run after a checkin is done.
See `run-hooks'."
:type 'hook
:options '(vc-comment-to-change-log)
:group 'vc)
(defcustom vc-before-checkin-hook nil
"*Normal hook (list of functions) run before a file gets checked in.
See `run-hooks'."
:type 'hook
:group 'vc)
(defcustom vc-annotate-mode-hook nil
"*Hooks to run when VC-Annotate mode is turned on."
:type 'hook
:group 'vc)
(defcustom vc-header-alist
'((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
"*Header keywords to be inserted by `vc-insert-headers'.
Must be a list of two-element lists, the first element of each must
be `RCS', `CVS', or `SCCS'. The second element is the string to
be inserted for this particular backend."
:type '(repeat (list :format "%v"
(choice :tag "System"
(const SCCS)
(const RCS)
(const CVS))
(string :tag "Header")))
:group 'vc)
(defcustom vc-static-header-alist
'(("\\.c$" .
"\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
"*Associate static header string templates with file types. A \%s in the
template is replaced with the first string associated with the file's
version-control type in `vc-header-alist'."
:type '(repeat (cons :format "%v"
(regexp :tag "File Type")
(string :tag "Header String")))
:group 'vc)
(defcustom vc-comment-alist
'((nroff-mode ".\\\"" ""))
"*Special comment delimiters to be used in generating vc headers only.
Add an entry in this list if you need to override the normal comment-start
and comment-end variables. This will only be necessary if the mode language
is sensitive to blank lines."
:type '(repeat (list :format "%v"
(symbol :tag "Mode")
(string :tag "Comment Start")
(string :tag "Comment End")))
:group 'vc)
(defcustom vc-checkout-carefully (= (user-uid) 0)
"*Non-nil means be extra-careful in checkout.
Verify that the file really is not locked
and that its contents match what the master file says."
:type 'boolean
:group 'vc)
(defcustom vc-rcs-release nil
"*The release number of your RCS installation, as a string.
If nil, VC itself computes this value when it is first needed."
:type '(choice (const :tag "Auto" nil)
string
(const :tag "Unknown" unknown))
:group 'vc)
(defcustom vc-sccs-release nil
"*The release number of your SCCS installation, as a string.
If nil, VC itself computes this value when it is first needed."
:type '(choice (const :tag "Auto" nil)
string
(const :tag "Unknown" unknown))
:group 'vc)
(defcustom vc-cvs-release nil
"*The release number of your CVS installation, as a string.
If nil, VC itself computes this value when it is first needed."
:type '(choice (const :tag "Auto" nil)
string
(const :tag "Unknown" unknown))
:group 'vc)
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
(defvar vc-log-after-operation-hook nil)
(defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer)
(defvar vc-parent-buffer nil)
(defvar vc-parent-buffer-name nil)
(defvar vc-log-file)
(defvar vc-log-version)
(defconst vc-name-assoc-file "VC-names")
(defvar vc-dired-mode nil)
(make-variable-buffer-local 'vc-dired-mode)
(defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
(defvar vc-comment-ring-index nil)
(defvar vc-last-comment-match nil)
(defun vc-backend-release (backend)
(cond
((eq backend 'RCS)
(or vc-rcs-release
(and (zerop (vc-do-command nil nil "rcs" nil nil "-V"))
(save-excursion
(set-buffer (get-buffer "*vc*"))
(setq vc-rcs-release
(car (vc-parse-buffer
'(("^RCS version \\([0-9.]+ *.*\\)" 1)))))))
(setq vc-rcs-release 'unknown)))
((eq backend 'CVS)
(or vc-cvs-release
(and (zerop (vc-do-command nil 1 "cvs" nil nil "-v"))
(save-excursion
(set-buffer (get-buffer "*vc*"))
(setq vc-cvs-release
(car (vc-parse-buffer
'(("^Concurrent Versions System (CVS) \\([0-9.]+\\)"
1)))))))
(setq vc-cvs-release 'unknown)))
((eq backend 'SCCS)
vc-sccs-release)))
(defun vc-release-greater-or-equal (r1 r2)
(let (v1 v2 i1 i2)
(catch 'done
(or (and (string-match "^\\.?\\([0-9]+\\)" r1)
(setq i1 (match-end 0))
(setq v1 (string-to-number (match-string 1 r1)))
(or (and (string-match "^\\.?\\([0-9]+\\)" r2)
(setq i2 (match-end 0))
(setq v2 (string-to-number (match-string 1 r2)))
(if (> v1 v2) (throw 'done t)
(if (< v1 v2) (throw 'done nil)
(throw 'done
(vc-release-greater-or-equal
(substring r1 i1)
(substring r2 i2)))))))
(throw 'done t)))
(or (and (string-match "^\\.?\\([0-9]+\\)" r2)
(throw 'done nil))
(throw 'done t)))))
(defun vc-backend-release-p (backend release)
(let (i r (ri 0) (ii 0) is rs (installation (vc-backend-release backend)))
(if (not (eq installation 'unknown))
(cond
((or (eq backend 'RCS) (eq backend 'CVS))
(vc-release-greater-or-equal installation release))))))
(defun vc-trunk-p (rev)
(not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
(defun vc-branch-p (rev)
(not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
(defun vc-branch-part (rev)
(substring rev 0 (string-match "\\.[0-9]+\\'" rev)))
(defun vc-minor-part (rev)
(string-match "[0-9]+\\'" rev)
(substring rev (match-beginning 0) (match-end 0)))
(defun vc-previous-version (rev)
(let ((branch (vc-branch-part rev))
(minor-num (string-to-number (vc-minor-part rev))))
(if (> minor-num 1)
(concat branch "." (number-to-string (1- minor-num)))
(if (vc-trunk-p rev)
""
(vc-branch-part branch)))))
(defun vc-clear-context ()
"Clear all cached file properties and the comment ring."
(interactive)
(fillarray vc-file-prop-obarray nil)
(setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
(defun vc-file-clear-masterprops (file)
(vc-file-setprop file 'vc-latest-version nil)
(vc-file-setprop file 'vc-your-latest-version nil)
(vc-backend-dispatch file
(progn (vc-file-setprop file 'vc-master-locks nil))
(progn (vc-file-setprop file 'vc-default-branch nil)
(vc-file-setprop file 'vc-head-version nil)
(vc-file-setprop file 'vc-master-workfile-version nil)
(vc-file-setprop file 'vc-master-locks nil))
(progn
(vc-file-setprop file 'vc-cvs-status nil))))
(defun vc-head-version (file)
(cond ((vc-file-getprop file 'vc-head-version))
(t (vc-fetch-master-properties file)
(vc-file-getprop file 'vc-head-version))))
(defun vc-latest-on-branch-p (file)
(vc-backend-dispatch file
(string= (vc-workfile-version file) (vc-latest-version file))
(let ((workfile-version (vc-workfile-version file)) tip-version)
(if (vc-trunk-p workfile-version)
(progn
(vc-fetch-master-properties file)
(string= (vc-file-getprop file 'vc-head-version)
workfile-version))
(save-excursion
(set-buffer (get-buffer-create "*vc-info*"))
(vc-insert-file (vc-name file) "^desc")
(setq tip-version (car (vc-parse-buffer (list (list
(concat "^\\(" (regexp-quote (vc-branch-part workfile-version))
"\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2)))))
(if (get-buffer "*vc-info*")
(kill-buffer (get-buffer "*vc-info*")))
(string= tip-version workfile-version))))
t))
(defmacro with-vc-file (file comment &rest body)
"Execute BODY, checking out a writable copy of FILE first if necessary.
After BODY has been executed, check-in FILE with COMMENT (a string).
FILE is passed through `expand-file-name'; BODY executed within
`save-excursion'. If FILE is not under version control, or locked by
somebody else, signal error."
`(let ((file (expand-file-name ,file)))
(or (vc-registered file)
(error (format "File not under version control: `%s'" file)))
(let ((locking-user (vc-locking-user file)))
(cond ((and (not locking-user)
(eq (vc-checkout-model file) 'manual))
(vc-checkout file t))
((and (stringp locking-user)
(not (string= locking-user (vc-user-login-name))))
(error (format "`%s' is locking `%s'" locking-user file)))))
(save-excursion
,@body)
(vc-checkin file nil ,comment)))
(defmacro edit-vc-file (file comment &rest body)
"Edit FILE under version control, executing BODY. Checkin with COMMENT.
This macro uses `with-vc-file', passing args to it.
However, before executing BODY, find FILE, and after BODY, save buffer."
`(with-vc-file
,file ,comment
(find-file ,file)
,@body
(save-buffer)))
(defun vc-ensure-vc-buffer ()
(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))
(catch 'found
(mapcar
(function
(lambda (s)
(if s
(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 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)
(olddir default-directory)
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)
(concat " from " (buffer-name camefrom)))
(setq default-directory olddir)
(erase-buffer)
(mapcar
(function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
flags)
(if (and (eq last 'MASTER) file (setq vc-file (vc-name file)))
(setq squeezed (append squeezed (list vc-file))))
(if (and file (eq last 'WORKFILE))
(progn
(let* ((pwd (expand-file-name default-directory))
(preflen (length pwd)))
(if (string= (substring file 0 preflen) pwd)
(setq file (substring file preflen))))
(setq squeezed (append squeezed (list file)))))
(let ((exec-path (append vc-path exec-path))
(process-environment
(cons (concat "PATH=" (getenv "PATH")
path-separator
(mapconcat 'identity vc-path path-separator))
process-environment))
(w32-quote-process-args t))
(setq status (apply 'call-process command nil t nil squeezed)))
(goto-char (point-max))
(set-buffer-modified-p nil)
(forward-line -1)
(if (or (not (integerp status)) (and okstatus (< okstatus status)))
(progn
(pop-to-buffer buffer)
(goto-char (point-min))
(shrink-window-if-larger-than-buffer)
(error "Running %s...FAILED (%s)" command
(if (integerp status)
(format "status %d" status)
status))
)
(if vc-command-messages
(message "Running %s...OK" command))
)
(set-buffer obuf)
status)
)
(defun vc-position-context (posn)
(list posn
(buffer-size)
(buffer-substring posn
(min (point-max) (+ posn 100)))))
(defun vc-find-position-by-context (context)
(let ((context-string (nth 2 context)))
(if (equal "" context-string)
(point-max)
(save-excursion
(let ((diff (- (nth 1 context) (buffer-size))))
(if (< diff 0) (setq diff (- diff)))
(goto-char (nth 0 context))
(if (or (search-forward context-string nil t)
(progn (goto-char (- (point) diff (length context-string)))
(search-forward context-string nil t)))
(- (point) (length context-string))))))))
(defun vc-context-matches-p (posn context)
(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 ()
(let ((point-context (vc-position-context (point)))
(mark-context (if (eq (marker-buffer (mark-marker)) (current-buffer))
(vc-position-context (mark-marker))))
(mark-active nil)
(reparse (and (boundp 'compilation-error-list) (let ((curbuf (current-buffer)))
(save-excursion
(mapcar (function
(lambda (buffer)
(set-buffer buffer)
(let ((errors (or
compilation-old-error-list
compilation-error-list))
(buffer-error-marked-p nil))
(while (and (consp errors)
(not buffer-error-marked-p))
(and (markerp (cdr (car errors)))
(eq buffer
(marker-buffer
(cdr (car errors))))
(setq buffer-error-marked-p t))
(setq errors (cdr errors)))
(if buffer-error-marked-p buffer))))
(buffer-list)))))))
(list point-context mark-context reparse)))
(defun vc-restore-buffer-context (context)
(let ((point-context (nth 0 context))
(mark-context (nth 1 context))
(reparse (nth 2 context)))
(while reparse
(if (car reparse)
(save-excursion
(set-buffer (car reparse))
(let ((compilation-last-buffer (current-buffer)) (error-pos (marker-position
(car (car-safe compilation-error-list)))))
(compile-reinitialize-errors '(4) compilation-parsing-end)
(while (and compilation-error-list
(/= error-pos (car (car compilation-error-list))))
(setq compilation-error-list (cdr compilation-error-list))))))
(setq reparse (cdr reparse)))
(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)
(interactive "P")
(widen)
(let ((context (vc-buffer-context)))
(save-excursion
(revert-buffer arg no-confirm t))
(vc-restore-buffer-context context)))
(defun vc-buffer-sync (&optional not-urgent)
(if (buffer-modified-p)
(if (or vc-suppress-confirm
(y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
(save-buffer)
(if not-urgent
nil
(error "Aborted")))))
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
(let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
(lastmod (nth 5 (file-attributes file))))
(or (equal checkout-time lastmod)
(and (or (not checkout-time) want-differences-if-changed)
(let ((unchanged (zerop (vc-backend-diff file nil nil
(not want-differences-if-changed)))))
(vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
unchanged)))))
(defun vc-next-action-on-file (file verbose &optional comment)
(let ((vc-type (vc-backend file))
owner version buffer)
(cond
((not vc-type)
(vc-register verbose comment))
((and (eq vc-type 'CVS)
(or (eq (vc-cvs-status file) 'needs-checkout)
(eq (vc-cvs-status file) 'needs-merge)))
(if (or vc-dired-mode
(yes-or-no-p
(format "%s is not up-to-date. Merge in changes now? "
(buffer-name))))
(progn
(if vc-dired-mode
(and (setq buffer (get-file-buffer file))
(buffer-modified-p buffer)
(switch-to-buffer-other-window buffer)
(vc-buffer-sync t))
(setq buffer (current-buffer))
(vc-buffer-sync t))
(if (and buffer (buffer-modified-p buffer)
(not (yes-or-no-p
(format
"Buffer %s modified; merge file on disc anyhow? "
(buffer-name buffer)))))
(error "Merge aborted"))
(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))))
((and (eq vc-type 'CVS)
(eq (vc-checkout-model file) 'implicit)
(not (vc-locking-user file))
(not verbose))
(message "%s is up to date" (buffer-name)))
((not (setq owner (vc-locking-user file)))
(and (eq (vc-checkout-model file) 'implicit)
(buffer-modified-p buffer)
(vc-buffer-sync))
(if (and vc-checkout-carefully
(not (vc-workfile-unchanged-p file t)))
(if (save-window-excursion
(pop-to-buffer "*vc-diff*")
(goto-char (point-min))
(insert-string (format "Changes to %s since last lock:\n\n"
file))
(not (beep))
(yes-or-no-p
(concat "File has unlocked changes, "
"claim lock retaining changes? ")))
(progn (vc-backend-steal file)
(vc-mode-line file))
(if (not (yes-or-no-p "Revert to checked-in version, instead? "))
(error "Checkout aborted")
(vc-revert-buffer1 t t)
(vc-checkout-writable-buffer file))
)
(if verbose
(if (not (eq vc-type 'SCCS))
(vc-checkout file nil
(read-string "Branch or version to move to: "))
(error "Sorry, this is not implemented for SCCS"))
(if (vc-latest-on-branch-p file)
(vc-checkout-writable-buffer file)
(if (yes-or-no-p
"This is not the latest version. Really lock it? ")
(vc-checkout-writable-buffer file)
(if (yes-or-no-p "Lock the latest version instead? ")
(vc-checkout-writable-buffer file
(if (vc-trunk-p (vc-workfile-version file))
"" (vc-branch-part (vc-workfile-version file)))))))
)))
((and (not (eq vc-type 'CVS))
(not (string-equal owner (vc-user-login-name))))
(if comment
(error "Sorry, you can't steal the lock on %s this way" file))
(and (eq vc-type 'RCS)
(not (vc-backend-release-p 'RCS "5.6.2"))
(error "File is locked by %s" owner))
(vc-steal-lock
file
(if verbose (read-string "Version to steal: ")
(vc-workfile-version file))
owner))
(t
(if vc-dired-mode
(find-file-other-window file)
(find-file file))
(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"))
(vc-buffer-sync))
(if (and (vc-workfile-unchanged-p file)
(not (buffer-modified-p)))
(cond
((yes-or-no-p "Revert to master version? ")
(vc-backend-revert file)
(vc-resynch-window file t t)))
(if verbose
(setq version (read-string "New version level: ")))
(vc-checkin file version comment)
)))))
(defvar vc-dired-window-configuration)
(defun vc-next-action-dired (file rev comment)
(let ((dired-buffer (current-buffer))
(dired-dir default-directory))
(dired-map-over-marks
(let ((file (dired-get-filename)))
(message "Processing %s..." file)
(let ((default-directory (file-name-directory file)))
(vc-next-action-on-file file nil comment)
(set-buffer dired-buffer))
(let ((vc-dired-terse-mode nil))
(dired-do-redisplay file))
(set-window-configuration vc-dired-window-configuration)
(message "Processing %s...done" file))
nil t))
(dired-move-to-filename))
(defun vc-next-action (verbose)
"Do the next logical checkin or checkout operation on the current file.
If you call this from within a VC dired buffer with no files marked,
it will operate on the file in the current line.
If you call this from within a VC dired buffer, and one or more
files are marked, it will accept a log message and then operate on
each one. The log message will be used as a comment for any register
or checkin operations, but ignored when doing checkouts. Attempted
lock steals will raise an error.
A prefix argument lets you specify the version number to use.
For RCS and SCCS files:
If the file is not already registered, this registers it for version
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
first checks to see if the file has changed since checkout. If not,
it performs a revert.
If the file has been changed, this pops up a buffer for entry
of a log message; when the message has been entered, it checks in the
resulting changes along with the log message as change commentary. If
the variable `vc-keep-workfiles' is non-nil (which is its default), a
read-only copy of the changed file is left in place afterwards.
If the file is registered and locked by someone else, you are given
the option to steal the lock.
For CVS files:
If the file is not already registered, this registers it for version
control. This does a \"cvs add\", but no \"cvs commit\".
If the file is added but not committed, it is committed.
If your working file is changed, but the repository file is
unchanged, this pops up a buffer for entry of a log message; when the
message has been entered, it checks in the resulting changes along
with the logmessage as change commentary. A writable file is retained.
If the repository file is changed, you are asked if you want to
merge in the changes into your working copy."
(interactive "P")
(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)
(if (eq (vc-backend f) 'CVS)
(if (or (eq (vc-cvs-status f) 'locally-modified)
(eq (vc-cvs-status f) 'locally-added))
"@" "")
(if (vc-locking-user f) "@" ""))))
files ""))
(vc-next-action-dired nil nil "dummy")
(vc-start-entry nil nil nil
"Enter a change comment for the marked files."
'vc-next-action-dired))
(throw 'nogo nil)))
(while vc-parent-buffer
(pop-to-buffer vc-parent-buffer))
(if buffer-file-name
(vc-next-action-on-file buffer-file-name verbose)
(error "Buffer %s is not associated with a file" (buffer-name)))))
(defun vc-checkout-writable-buffer (&optional file rev)
"Retrieve a writable copy of the latest version of the current buffer's file."
(vc-checkout (or file (buffer-file-name)) t rev)
)
(defun vc-register (&optional override comment)
"Register the current file into your version-control system."
(interactive "P")
(or buffer-file-name
(error "No visited file"))
(let ((master (vc-name buffer-file-name)))
(and master (file-exists-p master)
(error "This file is already registered"))
(and master
(not (y-or-n-p "Previous master file has vanished. Make a new one? "))
(error "This file is already registered")))
(if (and (not (buffer-modified-p))
(zerop (buffer-size))
(not (file-exists-p buffer-file-name)))
(set-buffer-modified-p t))
(vc-buffer-sync)
(cond ((not vc-make-backup-files)
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(vc-admin
buffer-file-name
(or (and override
(read-string
(format "Initial version level for %s: " buffer-file-name)))
vc-default-init-version)
comment)
(setq vc-buffer-backend (vc-backend (buffer-file-name)))
)
(defun vc-resynch-window (file &optional keep noquery)
(and (string= buffer-file-name file)
(if keep
(progn
(vc-revert-buffer1 t noquery)
(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 (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)
(let ((parent (if file (find-file-noselect file) (current-buffer))))
(if vc-before-checkin-hook
(if file
(save-excursion
(set-buffer parent)
(run-hooks 'vc-before-checkin-hook))
(run-hooks 'vc-before-checkin-hook)))
(if comment
(set-buffer (get-buffer-create "*VC-log*"))
(pop-to-buffer (get-buffer-create "*VC-log*")))
(set (make-local-variable 'vc-parent-buffer) parent)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name vc-parent-buffer)))
(if file (vc-mode-line file))
(vc-log-mode file)
(make-local-variable 'vc-log-after-operation-hook)
(if after-hook
(setq vc-log-after-operation-hook after-hook))
(setq vc-log-operation action)
(setq vc-log-version rev)
(if comment
(progn
(erase-buffer)
(if (eq comment t)
(vc-finish-logentry t)
(insert comment)
(vc-finish-logentry nil)))
(message "%s Type C-c C-c when done." msg))))
(defun vc-admin (file rev &optional comment)
"Check a file into your version-control system.
FILE is the unmodified name of the file. REV should be the base version
level to check it in under. COMMENT, if specified, is the checkin comment."
(vc-start-entry file rev
(or comment (not vc-initial-comment))
"Enter initial comment." 'vc-backend-admin
nil))
(defun vc-checkout (file &optional writable rev)
"Retrieve a copy of the latest version of the given file."
(if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp"))
(error "Sorry, you can't check out files over FTP"))
(vc-backend-checkout file writable rev)
(vc-resynch-buffer file t t))
(defun vc-steal-lock (file rev &optional owner)
"Steal the lock on the current workfile."
(let (file-description)
(if (not owner)
(setq owner (vc-locking-user file)))
(if rev
(setq file-description (format "%s:%s" file rev))
(setq file-description file))
(if (not (yes-or-no-p (format "Steal the lock on %s from %s? "
file-description owner)))
(error "Steal cancelled"))
(pop-to-buffer (get-buffer-create "*VC-mail*"))
(setq default-directory (expand-file-name "~/"))
(auto-save-mode auto-save-default)
(mail-mode)
(erase-buffer)
(mail-setup owner (format "Stolen lock on %s" file-description) nil nil nil
(list (list 'vc-finish-steal file rev)))
(goto-char (point-max))
(insert
(format "I stole the lock on %s, " file-description)
(current-time-string)
".\n")
(message "Please explain why you stole the lock. Type C-c C-c when done.")))
(defun vc-finish-steal (file version)
(vc-backend-steal file version)
(if (get-file-buffer file)
(save-excursion
(set-buffer (get-file-buffer file))
(vc-resynch-window file t t))))
(defun vc-checkin (file &optional rev comment)
"Check in the file specified by FILE.
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.
Runs the normal hook `vc-checkin-hook'."
(vc-start-entry file rev comment
"Enter a change comment." 'vc-backend-checkin
'vc-checkin-hook))
(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'.
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))))
(require 'add-log)
(let ( (comment (ring-ref vc-comment-ring 0))
(add-log-current-defun-function 'ignore)
end)
(add-change-log-entry whoami file-name t t)
(setq end (save-excursion (insert comment) (point-marker)))
(if (looking-at "\\s *\\s(")
(delete-char -2))
(just-one-space)
(let ((indentation (current-indentation)))
(save-excursion
(while (< (point) end)
(forward-line 1)
(indent-to indentation))
(setq end (point))))
(let ((paragraph-separate (concat paragraph-separate "\\|\\s *\\s("))
(paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
(beginning-of-line)
(fill-region (point) end))
(skip-syntax-forward " " end)
(delete-char (- (skip-syntax-backward " ")))
(or (eobp) (looking-at "\n\n")
(insert "\n"))))
(defun vc-finish-logentry (&optional nocomment)
"Complete the operation implied by the current log entry."
(interactive)
(if (not nocomment)
(progn
(vc-backend-logentry-check vc-log-file)
(ring-insert vc-comment-ring (buffer-string))
))
(save-excursion
(set-buffer vc-parent-buffer)
(or vc-dired-mode
(vc-buffer-sync)))
(if (not vc-log-operation) (error "No log operation is pending"))
(let ((log-operation vc-log-operation)
(log-file vc-log-file)
(log-version vc-log-version)
(log-entry (buffer-string))
(after-hook vc-log-after-operation-hook)
(tmp-vc-parent-buffer vc-parent-buffer))
(pop-to-buffer vc-parent-buffer)
(save-excursion
(funcall log-operation
log-file
log-version
log-entry))
(let ((logbuf (get-buffer "*VC-log*")))
(cond ((and logbuf vc-delete-logbuf-window)
(delete-windows-on logbuf (selected-frame))
(kill-buffer logbuf))
(t (pop-to-buffer "*VC-log*")
(bury-buffer)
(pop-to-buffer tmp-vc-parent-buffer))))
(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)))
(defun vc-previous-comment (arg)
"Cycle backwards through comment history."
(interactive "*p")
(let ((len (ring-length vc-comment-ring)))
(cond ((<= len 0)
(message "Empty comment ring")
(ding))
(t
(erase-buffer)
(if (null vc-comment-ring-index)
(setq vc-comment-ring-index
(if (> arg 0) -1
(if (< arg 0) 1 0))))
(setq vc-comment-ring-index
(mod (+ vc-comment-ring-index arg) len))
(message "%d" (1+ vc-comment-ring-index))
(insert (ring-ref vc-comment-ring vc-comment-ring-index))))))
(defun vc-next-comment (arg)
"Cycle forwards through comment history."
(interactive "*p")
(vc-previous-comment (- arg)))
(defun vc-comment-search-reverse (str)
"Searches backwards through comment history for substring match."
(interactive "sComment substring: ")
(if (string= str "")
(setq str vc-last-comment-match)
(setq vc-last-comment-match str))
(if (null vc-comment-ring-index)
(setq vc-comment-ring-index -1))
(let ((str (regexp-quote str))
(len (ring-length vc-comment-ring))
(n (1+ vc-comment-ring-index)))
(while (and (< n len) (not (string-match str (ring-ref vc-comment-ring n))))
(setq n (+ n 1)))
(cond ((< n len)
(vc-previous-comment (- n vc-comment-ring-index)))
(t (error "Not found")))))
(defun vc-comment-search-forward (str)
"Searches forwards through comment history for substring match."
(interactive "sComment substring: ")
(if (string= str "")
(setq str vc-last-comment-match)
(setq vc-last-comment-match str))
(if (null vc-comment-ring-index)
(setq vc-comment-ring-index 0))
(let ((str (regexp-quote str))
(len (ring-length vc-comment-ring))
(n vc-comment-ring-index))
(while (and (>= n 0) (not (string-match str (ring-ref vc-comment-ring n))))
(setq n (- n 1)))
(cond ((>= n 0)
(vc-next-comment (- n vc-comment-ring-index)))
(t (error "Not found")))))
(defun vc-diff (historic &optional not-urgent)
"Display diffs between file versions.
Normally this compares the current file and buffer with the most recent
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))
(vc-ensure-vc-buffer)
(if historic
(call-interactively 'vc-version-diff)
(let ((file buffer-file-name)
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)
(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
(let ((file (expand-file-name
(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))
(cond
((file-directory-p file)
nil)
((vc-locking-user file)
(setq rel1-default (vc-workfile-version file)))
(t
(setq rel1-default (vc-previous-version (vc-workfile-version file)))
(setq rel2-default (vc-workfile-version file))))
(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)
(let ((camefrom (current-buffer)))
(set-buffer (get-buffer-create "*vc-status*"))
(set (make-local-variable 'vc-parent-buffer) camefrom)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name camefrom)))
(erase-buffer)
(insert "Diffs between "
(or rel1 "last version checked in")
" and "
(or rel2 "current workfile(s)")
":\n\n")
(set-buffer (get-buffer-create "*vc-diff*"))
(cd file)
(vc-file-tree-walk
default-directory
(function (lambda (f)
(message "Looking at %s" f)
(and
(not (file-directory-p f))
(vc-registered f)
(vc-backend-diff f rel1 rel2)
(append-to-buffer "*vc-status*" (point-min) (point-max)))
)))
(pop-to-buffer "*vc-status*")
(insert "\nEnd of diffs.\n")
(goto-char (point-min))
(set-buffer-modified-p nil)
)
(if (zerop (vc-backend-diff file rel1 rel2))
(message "No changes to %s between %s and %s." file rel1 rel2)
(pop-to-buffer "*vc-diff*"))))
(defun vc-version-other-window (rev)
"Visit version REV of the current buffer in another window.
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): ")
(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)))
(defun vc-insert-headers ()
"Insert headers in a file for use with your version-control system.
Headers desired are inserted at point, and are pulled from
the variable `vc-header-alist'."
(interactive)
(vc-ensure-vc-buffer)
(save-excursion
(save-restriction
(widen)
(if (or (not (vc-check-headers))
(y-or-n-p "Version headers already exist. Insert another set? "))
(progn
(let* ((delims (cdr (assq major-mode vc-comment-alist)))
(comment-start-vc (or (car delims) comment-start "#"))
(comment-end-vc (or (car (cdr delims)) comment-end ""))
(hdstrings (cdr (assoc (vc-backend (buffer-file-name)) vc-header-alist))))
(mapcar (function (lambda (s)
(insert comment-start-vc "\t" s "\t"
comment-end-vc "\n")))
hdstrings)
(if vc-static-header-alist
(mapcar (function (lambda (f)
(if (string-match (car f) buffer-file-name)
(insert (format (cdr f) (car hdstrings))))))
vc-static-header-alist))
)
)))))
(defun vc-clear-headers ()
(let ((context (vc-buffer-context))
(case-fold-search nil))
(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)))
(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) ".")))
(setq second-version first-version)
(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"))))))
(defvar vc-ediff-windows)
(defvar vc-ediff-result)
(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))
(set-buffer (ediff-merge-buffers your-buffer other-buffer))
(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))))
(defvar vc-dired-switches)
(defvar vc-dired-terse-mode)
(define-derived-mode vc-dired-mode dired-mode "Dired under VC"
"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)
(set (make-local-variable 'dired-move-to-filename-regexp)
(let*
((l "\\([A-Za-z]\\|[^\0-\177]\\)")
(month (concat l l "+ *"))
(k "[^\0-\177]")
(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"\\|" yyyy s "\\)"))
(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 "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))
(vc-do-command "*vc-info*" 0 "cvs" nil nil "status" "-l")
(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)
(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)
(beginning-of-line)
(let ((pos (point)) limit perm date-and-file)
(end-of-line)
(setq limit (point))
(goto-char pos)
(when
(or
(re-search-forward "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[^ ]+ +[0-9]+\\( .*\\)"
limit t)
(re-search-forward "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[0-9]+\\( .*\\)"
limit t)
(re-search-forward "^\\(..[drwxlts-]+ \\) *[0-9]+\\( .*\\)"
limit t))
(setq perm (match-string 1)
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 ()
(message "Getting version information... ")
(let (subdir filename (buffer-read-only nil) cvs-dir)
(goto-char (point-min))
(while (not (eq (point) (point-max)))
(cond
((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)
(let ((start (point)))
(end-of-line)
(delete-region start (point))
(beginning-of-line)
(forward-line 1)))
((setq filename (dired-get-filename nil t))
(cond
((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
(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))))
((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))))
(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 ()
(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 "")
(forward-line 1)
(kill-line)
(if (not (dired-next-subdir 1 t))
(goto-char (point-max))))))
(goto-char (point-min))))
(defun vc-directory (dirname read-switches)
(interactive "DDired under VC (directory): \nP")
(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)
(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))))
(defun vc-add-triple (name file rev)
(save-excursion
(find-file (expand-file-name
vc-name-assoc-file
(file-name-directory (vc-name file))))
(goto-char (point-max))
(insert name "\t:\t" file "\t" rev "\n")
(basic-save-buffer)
(kill-buffer (current-buffer))
))
(defun vc-record-rename (file newname)
(save-excursion
(find-file
(expand-file-name
vc-name-assoc-file
(file-name-directory (vc-name file))))
(goto-char (point-min))
(while (re-search-forward (concat ":" (regexp-quote file) "$") nil t)
(replace-match (concat ":" newname) nil nil))
(basic-save-buffer)
(kill-buffer (current-buffer))
))
(defun vc-lookup-triple (file name)
(cond ((null name) name)
((let ((firstchar (aref name 0)))
(and (>= firstchar ?0) (<= firstchar ?9)))
name)
(t
(save-excursion
(set-buffer (get-buffer-create "*vc-info*"))
(vc-insert-file
(expand-file-name
vc-name-assoc-file
(file-name-directory (vc-name file))))
(prog1
(car (vc-parse-buffer
(list (list (concat name "\t:\t" file "\t\\(.+\\)") 1))))
(kill-buffer "*vc-info*"))))
))
(defun vc-snapshot-precondition ()
(let ((status nil))
(catch 'vc-locked-example
(vc-file-tree-walk
default-directory
(function (lambda (f)
(and (vc-registered f)
(if (vc-locking-user f) (throw 'vc-locked-example f)
(if (get-file-buffer f) (setq status 'visited)))))))
status)))
(defun vc-create-snapshot (name)
"Make a snapshot called NAME.
The snapshot is made from all registered files at or below the current
directory. For each file, the version level of its latest
version becomes part of the named configuration."
(interactive "sNew snapshot name: ")
(let ((result (vc-snapshot-precondition)))
(if (stringp result)
(error "File %s is locked" result)
(vc-file-tree-walk
default-directory
(function (lambda (f) (and
(vc-name f)
(vc-backend-assign-name f name)))))
)))
(defun vc-retrieve-snapshot (name)
"Retrieve the snapshot called NAME, or latest versions if NAME is empty.
When retrieving a snapshot, there must not be any locked files at or below
the current directory. If none are locked, all registered files are
checked out (unlocked) at their version levels in the snapshot NAME.
If NAME is the empty string, all registered files that are not currently
locked are updated to the latest versions."
(interactive "sSnapshot name to retrieve (default latest versions): ")
(let ((update (yes-or-no-p "Update any affected buffers? ")))
(if (string= name "")
(progn
(vc-file-tree-walk
default-directory
(function (lambda (f) (and
(vc-registered f)
(not (vc-locking-user f))
(vc-error-occurred
(vc-backend-checkout f nil "")
(if update (vc-resynch-buffer f t t))))))))
(let ((result (vc-snapshot-precondition)))
(if (stringp result)
(error "File %s is locked" result)
(setq update (and (eq result 'visited) update))
(vc-file-tree-walk
default-directory
(function (lambda (f) (and
(vc-name f)
(vc-error-occurred
(vc-backend-checkout f nil name)
(if update (vc-resynch-buffer f t t)))))))
)))))
(defun vc-print-log ()
"List the change log of the current buffer in a window."
(interactive)
(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)
(and (not (eq (vc-backend file) 'SCCS))
(re-search-forward
(concat "----\nrevision " (vc-workfile-version file)
"\\(\tlocked by:.*\n\\|\n\\)date: ") nil t)
(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
((< (count-lines (point-min) end) (window-height))
(goto-char (point-min))
(recenter 0)
(goto-char start))
((< (1+ lines) (window-height))
(goto-char start)
(recenter (1- (- (/ (window-height) 2) (/ lines 2)))))
(t
(goto-char start)
(recenter 0)))))))
(defun vc-revert-buffer ()
"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. 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)
(vc-ensure-vc-buffer)
(let ((file buffer-file-name)
(vc-suppress-confirm nil)
(obuf (current-buffer)) (changed (vc-diff nil t)))
(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))))
(set-buffer obuf)
(vc-backend-revert file)
(vc-resynch-window file t t)))
(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")
(vc-ensure-vc-buffer)
(cond
((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))
(error "This version is locked; use vc-revert-buffer to discard changes"))
((not (vc-latest-on-branch-p (buffer-file-name)))
(error "This is not the latest version--VC cannot cancel it")))
(let* ((target (vc-workfile-version (buffer-file-name)))
(recent (if (vc-trunk-p target) "" (vc-branch-part target)))
(config (current-window-configuration)) done)
(if (null (yes-or-no-p (format "Remove version %s from master? " target)))
nil
(setq norevert (or norevert (not
(yes-or-no-p "Revert buffer to most recent remaining version? "))))
(vc-backend-uncheck (buffer-file-name) target)
(while (not done)
(condition-case err
(progn
(if norevert
(vc-backend-checkout (buffer-file-name) t recent)
(vc-checkout (buffer-file-name) nil recent))
(setq done t))
(error (set-buffer "*vc*")
(goto-char (point-min))
(if (search-forward "no side branches present for" nil t)
(progn (setq recent (vc-branch-part recent))
(set-window-configuration config))
(signal (car err) (cdr err))))))
(if norevert
(progn
(set-visited-file-name (buffer-file-name))
(if (not vc-make-backup-files)
(progn (make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(if (eq (vc-backend (buffer-file-name)) 'RCS)
(progn (setq buffer-read-only nil)
(vc-clear-headers)))
(vc-mode-line (buffer-file-name))))
(message "Version %s has been removed from the master" target)
)))
(defun vc-rename-file (old new)
"Rename file OLD to NEW, and rename its master file likewise."
(interactive "fVC rename file: \nFRename to: ")
(if (eq (vc-backend old) 'CVS)
(error "Renaming files under CVS is dangerous and not supported in VC"))
(let ((oldbuf (get-file-buffer old)))
(if (and oldbuf (buffer-modified-p oldbuf))
(error "Please save files before moving them"))
(if (get-file-buffer new)
(error "Already editing new file name"))
(if (file-exists-p new)
(error "New file already exists"))
(let ((oldmaster (vc-name old)) newmaster)
(if oldmaster
(progn
(if (vc-locking-user old)
(error "Please check in files before moving them"))
(if (or (file-symlink-p oldmaster)
(file-symlink-p (vc-backend-subdirectory-name old)))
(error "This is not a safe thing to do in the presence of symbolic links"))
(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"))))
(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)))
(if oldbuf
(save-excursion
(set-buffer oldbuf)
(let ((buffer-read-only buffer-read-only))
(set-visited-file-name new))
(vc-backend new)
(vc-mode-line new)
(set-buffer-modified-p nil))))
(vc-backend-dispatch old
(vc-record-rename old new) nil nil )
)
(defun vc-update-change-log (&rest args)
"Find change log file and add entries from recent RCS/CVS logs.
Normally, find log entries for all registered files in the default
directory using `rcs2log', which finds CVS logs preferentially.
The mark is left at the end of the text prepended to the change log.
With prefix arg of C-u, only find log entries for the current buffer's file.
With any numeric prefix arg, find log entries for all currently visited
files that are under version control. This puts all the entries in the
log for the default directory, which may not be appropriate.
From a program, any arguments are assumed to be filenames and are
passed to the `rcs2log' script after massaging to be relative to the
default directory."
(interactive
(cond ((consp current-prefix-arg) (list buffer-file-name))
(current-prefix-arg (let ((files nil)
(buffers (buffer-list))
file)
(while buffers
(setq file (buffer-file-name (car buffers)))
(and file (vc-backend file)
(setq files (cons file files)))
(setq buffers (cdr buffers)))
files))
(t
nil)))
(let ((odefault default-directory)
(changelog (find-change-log))
(tempfile (make-temp-name
(expand-file-name "vc"
temporary-file-directory)))
(full-name (or add-log-full-name
(user-full-name)
(user-login-name)
(format "uid%d" (number-to-string (user-uid)))))
(mailing-address (or add-log-mailing-address
user-mail-address)))
(find-file-other-window changelog)
(barf-if-buffer-read-only)
(vc-buffer-sync)
(undo-boundary)
(goto-char (point-min))
(push-mark)
(message "Computing change log entries...")
(message "Computing change log entries... %s"
(unwind-protect
(progn
(cd odefault)
(if (eq 0 (apply 'call-process
(expand-file-name "rcs2log" exec-directory)
nil
(list t tempfile) nil
"-c" changelog
"-u" (concat (vc-user-login-name)
"\t" full-name
"\t" mailing-address)
(mapcar
(function
(lambda (f)
(file-relative-name
(if (file-name-absolute-p f)
f
(concat odefault f)))))
args)))
"done"
(pop-to-buffer
(set-buffer (get-buffer-create "*vc*")))
(erase-buffer)
(insert-file tempfile)
"failed"))
(cd (file-name-directory changelog))
(delete-file tempfile)))))
(defvar vc-annotate-mode-map nil
"Local keymap used for VC-Annotate mode.")
(defvar vc-annotate-mode-menu nil
"Local keymap used for VC-Annotate mode's menu bar menu.")
(defvar vc-annotate-mode-syntax-table nil
"Syntax table used in VC-Annotate mode buffers.")
(defvar vc-annotate-ratio nil)
(defun vc-annotate-mode-variables ()
(if (not vc-annotate-mode-syntax-table)
(progn (setq vc-annotate-mode-syntax-table (make-syntax-table))
(set-syntax-table vc-annotate-mode-syntax-table)))
(if (not vc-annotate-mode-map)
(setq vc-annotate-mode-map (make-sparse-keymap)))
(setq vc-annotate-mode-menu (make-sparse-keymap "Annotate"))
(define-key vc-annotate-mode-map [menu-bar]
(make-sparse-keymap "VC-Annotate"))
(define-key vc-annotate-mode-map [menu-bar vc-annotate-mode]
(cons "VC-Annotate" vc-annotate-mode-menu)))
(defun vc-annotate-mode ()
"Major mode for buffers displaying output from the CVS `annotate' command.
You can use the mode-specific menu to alter the time-span of the used
colors. See variable `vc-annotate-menu-elements' for customizing the
menu items."
(interactive)
(kill-all-local-variables) (vc-annotate-mode-variables) (use-local-map vc-annotate-mode-map) (set-syntax-table vc-annotate-mode-syntax-table)
(setq major-mode 'vc-annotate-mode) (setq mode-name "Annotate") (run-hooks 'vc-annotate-mode-hook)
(vc-annotate-add-menu))
(defun vc-annotate-display-default (&optional event)
"Use the default color spectrum for VC Annotate mode."
(interactive)
(message "Redisplaying annotation...")
(vc-annotate-display (get-buffer (buffer-name)))
(message "Redisplaying annotation...done"))
(defun vc-annotate-add-menu ()
"Adds the menu 'Annotate' to the menu bar in VC-Annotate mode."
(define-key vc-annotate-mode-menu [default]
'("Default" . vc-annotate-display-default))
(let ((menu-elements vc-annotate-menu-elements))
(while menu-elements
(let* ((element (car menu-elements))
(days (round (* element
(vc-annotate-car-last-cons vc-annotate-color-map)
0.7585))))
(setq menu-elements (cdr menu-elements))
(define-key vc-annotate-mode-menu
(vector days)
(cons (format "Span %d days"
days)
`(lambda ()
,(format "Use colors spanning %d days" days)
(interactive)
(message "Redisplaying annotation...")
(vc-annotate-display
(get-buffer (buffer-name))
(vc-annotate-time-span vc-annotate-color-map ,element))
(message "Redisplaying annotation...done"))))))))
(defun vc-annotate (ratio)
"Display the result of the CVS `annotate' command using colors.
New lines are displayed in red, old in blue.
A prefix argument specifies a factor for stretching the time scale.
`vc-annotate-menu-elements' customizes the menu elements of the
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")
(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)
(vc-annotate-ratio ratio))
(with-output-to-temp-buffer temp-buffer-name
(call-process "cvs" nil (get-buffer temp-buffer-name) nil
"annotate" (file-name-nondirectory (buffer-file-name)))))
(message "Annotating... done"))
(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))))
(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."
(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) (1)) 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))
(defun vc-annotate-display (buffer &optional color-map)
"Do the VC-Annotate display in BUFFER using COLOR-MAP."
(if (and (not color-map) vc-annotate-ratio)
(setq color-map (vc-annotate-time-span vc-annotate-color-map
vc-annotate-ratio)))
(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))))
(set-buffer buffer)
(display-buffer buffer)
(or (eq major-mode 'vc-annotate-mode) (vc-annotate-mode))
(mapcar
(lambda (overlay)
(if (overlay-get overlay 'vc-annotation)
(delete-overlay overlay)))
(overlays-in (point-min) (point-max)))
(goto-char (point-min)) (while (re-search-forward
"^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): "
nil t)
(let* ( (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 (+ (cond ((> 69 year-tmp) 2000)
((> 100 year-tmp) 1900)
(t 0))
year-tmp))
(high (- (car (current-time))
(car (encode-time 0 0 0 day month year))))
(color (cond ((vc-annotate-compcar high (cond (color-map)
(vc-annotate-color-map))))
((cons nil vc-annotate-very-old-color))))
(face-name (concat "vc-annotate-face-" (substring (cdr color) 1)))
(face (cond ((intern-soft face-name))
((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)))) (point (point))
overlay)
(forward-line 1)
(setq overlay (make-overlay point (point)))
(overlay-put overlay 'face face)
(overlay-put overlay 'vc-annotation t)))))
(defun vc-backend-admin (file &optional rev comment)
(vc-file-clearprops file)
(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))
(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)
(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 (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)))
((eq backend 'RCS)
(apply 'vc-do-command nil 0 "ci" file 'WORKFILE (and (vc-backend-release-p 'RCS "5.6.4") "-i")
(concat (if vc-keep-workfiles "-u" "-r") rev)
(and comment (concat "-t-" comment))
switches))
((eq backend 'CVS)
(apply 'vc-do-command nil 0 "cvs" file 'WORKFILE "add"
(and comment (string-match "[^\t\n ]" comment)
(concat "-m" comment))
switches)
)))
(message "Registering %s...done" file)
)
(defun vc-backend-checkout (file &optional writable rev workfile)
(let ((filename (or workfile file))
(file-buffer (get-file-buffer file))
switches)
(message "Checking out %s..." filename)
(save-excursion
(if file-buffer (set-buffer file-buffer))
(setq switches (if (stringp vc-checkout-switches)
(list vc-checkout-switches)
vc-checkout-switches))
(let ((default-directory default-directory))
(save-excursion
(setq default-directory (file-name-directory filename))
(vc-backend-dispatch file
(progn (and rev (string= rev "") (setq rev nil))
(if workfile
(let ((vc-modes (logior (file-modes (vc-name file))
(if writable 128 0)))
(failed t))
(unwind-protect
(progn
(let ((coding-system-for-read 'no-conversion)
(coding-system-for-write 'no-conversion))
(with-temp-file filename
(apply 'vc-do-command
(current-buffer) 0 "get" file 'MASTER
"-s" (if writable "-e")
"-p"
(and rev
(concat "-r"
(vc-lookup-triple file rev)))
switches)))
(set-file-modes filename
(logior (file-modes (vc-name file))
(if writable 128 0)))
(setq failed nil))
(and failed (file-exists-p filename)
(delete-file filename))))
(apply 'vc-do-command nil 0 "get" file 'MASTER (if writable "-e")
(and rev (concat "-r" (vc-lookup-triple file rev)))
switches)
(vc-file-setprop file 'vc-workfile-version nil)))
(if workfile (let ((vc-modes (logior (file-modes (vc-name file))
(if writable 128 0)))
(failed t))
(unwind-protect
(progn
(let ((coding-system-for-read 'no-conversion)
(coding-system-for-write 'no-conversion))
(with-temp-file filename
(apply 'vc-do-command
(current-buffer) 0 "co" file 'MASTER
"-q" (if writable "-l")
(concat "-p" rev)
switches)))
(set-file-modes filename
(logior (file-modes (vc-name file))
(if writable 128 0)))
(setq failed nil))
(and failed (file-exists-p filename) (delete-file filename))))
(let (new-version)
(and rev (string= rev "")
(vc-do-command nil 0 "rcs" file 'MASTER "-b"))
(apply 'vc-do-command
nil 0 "co" file 'MASTER
(if (eq (vc-checkout-model file) 'implicit) "-f")
(if writable "-l")
(if rev (concat "-r" rev)
(let ((workrev (vc-workfile-version file)))
(if workrev (concat "-r" workrev)
nil)))
switches)
(save-excursion
(set-buffer "*vc*")
(goto-char (point-min))
(setq new-version
(if (re-search-forward "^revision \\([0-9.]+\\).*\n" nil t)
(buffer-substring (match-beginning 1) (match-end 1)))))
(vc-file-setprop file 'vc-workfile-version new-version)
(and rev (not (string= rev ""))
(vc-do-command nil 0 "rcs" file 'MASTER
(concat "-b" (if (vc-latest-on-branch-p file)
(if (vc-trunk-p new-version) nil
(vc-branch-part new-version))
new-version))))))
(if workfile (let ((failed t))
(unwind-protect
(progn
(let ((coding-system-for-read 'no-conversion)
(coding-system-for-write 'no-conversion))
(with-temp-file filename
(apply 'vc-do-command
(current-buffer) 0 "cvs" file 'WORKFILE
"-Q" "update"
(concat "-r" rev)
"-p"
switches)))
(setq failed nil))
(and failed (file-exists-p filename) (delete-file filename))))
(and rev (string= rev "")
(vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A"))
(if rev
(apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
(and writable (eq (vc-checkout-model file) 'manual) "-w")
"update"
(and rev (not (string= rev ""))
(concat "-r" rev))
switches)
(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)
(if writable
(vc-file-setprop file 'vc-locking-user (vc-user-login-name)))
(vc-file-setprop file
'vc-checkout-time (nth 5 (file-attributes file)))))
(message "Checking out %s...done" filename))))))
(defun vc-backend-logentry-check (file)
(vc-backend-dispatch file
(if (>= (buffer-size) 512) (progn
(goto-char 512)
(error
"Log must be less than 512 characters; point is now at pos 512")))
nil nil) )
(defun vc-backend-checkin (file rev comment)
(message "Checking in %s..." file)
(or (and comment (string-match "[^\t\n ]" comment))
(setq comment "*** empty log message ***"))
(save-excursion
(set-buffer (or (get-file-buffer file) (current-buffer)))
(let ((switches
(if (stringp vc-checkin-switches)
(list vc-checkin-switches)
vc-checkin-switches)))
(vc-file-clear-masterprops file)
(vc-backend-dispatch file
(progn
(apply 'vc-do-command nil 0 "delta" file 'MASTER
(if rev (concat "-r" rev))
(concat "-y" comment)
switches)
(vc-file-setprop file 'vc-locking-user 'none)
(vc-file-setprop file 'vc-workfile-version nil)
(if vc-keep-workfiles
(vc-do-command nil 0 "get" file 'MASTER))
)
(let ((old-version (vc-workfile-version file)) new-version)
(apply 'vc-do-command nil 0 "ci" file 'MASTER
(and (vc-backend-release-p 'RCS "5.6.4") "-j")
(concat (if vc-keep-workfiles "-u" "-r") rev)
(concat "-m" comment)
switches)
(vc-file-setprop file 'vc-locking-user 'none)
(vc-file-setprop file 'vc-workfile-version nil)
(set-buffer "*vc*")
(goto-char (point-min))
(if (or (re-search-forward
"new revision: \\([0-9.]+\\);" nil t)
(re-search-forward
"reverting to previous revision \\([0-9.]+\\)" nil t))
(progn (setq new-version (buffer-substring (match-beginning 1)
(match-end 1)))
(vc-file-setprop file 'vc-workfile-version new-version)))
(cond
((and old-version new-version
(not (string= (vc-branch-part old-version)
(vc-branch-part new-version))))
(vc-do-command nil 0 "rcs" file 'MASTER
(if (vc-trunk-p new-version) "-b"
(concat "-b" (vc-branch-part new-version))))
(if (not (vc-backend-release-p 'RCS "5.6.2"))
(vc-do-command nil 1 "rcs" file 'MASTER
(concat "-u" old-version))))))
(progn
(condition-case nil
(progn
(if (and rev (vc-trunk-p rev))
(apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
"ci" "-m" "intermediate"
switches))
(apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
"ci" (if rev (concat "-r" rev))
(concat "-m" comment)
switches))
(error (if (eq (vc-cvs-status file) 'needs-merge)
(error "Type C-x 0 C-x C-q to merge in changes")
(error "Check-in failed"))))
(set-buffer "*vc*")
(goto-char (point-min))
(if (re-search-forward
"^\\(new\\|initial\\) revision: \\([0-9.]+\\)" nil t)
(vc-file-setprop file 'vc-workfile-version
(buffer-substring (match-beginning 2)
(match-end 2)))
(vc-file-setprop file 'vc-workfile-version nil))
(if rev
(vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A"))
(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)
(message "Reverting %s..." file)
(vc-file-clear-masterprops file)
(vc-backend-dispatch
file
(progn
(vc-do-command nil 0 "unget" file 'MASTER nil)
(vc-do-command nil 0 "get" file 'MASTER nil)
(vc-file-setprop file 'vc-workfile-version nil))
(vc-do-command nil 0 "co" file 'MASTER
"-f" (concat "-u" (vc-workfile-version file)))
(progn
(vc-backend-checkout file nil (vc-workfile-version file) file)
(if (eq (vc-checkout-model file) 'manual)
(vc-do-command nil 0 "cvs" file 'WORKFILE "unedit"))))
(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)
)
(defun vc-backend-steal (file &optional rev)
(message "Stealing lock on %s..." file)
(vc-backend-dispatch file
(progn (vc-do-command nil 0 "unget" file 'MASTER "-n" (if rev (concat "-r" rev)))
(vc-do-command nil 0 "get" file 'MASTER "-g" (if rev (concat "-r" rev)))
)
(vc-do-command nil 0 "rcs" file 'MASTER "-M" (concat "-u" rev) (concat "-l" rev))
(error "You cannot steal a CVS lock; there are no CVS locks to steal") )
(vc-file-setprop file 'vc-locking-user (vc-user-login-name))
(message "Stealing lock on %s...done" file)
)
(defun vc-backend-uncheck (file target)
(message "Removing last change from %s..." file)
(vc-backend-dispatch file
(vc-do-command nil 0 "rmdel" file 'MASTER (concat "-r" target))
(vc-do-command nil 0 "rcs" file 'MASTER (concat "-o" target))
nil )
(message "Removing last change from %s...done" file)
)
(defun vc-backend-print-log (file)
(vc-backend-dispatch
file
(vc-do-command nil 0 "prs" file 'MASTER)
(vc-do-command nil 0 "rlog" file 'MASTER)
(vc-do-command nil 0 "cvs" file 'WORKFILE "log")))
(defun vc-backend-assign-name (file name)
(vc-backend-dispatch file
(vc-add-triple name file (vc-latest-version file)) (vc-do-command nil 0 "rcs" file 'MASTER (concat "-n" name ":")) (vc-do-command nil 0 "cvs" file 'WORKFILE "tag" name) )
)
(defun vc-backend-diff (file &optional oldvers newvers cmp)
(let ((backend (vc-backend file)) options status
(diff-switches-list (if (listp diff-switches)
diff-switches
(list diff-switches))))
(cond
((eq backend 'SCCS)
(setq oldvers (vc-lookup-triple file oldvers))
(setq newvers (vc-lookup-triple file newvers))
(setq options (append (list (and cmp "--brief") "-q"
(and oldvers (concat "-r" oldvers))
(and newvers (concat "-r" newvers)))
(and (not cmp) diff-switches-list)))
(apply 'vc-do-command "*vc-diff*" 1 "vcdiff" file 'MASTER options))
((eq backend 'RCS)
(if (not oldvers) (setq oldvers (vc-workfile-version file)))
(setq cmp (and cmp (not (eq vc-rcsdiff-knows-brief 'no))))
(setq options (append (list (and cmp "--brief") "-q"
(concat "-r" oldvers)
(and newvers (concat "-r" newvers)))
(and (not cmp) diff-switches-list)))
(setq status (apply 'vc-do-command "*vc-diff*" 2
"rcsdiff" file 'WORKFILE options))
(if (eq status 2)
(prog1
(apply 'vc-do-command "*vc-diff*" 1 "rcsdiff" file 'WORKFILE
(if cmp (cdr options) options))
(if cmp (setq vc-rcsdiff-knows-brief 'no)))
(and cmp (not vc-rcsdiff-knows-brief)
(setq vc-rcsdiff-knows-brief 'yes))
status))
((eq backend 'CVS)
(if (string= (vc-workfile-version file) "0")
(if (or oldvers newvers)
(error "No revisions of %s exist" file)
(if cmp 1 (apply 'vc-do-command
"*vc-diff*" 1 "diff" file 'WORKFILE
(append diff-switches-list '("/dev/null")))))
(apply 'vc-do-command
"*vc-diff*" 1 "cvs" file 'WORKFILE "diff"
(and oldvers (concat "-r" oldvers))
(and newvers (concat "-r" newvers))
diff-switches-list))))))
(defun vc-backend-merge-news (file)
(message "Merging changes into %s..." file)
(prog1
(vc-backend-dispatch
file
(error "vc-backend-merge-news not meaningful for SCCS files") (error "vc-backend-merge-news not meaningful for RCS files") (save-excursion (vc-file-clear-masterprops file)
(vc-file-setprop file 'vc-workfile-version nil)
(vc-file-setprop file 'vc-locking-user nil)
(vc-file-setprop file 'vc-checkout-time nil)
(vc-do-command nil 0 "cvs" file 'WORKFILE "update")
(set-buffer (get-buffer "*vc*"))
(goto-char (point-min))
(if (re-search-forward (concat "^Merging differences between "
"[01234567890.]* and "
"\\([01234567890.]*\\) into")
nil t)
(vc-file-setprop file 'vc-workfile-version (match-string 1)))
(if (re-search-forward
(concat "^\\(\\([CMUP]\\) \\)?"
(regexp-quote (file-name-nondirectory file))
"\\( already contains the differences between \\)?")
nil t)
(cond
((or (string= (match-string 2) "U")
(string= (match-string 2) "P")
(match-string 3))
(vc-file-setprop file 'vc-locking-user 'none)
(vc-file-setprop file 'vc-checkout-time
(nth 5 (file-attributes file)))
0) ((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) ((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) )
(pop-to-buffer "*vc*")
(error "Couldn't analyze cvs update result"))))
(message "Merging changes into %s...done" file)))
(defun vc-backend-merge (file first-version &optional second-version)
(vc-backend-dispatch file
(error "Sorry, merging is not implemented for SCCS")
(vc-do-command nil 1 "rcsmerge" file 'MASTER
"-kk" (concat "-r" first-version)
(if second-version (concat "-r" second-version)))
(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 0 )))))
(defun vc-check-headers ()
"Check if the current file has any headers in it."
(interactive)
(save-excursion
(goto-char (point-min))
(vc-backend-dispatch buffer-file-name
(re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" nil t) (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t) 'RCS )
))
(defun vc-log-mode (&optional file)
"Minor mode for driving version-control tools.
These bindings are added to the global keymap when you enter this mode:
\\[vc-next-action] perform next logical version-control operation on current file
\\[vc-register] register current file
\\[vc-toggle-read-only] like next-action, but won't register files
\\[vc-insert-headers] insert version-control headers in current file
\\[vc-print-log] display change history of current file
\\[vc-revert-buffer] revert buffer to latest version
\\[vc-cancel-version] undo latest checkin
\\[vc-diff] show diffs between file versions
\\[vc-version-other-window] visit old version in another window
\\[vc-directory] show all files locked by any user in or below .
\\[vc-annotate] colorful display of the cvs annotate command
\\[vc-update-change-log] add change log entry from recent checkins
While you are entering a change log message for a version, the following
additional bindings will be in effect.
\\[vc-finish-logentry] proceed with check in, ending log message entry
Whenever you do a checkin, your log comment is added to a ring of
saved comments. These can be recalled as follows:
\\[vc-next-comment] replace region with next message in comment ring
\\[vc-previous-comment] replace region with previous message in comment ring
\\[vc-comment-search-reverse] search backward for regexp in the comment ring
\\[vc-comment-search-forward] search backward for regexp in the comment ring
Entry to the change-log submode calls the value of text-mode-hook, then
the value of vc-log-mode-hook.
Global user options:
vc-initial-comment If non-nil, require user to enter a change
comment upon first checkin of the file.
vc-keep-workfiles Non-nil value prevents workfiles from being
deleted when changes are checked in
vc-suppress-confirm Suppresses some confirmation prompts,
notably for reversions.
vc-header-alist Which keywords to insert when adding headers
with \\[vc-insert-headers]. Defaults to
'(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under
RCS and CVS.
vc-static-header-alist By default, version headers inserted in C files
get stuffed in a static string area so that
ident(RCS/CVS) or what(SCCS) can see them in
the compiled object code. You can override
this by setting this variable to nil, or change
the header template by changing it.
vc-command-messages if non-nil, display run messages from the
actual version-control utilities (this is
intended primarily for people hacking vc
itself).
"
(interactive)
(set-syntax-table text-mode-syntax-table)
(use-local-map vc-log-entry-mode)
(setq local-abbrev-table text-mode-abbrev-table)
(setq major-mode 'vc-log-mode)
(setq mode-name "VC-Log")
(make-local-variable 'vc-log-file)
(setq vc-log-file file)
(make-local-variable 'vc-log-version)
(make-local-variable 'vc-comment-ring-index)
(set-buffer-modified-p nil)
(setq buffer-file-name nil)
(run-hooks 'text-mode-hook 'vc-log-mode-hook)
)
(if vc-log-entry-mode
nil
(setq vc-log-entry-mode (make-sparse-keymap))
(define-key vc-log-entry-mode "\M-n" 'vc-next-comment)
(define-key vc-log-entry-mode "\M-p" 'vc-previous-comment)
(define-key vc-log-entry-mode "\M-r" 'vc-comment-search-reverse)
(define-key vc-log-entry-mode "\M-s" 'vc-comment-search-forward)
(define-key vc-log-entry-mode "\C-c\C-c" 'vc-finish-logentry)
)
(defun vc-file-tree-walk (dirname func &rest args)
"Walk recursively through DIRNAME.
Invoke FUNC f ARGS on each non-directory file f underneath it."
(vc-file-tree-walk-internal (expand-file-name dirname) func args)
(message "Traversing directory %s...done" dirname))
(defun vc-file-tree-walk-internal (file func args)
(if (not (file-directory-p file))
(apply func file args)
(message "Traversing directory %s..." (abbreviate-file-name file))
(let ((dir (file-name-as-directory file)))
(mapcar
(function
(lambda (f) (or
(string-equal f ".")
(string-equal f "..")
(member f vc-directory-exclusion-list)
(let ((dirf (concat dir f)))
(or
(file-symlink-p dirf) (vc-file-tree-walk-internal dirf func args))))))
(directory-files dir)))))
(provide 'vc)