1;;; vc-hooks.el --- resident support for version-control 2 3;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. 4 5;; Author: Eric S. Raymond <esr@snark.thyrsus.com> 6;; Version: 5.3 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to 22;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 24;;; Commentary: 25 26;; See the commentary of vc.el. 27 28;;; Code: 29 30(defvar vc-master-templates 31 '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS) 32 ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS)) 33 "*Where to look for version-control master files. 34The first pair corresponding to a given back end is used as a template 35when creating new masters.") 36 37(defvar vc-make-backup-files nil 38 "*If non-nil, backups of registered files are made as with other files. 39If nil (the default), files covered by version control don't get backups.") 40 41(defvar vc-rcs-status t 42 "*If non-nil, revision and locks on RCS working file displayed in modeline. 43Otherwise, not displayed.") 44 45;; Tell Emacs about this new kind of minor mode 46(if (not (assoc 'vc-mode minor-mode-alist)) 47 (setq minor-mode-alist (cons '(vc-mode vc-mode) 48 minor-mode-alist))) 49 50(make-variable-buffer-local 'vc-mode) 51(put 'vc-mode 'permanent-local t) 52 53;; We need a notion of per-file properties because the version 54;; control state of a file is expensive to derive --- we don't 55;; want to recompute it even on every find. 56 57(defmacro vc-error-occurred (&rest body) 58 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) 59 60(defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0] 61 "Obarray for per-file properties.") 62 63(defun vc-file-setprop (file property value) 64 ;; set per-file property 65 (put (intern file vc-file-prop-obarray) property value)) 66 67(defun vc-file-getprop (file property) 68 ;; get per-file property 69 (get (intern file vc-file-prop-obarray) property)) 70 71;;; actual version-control code starts here 72 73(defun vc-registered (file) 74 (let (handler handlers) 75 (if (boundp 'file-name-handler-alist) 76 (setq handler (find-file-name-handler file 'vc-registered))) 77 (if handler 78 (funcall handler 'vc-registered file) 79 ;; Search for a master corresponding to the given file 80 (let ((dirname (or (file-name-directory file) "")) 81 (basename (file-name-nondirectory file))) 82 (catch 'found 83 (mapcar 84 (function (lambda (s) 85 (let ((trial (format (car s) dirname basename))) 86 (if (and (file-exists-p trial) 87 ;; Make sure the file we found with name 88 ;; TRIAL is not the source file itself. 89 ;; That can happen with RCS-style names 90 ;; if the file name is truncated 91 ;; (e.g. to 14 chars). See if either 92 ;; directory or attributes differ. 93 (or (not (string= dirname 94 (file-name-directory trial))) 95 (not (equal 96 (file-attributes file) 97 (file-attributes trial))))) 98 (throw 'found (cons trial (cdr s))))))) 99 vc-master-templates) 100 nil))))) 101 102(defun vc-name (file) 103 "Return the master name of a file, nil if it is not registered." 104 (or (vc-file-getprop file 'vc-name) 105 (let ((name-and-type (vc-registered file))) 106 (if name-and-type 107 (progn 108 (vc-file-setprop file 'vc-backend (cdr name-and-type)) 109 (vc-file-setprop file 'vc-name (car name-and-type))))))) 110 111(defun vc-backend-deduce (file) 112 "Return the version-control type of a file, nil if it is not registered." 113 (and file 114 (or (vc-file-getprop file 'vc-backend) 115 (let ((name-and-type (vc-registered file))) 116 (if name-and-type 117 (progn 118 (vc-file-setprop file 'vc-name (car name-and-type)) 119 (vc-file-setprop file 'vc-backend (cdr name-and-type)))))))) 120 121(defun vc-toggle-read-only () 122 "Change read-only status of current buffer, perhaps via version control. 123If the buffer is visiting a file registered with version control, 124then check the file in or out. Otherwise, just change the read-only flag 125of the buffer." 126 (interactive) 127 (if (vc-backend-deduce (buffer-file-name)) 128 (vc-next-action nil) 129 (toggle-read-only))) 130(define-key global-map "\C-x\C-q" 'vc-toggle-read-only) 131 132(defun vc-mode-line (file &optional label) 133 "Set `vc-mode' to display type of version control for FILE. 134The value is set in the current buffer, which should be the buffer 135visiting FILE." 136 (interactive (list buffer-file-name nil)) 137 (if file 138 (let ((vc-type (vc-backend-deduce file))) 139 (setq vc-mode 140 (and vc-type 141 (concat " " (or label (symbol-name vc-type)) 142 (if (and vc-rcs-status (eq vc-type 'RCS)) 143 (vc-rcs-status file))))) 144 ;; Even root shouldn't modify a registered file without locking it first. 145 (and vc-type 146 (not buffer-read-only) 147 (zerop (user-uid)) 148 (require 'vc) 149 (not (string-equal (user-login-name) (vc-locking-user file))) 150 (setq buffer-read-only t)) 151 (and (null vc-type) 152 (file-symlink-p file) 153 (let ((link-type (vc-backend-deduce (file-symlink-p file)))) 154 (if link-type 155 (message "Warning: symbolic link to %s-controlled source file" 156 link-type)))) 157 (force-mode-line-update) 158 ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18 159 vc-type))) 160 161(defun vc-rcs-status (file) 162 ;; Return string for placement in modeline by `vc-mode-line'. 163 ;; If FILE is not registered under RCS, return nil. 164 ;; If FILE is registered but not locked, return " REV" if there is a head 165 ;; revision and " @@" otherwise. 166 ;; If FILE is locked then return all locks in a string of the 167 ;; form " LOCKER1:REV1 LOCKER2:REV2 ...", where "LOCKERi:" is empty if you 168 ;; are the locker, and otherwise is the name of the locker followed by ":". 169 170 ;; Algorithm: 171 172 ;; 1. Check for master file corresponding to FILE being visited. 173 ;; 174 ;; 2. Insert the first few characters of the master file into a work 175 ;; buffer. 176 ;; 177 ;; 3. Search work buffer for "locks...;" phrase; if not found, then 178 ;; keep inserting more characters until the phrase is found. 179 ;; 180 ;; 4. Extract the locks, and remove control characters 181 ;; separating them, like newlines; the string " user1:revision1 182 ;; user2:revision2 ..." is returned. 183 184 ;; Limitations: 185 186 ;; The output doesn't show which version you are actually looking at. 187 ;; The modeline can get quite cluttered when there are multiple locks. 188 ;; The head revision is probably not what you want if you've used `rcs -b'. 189 190 (let ((master (vc-name file)) 191 found) 192 193 ;; If master file exists, then parse its contents, otherwise we return the 194 ;; nil value of this if form. 195 (if master 196 (save-excursion 197 198 ;; Create work buffer. 199 (set-buffer (get-buffer-create " *vc-rcs-status*")) 200 (setq buffer-read-only nil 201 default-directory (file-name-directory master)) 202 (erase-buffer) 203 204 ;; Check if we have enough of the header. 205 ;; If not, then keep including more. 206 (while 207 (not (or found 208 (let ((s (buffer-size))) 209 (goto-char (1+ s)) 210 (zerop (car (cdr (insert-file-contents 211 master nil s (+ s 8192)))))))) 212 (beginning-of-line) 213 (setq found (re-search-forward "^locks\\([^;]*\\);" nil t))) 214 215 (if found 216 ;; Clean control characters and self-locks from text. 217 (let* ((lock-pattern 218 (concat "[ \b\t\n\v\f\r]+\\(" 219 (regexp-quote (user-login-name)) 220 ":\\)?")) 221 (locks 222 (save-restriction 223 (narrow-to-region (match-beginning 1) (match-end 1)) 224 (goto-char (point-min)) 225 (while (re-search-forward lock-pattern nil t) 226 (replace-match (if (eobp) "" ":") t t)) 227 (buffer-string))) 228 (status 229 (if (not (string-equal locks "")) 230 locks 231 (goto-char (point-min)) 232 (if (looking-at "head[ \b\t\n\v\f\r]+\\([.0-9]+\\)") 233 (concat "-" (buffer-substring (match-beginning 1) 234 (match-end 1))) 235 " @@")))) 236 ;; Clean work buffer. 237 (erase-buffer) 238 (set-buffer-modified-p nil) 239 status)))))) 240 241;;; install a call to the above as a find-file hook 242(defun vc-find-file-hook () 243 ;; Recompute whether file is version controlled, 244 ;; if user has killed the buffer and revisited. 245 (if buffer-file-name 246 (vc-file-setprop buffer-file-name 'vc-backend nil)) 247 (if (and (vc-mode-line buffer-file-name) (not vc-make-backup-files)) 248 (progn 249 ;; Use this variable, not make-backup-files, 250 ;; because this is for things that depend on the file name. 251 (make-local-variable 'backup-inhibited) 252 (setq backup-inhibited t)))) 253 254(add-hook 'find-file-hooks 'vc-find-file-hook) 255 256;;; more hooks, this time for file-not-found 257(defun vc-file-not-found-hook () 258 "When file is not found, try to check it out from RCS or SCCS. 259Returns t if checkout was successful, nil otherwise." 260 (if (vc-backend-deduce buffer-file-name) 261 (progn 262 (require 'vc) 263 (not (vc-error-occurred (vc-checkout buffer-file-name)))))) 264 265(add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook) 266 267;;; Now arrange for bindings and autoloading of the main package. 268;;; Bindings for this have to go in the global map, as we'll often 269;;; want to call them from random buffers. 270 271(setq vc-prefix-map (lookup-key global-map "\C-xv")) 272(if (not (keymapp vc-prefix-map)) 273 (progn 274 (setq vc-prefix-map (make-sparse-keymap)) 275 (define-key global-map "\C-xv" vc-prefix-map) 276 (define-key vc-prefix-map "a" 'vc-update-change-log) 277 (define-key vc-prefix-map "c" 'vc-cancel-version) 278 (define-key vc-prefix-map "d" 'vc-directory) 279 (define-key vc-prefix-map "h" 'vc-insert-headers) 280 (define-key vc-prefix-map "i" 'vc-register) 281 (define-key vc-prefix-map "l" 'vc-print-log) 282 (define-key vc-prefix-map "r" 'vc-retrieve-snapshot) 283 (define-key vc-prefix-map "s" 'vc-create-snapshot) 284 (define-key vc-prefix-map "u" 'vc-revert-buffer) 285 (define-key vc-prefix-map "v" 'vc-next-action) 286 (define-key vc-prefix-map "=" 'vc-diff) 287 (define-key vc-prefix-map "~" 'vc-version-other-window) 288 )) 289 290(provide 'vc-hooks) 291 292;;; vc-hooks.el ends here 293