;;; vc.el --- drive a version-control system from within Emacs
-;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
-;; Version: 5.4
+;; Maintainer: eggert@twinsun.com
+;; Version: 5.5
;; This file is part of GNU Emacs.
;; and Richard Stallman contributed valuable criticism, support, and testing.
;;
;; Supported version-control systems presently include SCCS and RCS;
-;; your RCS version should be 5.6.2 or later for proper operation of
-;; the lock-breaking code.
+;; the RCS lock-stealing code doesn't work right unless you use RCS 5.6.2
+;; or newer. Currently (January 1994) that is only a beta test release.
;;
;; The RCS code assumes strict locking. You can support the RCS -x option
;; by adding pairs to the vc-master-templates list.
"*Don't assume that permissions and ownership track version-control status.")
(defvar vc-checkin-switches nil
"*Extra switches passed to the checkin program by \\[vc-checkin].")
+(defvar vc-path
+ (if (file-exists-p "/usr/sccs")
+ '("/usr/sccs") nil)
+ "*List of extra directories to search for version control commands.")
(defconst vc-maximum-comment-ring-size 32
"Maximum number of saved comments in the comment ring.")
(defvar vc-header-alist
'((SCCS "\%W\%") (RCS "\$Id\$"))
"*Header keywords to be inserted when `vc-insert-headers' is executed.")
-(defconst vc-static-header-alist
+(defvar 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
and comment-end variables. This will only be necessary if the mode language
is sensitive to blank lines.")
+;; Default is to be extra careful for super-user.
+(defvar 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.")
+
;; Variables the user doesn't need to know about.
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
;; Random helper functions
-(defun vc-name (file)
- "Return the master name of a file, nil if it is not registered."
- (or (vc-file-getprop file 'vc-name)
- (vc-file-setprop file 'vc-name
- (let ((name-and-type (vc-registered file)))
- (and name-and-type (car name-and-type))))))
-
(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))))
+ (error "File %s is not under version control" file)
+ (error "Buffer %s is not associated with a file" (buffer-name))))
(defvar vc-binary-assoc nil)
(defun vc-find-binary (name)
"Look for a command anywhere on the subprocess-command search path."
(or (cdr (assoc name vc-binary-assoc))
- (let ((full nil))
- (catch 'found
- (mapcar
- (function (lambda (s)
- (if (and s (file-exists-p (setq full (concat s "/" name))))
- (throw 'found nil))))
- exec-path))
- (if full
- (setq vc-binary-assoc (cons (cons name full) vc-binary-assoc)))
- full)))
+ (catch 'found
+ (mapcar
+ (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)))))))
+ exec-path)
+ nil)))
(defun vc-do-command (okstatus command file &rest flags)
"Execute a version-control command, notifying user and checking for errors.
flags)
(if vc-file
(setq squeezed (append squeezed (list vc-file))))
- (let ((default-directory (file-name-directory (or file "./"))))
+ (let ((default-directory (file-name-directory (or file "./")))
+ (exec-path (if vc-path (append exec-path vc-path) exec-path)))
(setq status (apply 'call-process command nil t nil squeezed)))
(goto-char (point-max))
- (previous-line 1)
+ (forward-line -1)
(if (or (not (integerp status)) (< okstatus status))
(progn
- (previous-line 1)
- (print (cons command squeezed))
- (next-line 1)
(pop-to-buffer "*vc*")
- (vc-shrink-to-fit)
(goto-char (point-min))
+ (shrink-window-if-larger-than-buffer)
(error "Running %s...FAILED (%s)" command
(if (integerp status)
(format "status %d" status)
(if new-mark (set-mark new-mark))))))
-(defun vc-buffer-sync ()
+(defun vc-buffer-sync (&optional not-urgent)
;; Make sure the current buffer and its working file are in sync
- (if (and (buffer-modified-p)
- (or
- vc-suppress-confirm
- (y-or-n-p (format "%s has been modified. Write it out? "
- (buffer-name)))))
- (save-buffer)))
-
-(defun vc-workfile-unchanged-p (file)
+ ;; NOT-URGENT means it is ok to continue if the user says not to save.
+ (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)
;; Has the given workfile changed since last checkout?
(let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
(lastmod (nth 5 (file-attributes file))))
- (if checkout-time
- (equal lastmod checkout-time)
- (if (zerop (vc-backend-diff file nil))
- (progn
- (vc-file-setprop file 'vc-checkout-time lastmod)
- t)
- (progn
- (vc-file-setprop file 'vc-checkout-time '(0 . 0))
- nil
- ))
- )))
+ (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)))))
+ ;; 0 stands for an unknown time; it can't match any mod time.
+ (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
+ unchanged)))))
(defun vc-next-action-on-file (file verbose &optional comment)
;;; If comment is specified, it will be used as an admin or checkin comment.
;; if there is no lock on the file, assert one and get it
((not (setq owner (vc-locking-user file)))
- (vc-checkout-writable-buffer file))
+ (if (and vc-checkout-carefully
+ (not (vc-workfile-unchanged-p file t)))
+ (if (save-window-excursion
+ (pop-to-buffer "*vc*")
+ (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))
+ )
+ (vc-checkout-writable-buffer file)))
;; a checked-out version exists, but the user may not own the lock
((not (string-equal owner (user-login-name)))
(if comment
- (error "Sorry, you can't steal the lock on %s this way." file))
+ (error "Sorry, you can't steal the lock on %s this way" file))
(vc-steal-lock
file
(and verbose (read-string "Version to steal: "))
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."
+lock steals will raise an error.
+
+ For checkin, a prefix argument lets you specify the version number to use."
(interactive "P")
(catch 'nogo
(if vc-dired-mode
(vc-start-entry nil nil nil
"Enter a change comment for the marked files."
'vc-next-action-dired)
- (throw 'nogo))))
+ (throw 'nogo nil))))
(while vc-parent-buffer
(pop-to-buffer vc-parent-buffer))
(if buffer-file-name
"Register the current file into your version-control system."
(interactive "P")
(if (vc-name buffer-file-name)
- (error "This file is already registered."))
+ (error "This file is already registered"))
;; Watch out for new buffers of size 0: the corresponding file
;; does not exist yet, even though buffer-modified-p is nil.
(if (and (not (buffer-modified-p))
(set (make-local-variable 'vc-parent-buffer) parent)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name vc-parent-buffer)))
- (vc-mode-line (if file (file-name-nondirectory file) " (no file)"))
+ (vc-mode-line (or file " (no file)"))
(vc-log-mode)
(setq vc-log-operation action)
(setq vc-log-file file)
(if (not owner)
(setq owner (vc-locking-user file)))
(if (not (y-or-n-p (format "Take the lock on %s:%s from %s? " file rev owner)))
- (error "Steal cancelled."))
+ (error "Steal cancelled"))
(pop-to-buffer (get-buffer-create "*VC-mail*"))
(setq default-directory (expand-file-name "~/"))
(auto-save-mode auto-save-default)
COMMENT is a comment string; if omitted, a buffer is
popped up to accept a comment."
(setq vc-log-after-operation-hook 'vc-checkin-hook)
- (vc-start-entry file rev comment "Enter a change comment." 'vc-backend-checkin))
+ (vc-start-entry file rev comment
+ "Enter a change comment." 'vc-backend-checkin))
;;; Here is a checkin hook that may prove useful to sites using the
;;; ChangeLog facility supported by Emacs.
-(defun vc-comment-to-change-log ()
- "Update change log from VC change comments entered for the current file.
-See `vc-update-change-log'."
- (interactive)
- (let ((log (find-change-log)))
- (if log
- (vc-update-change-log
- (file-relative-name buffer-file-name
- (file-name-directory (expand-file-name log)))))))
+(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'."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ ;; Make sure the defvar for add-log-current-defun-function has been executed
+ ;; before binding it.
+ (require 'add-log)
+ (let (;; Extract the comment first so we get any error before doing anything.
+ (comment (ring-ref vc-comment-ring 0))
+ ;; Don't let add-change-log-entry insert a defun name.
+ (add-log-current-defun-function 'ignore)
+ end)
+ ;; Call add-log to do half the work.
+ (add-change-log-entry whoami file-name t t)
+ ;; Insert the VC comment, leaving point before it.
+ (setq end (save-excursion (insert comment) (point-marker)))
+ (if (looking-at "\\s *\\s(")
+ ;; It starts with an open-paren, as in "(foo): Frobbed."
+ ;; So remove the ": " add-log inserted.
+ (delete-char -2))
+ ;; Canonicalize the white space between the file name and comment.
+ (just-one-space)
+ ;; Indent rest of the text the same way add-log indented the first line.
+ (let ((indentation (current-indentation)))
+ (save-excursion
+ (while (< (point) end)
+ (forward-line 1)
+ (indent-to indentation))
+ (setq end (point))))
+ ;; Fill the inserted text, preserving open-parens at bol.
+ (let ((paragraph-separate (concat paragraph-separate "\\|^\\s *\\s("))
+ (paragraph-start (concat paragraph-start "\\|^\\s *\\s(")))
+ (beginning-of-line)
+ (fill-region (point) end))
+ ;; Canonicalize the white space at the end of the entry so it is
+ ;; separated from the next entry by a single blank line.
+ (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."
(setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
(ring-insert vc-comment-ring (buffer-string))
))
+ ;; Sync parent buffer in case the user modified it while editing the comment.
+ (save-excursion
+ (set-buffer vc-parent-buffer)
+ (vc-buffer-sync))
;; OK, do it to it
(if vc-log-operation
(save-excursion
vc-log-file
vc-log-version
(buffer-string)))
- (error "No log operation is pending."))
+ (error "No log operation is pending"))
;; Return to "parent" buffer of this checkin and remove checkin window
(pop-to-buffer vc-parent-buffer)
- (vc-error-occurred
- (delete-window (get-buffer-window "*VC-log*")))
- (kill-buffer "*VC-log*")
+ (let ((logbuf (get-buffer "*VC-log*")))
+ (delete-windows-on logbuf)
+ (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 (> arg 0) -1
(if (< arg 0) 1 0))))
(setq vc-comment-ring-index
- (ring-mod (+ vc-comment-ring-index arg) len))
+ (mod (+ vc-comment-ring-index arg) len))
(message "%d" (1+ vc-comment-ring-index))
(insert (ring-ref vc-comment-ring vc-comment-ring-index))))))
;; Additional entry points for examining version histories
;;;###autoload
-(defun vc-diff (historic)
+(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.
(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."))
+ (error
+ "There is no version-control master associated with this buffer"))
(let ((file buffer-file-name)
unchanged)
(or (and file (vc-name file))
(vc-registration-error file))
- (vc-buffer-sync)
+ (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 nil)
+ (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.
;; visited. This plays hell with numerous assumptions in
;; the diff.el and compile.el machinery.
(pop-to-buffer "*vc*")
- (vc-shrink-to-fit)
- (goto-char (point-min))
- )
- (not unchanged)
- )
- )
- )
+ (pop-to-buffer "*vc*")
+ (if (= 0 (buffer-size))
+ (progn
+ (setq unchanged t)
+ (message "No changes to %s since latest version." file))
+ (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.
(message "No changes to %s between %s and %s." file rel1 rel2)
(pop-to-buffer "*vc*"))))
+;;;###autoload
+(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): ")
+ (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)))
+
;; Header-insertion code
;;;###autoload
(if nonempty
(progn
(pop-to-buffer "*vc-status*" t)
- (vc-shrink-to-fit)
- (goto-char (point-min)))
+ (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))
(save-excursion
(find-file (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file))
(goto-char (point-min))
- (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname))
+ ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname))
+ (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)
;; Return the numeric version corresponding to a named snapshot of file
;; If name is nil or a version number string it's just passed through
- (cond ((null name) "")
+ (cond ((null name) name)
((let ((firstchar (aref name 0)))
(and (>= firstchar ?0) (<= firstchar ?9)))
name)
;; Named-configuration entry points
-(defun vc-quiescent-p ()
- ;; Is the current directory ready to be snapshot?
- (catch 'quiet
+(defun vc-locked-example ()
+ ;; Return an example of why the current directory is not ready to be snapshot
+ ;; or nil if no such example exists.
+ (catch 'vc-locked-example
(vc-file-tree-walk
(function (lambda (f)
(if (and (vc-registered f) (vc-locking-user f))
- (throw 'quiet nil)))))
- t))
+ (throw 'vc-locked-example f)))))
+ nil))
;;;###autoload
(defun vc-create-snapshot (name)
directory. For each file, the version level of its latest
version becomes part of the named configuration."
(interactive "sNew snapshot name: ")
- (if (not (vc-quiescent-p))
- (error "Can't make a snapshot, locked files are in the way.")
- (vc-file-tree-walk
- (function (lambda (f) (and
- (vc-name f)
- (vc-backend-assign-name f name)))))
- ))
+ (let ((locked (vc-locked-example)))
+ (if locked
+ (error "File %s is locked" locked)
+ (vc-file-tree-walk
+ (function (lambda (f) (and
+ (vc-name f)
+ (vc-backend-assign-name f name)))))
+ )))
;;;###autoload
(defun vc-retrieve-snapshot (name)
Otherwise, all registered files are checked out (unlocked) at their version
levels in the snapshot."
(interactive "sSnapshot name to retrieve: ")
- (if (not (vc-quiescent-p))
- (error "Can't retrieve a snapshot, locked files are in the way.")
- (vc-file-tree-walk
- (function (lambda (f) (and
- (vc-name f)
- (vc-error-occurred (vc-backend-checkout f nil name))))))
- ))
+ (let ((locked (vc-locked-example)))
+ (if locked
+ (error "File %s is locked" locked)
+ (vc-file-tree-walk
+ (function (lambda (f) (and
+ (vc-name f)
+ (vc-error-occurred
+ (vc-backend-checkout f nil name))))))
+ )))
;; Miscellaneous other entry points
(progn
(vc-backend-print-log buffer-file-name)
(pop-to-buffer (get-buffer-create "*vc*"))
- (vc-shrink-to-fit)
+ (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)
)
(vc-registration-error buffer-file-name)
)
(while vc-parent-buffer
(pop-to-buffer vc-parent-buffer))
(let ((file buffer-file-name)
- (obuf (current-buffer)) (changed (vc-diff nil)))
+ (obuf (current-buffer)) (changed (vc-diff nil t)))
(if (and changed (or vc-suppress-confirm
(not (yes-or-no-p "Discard changes? "))))
(progn
(delete-window)
- (error "Revert cancelled."))
+ (error "Revert cancelled"))
(set-buffer obuf))
(if changed
(delete-window))
(let* ((target (concat (vc-latest-version (buffer-file-name))))
(yours (concat (vc-your-latest-version (buffer-file-name))))
(prompt (if (string-equal yours target)
- "Remove your version %s from master?"
- "Version %s was not your change. Remove it anyway?")))
+ "Remove your version %s from master? "
+ "Version %s was not your change. Remove it anyway? ")))
(if (null (yes-or-no-p (format prompt target)))
nil
(vc-backend-uncheck (buffer-file-name) target)
"Rename file OLD to NEW, and rename its master file likewise."
(interactive "fVC rename file: \nFRename to: ")
(let ((oldbuf (get-file-buffer old)))
- (if (buffer-modified-p oldbuf)
- (error "Please save files before moving them."))
+ (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."))
+ (error "Already editing new file name"))
+ (if (file-exists-p new)
+ (error "New file already exists"))
(let ((oldmaster (vc-name old)))
(if oldmaster
- (if (vc-locking-user old)
- (error "Please check in files before moving them."))
- (if (or (file-symlink-p oldmaster)
- ;; 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 (vc-name new)))
+ (progn
+ (if (vc-locking-user old)
+ (error "Please check in files before moving them"))
+ (if (or (file-symlink-p oldmaster)
+ ;; 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-deduce 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 (or (not oldmaster) (file-exists-p old))
(rename-file old new)))
; ?? Renaming a file might change its contents due to keyword expansion.
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 files currently visited.
+Otherwise, find log entries for all registered files in the default directory.
From a program, any arguments are passed to the `rcs2log' script."
(interactive
(cond ((consp current-prefix-arg) ;C-u
(while buffers
(setq file (buffer-file-name (car buffers)))
(and file (vc-backend-deduce file)
- (setq files (cons (file-relative-name file) files)))
+ (setq files (cons file files)))
(setq buffers (cdr buffers)))
- files))))
- (find-file-other-window (find-change-log))
- (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"
- (if (eq 0 (apply 'call-process "rcs2log" nil t nil args))
- "done" "failed")))
+ files))
+ (t
+ (let ((RCS (concat default-directory "RCS")))
+ (and (file-directory-p RCS)
+ (mapcar (function
+ (lambda (f)
+ (if (string-match "\\(.*\\),v$" f)
+ (substring f 0 (match-end 1))
+ f)))
+ (directory-files RCS nil "...\\|^[^.]\\|^.[^.]")))))))
+ (let ((odefault default-directory))
+ (find-file-other-window (find-change-log))
+ (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"
+ (if (or (null args)
+ (eq 0 (apply 'call-process "rcs2log" nil t nil
+ (mapcar (function
+ (lambda (f)
+ (file-relative-name
+ (if (file-name-absolute-p f)
+ f
+ (concat odefault f)))))
+ args))))
+ "done" "failed"))))
;; Functions for querying the master and lock files.
(vc-match-substring 1))))))
latest-val))
(prog1
- (and (re-search-forward p nil t)
- (let ((value (vc-match-substring 1)))
- (if file
- (vc-file-setprop file (car properties) value))
- value))
+ (let ((value nil))
+ (if (re-search-forward p nil t)
+ (setq value (vc-match-substring 1)))
+ (if file
+ (vc-file-setprop file (car properties) value))
+ value)
(setq properties (cdr properties)))))
patterns)
)
;; control and has -rw-r--r-- is locked by its owner. This is true
;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
;; We have to be careful not to exclude files with execute bits on;
- ;; scripts can be under version control too. The advantage of this
- ;; hack is that calls to the very expensive vc-fetch-properties
+ ;; scripts can be under version control too. Also, we must ignore
+ ;; the group-read and other-read bits, since paranoid users turn them off.
+ ;; This hack wins because calls to the very expensive vc-fetch-properties
;; function only have to be made if (a) the file is locked by someone
;; other than the current user, or (b) some untoward manipulation
;; behind vc's back has changed the owner or the `group' or `other'
;; write bits.
(let ((attributes (file-attributes file)))
- (cond ((string-match ".r-.r-.r-." (nth 8 attributes))
+ (cond ((string-match ".r-..-..-." (nth 8 attributes))
nil)
((and (= (nth 2 attributes) (user-uid))
- (string-match ".rw.r-.r-." (nth 8 attributes)))
+ (string-match ".rw..-..-." (nth 8 attributes)))
(user-login-name))
(t
(vc-true-locking-user file))))))
(message "Registering %s...done" file)
)
-(defun vc-backend-checkout (file &optional writable rev)
+(defun vc-backend-checkout (file &optional writable rev workfile)
;; Retrieve a copy of a saved version into a workfile
- (message "Checking out %s..." file)
- (vc-backend-dispatch file
- (progn
+ (let ((filename (or workfile file)))
+ (message "Checking out %s..." filename)
+ (vc-backend-dispatch file
(vc-do-command 0 "get" file ;; SCCS
(if writable "-e")
+ (if workfile (concat "-G" workfile))
(and rev (concat "-r" (vc-lookup-triple file rev))))
+ (if workfile ;; RCS
+ ;; RCS doesn't let us check out into arbitrary file names directly.
+ ;; Use `co -p' and make stdout point to the correct file.
+ (let ((vc-modes (logior (file-modes (vc-name file))
+ (if writable 128 0)))
+ (failed t))
+ (unwind-protect
+ (progn
+ (vc-do-command
+ 0 "/bin/sh" file "-c"
+ (format "umask %o; exec >\"$1\" || exit; shift; umask %o; exec co \"$@\""
+ (logand 511 (lognot vc-modes))
+ (logand 511 (lognot (default-file-modes))))
+ "" ; dummy argument for shell's $0
+ filename
+ (if writable "-l")
+ (concat "-p" rev))
+ (setq failed nil))
+ (and failed (file-exists-p filename) (delete-file filename))))
+ (vc-do-command 0 "co" file
+ (if writable "-l")
+ (and rev (concat "-r" rev))))
)
- (vc-do-command 0 "co" file ;; RCS
- (if writable "-l")
- (and rev (concat "-r" rev)))
- )
- (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file)))
- (message "Checking out %s...done" file)
+ (or workfile
+ (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))))
+ (message "Checking out %s...done" filename))
)
(defun vc-backend-logentry-check (file)
(progn
(goto-char 512)
(error
- "Log must be less than 512 characters. Point is now at char 512.")))
+ "Log must be less than 512 characters; point is now at pos 512")))
nil)
)
(progn ;; SCCS
(vc-do-command 0 "unget" file nil)
(vc-do-command 0 "get" file nil))
- (progn
- (delete-file file) ;; RCS
- (vc-do-command 0 "co" file "-u")))
+ (vc-do-command 0 "co" file "-f" "-u")) ;; RCS. This deletes the work file.
(vc-file-setprop file 'vc-locking-user nil)
(message "Reverting %s...done" file)
)
(defun vc-backend-steal (file &optional rev)
;; Steal the lock on the current workfile. Needs RCS 5.6.2 or later for -M.
(message "Stealing lock on %s..." file)
- (progn
- (vc-do-command 0 "unget" file "-n" (if rev (concat "-r" rev)))
- (vc-do-command 0 "get" file "-g" (if rev (concat "-r" rev)))
- )
- (progn
- (vc-do-command 0 "rcs" "-M" (concat "-u" rev) file)
- (delete-file file)
- (vc-do-command 0 "rcs" (concat "-l" rev) file)
- )
+ (vc-backend-dispatch file
+ (progn
+ (vc-do-command 0 "unget" file "-n" (if rev (concat "-r" rev)))
+ (vc-do-command 0 "get" file "-g" (if rev (concat "-r" rev)))
+ )
+ (vc-do-command 0 "rcs" file "-M" (concat "-u" rev) (concat "-l" rev)))
(vc-file-setprop file 'vc-locking-user (user-login-name))
(message "Stealing lock on %s...done" file)
)
)
)
-(defun vc-backend-diff (file oldvers &optional newvers)
- ;; Get a difference report between two versions
+(defun vc-backend-diff (file &optional oldvers newvers cmp)
+ ;; Get a difference report between two versions of FILE.
+ ;; Get only a brief comparison report if CMP, a difference report otherwise.
(if (eq (vc-backend-deduce file) 'SCCS)
(setq oldvers (vc-lookup-triple file oldvers))
(setq newvers (vc-lookup-triple file newvers)))
- (apply 'vc-do-command 1
- (or (vc-backend-dispatch file "vcdiff" "rcsdiff")
- (vc-registration-error file))
- file
- (and oldvers (concat "-r" oldvers))
- (and newvers (concat "-r" newvers))
- (if (listp diff-switches)
- diff-switches
- (list diff-switches))
- ))
+ (let* ((command (or (vc-backend-dispatch file "vcdiff" "rcsdiff")
+ (vc-registration-error file)))
+ (options (append (list (and cmp "--brief")
+ "-q"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers)))
+ (and (not cmp)
+ (if (listp diff-switches)
+ diff-switches
+ (list diff-switches)))))
+ (status (apply 'vc-do-command 2 command file options)))
+ ;; Some RCS versions don't understand "--brief"; work around this.
+ (if (eq status 2)
+ (apply 'vc-do-command 1 command file (if cmp (cdr options) options))
+ status)))
(defun vc-check-headers ()
"Check if the current file has any headers in it."
\\[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-update-change-log] add change log entry from recent checkins
;;; These things should probably be generally available
-(defun vc-shrink-to-fit ()
- "Shrink window vertically until it's just large enough to contain its text."
- (let ((minsize (1+ (count-lines (point-min) (point-max)))))
- (if (< minsize (window-height))
- (let ((window-min-height 2))
- (shrink-window (- (window-height) minsize))))))
-
(defun vc-file-tree-walk (func &rest args)
"Walk recursively through default directory.
Invoke FUNC f ARGS on each non-directory file f underneath it."
HCoop / bpt / emacs.git / blobdiff