code.delx.au - gnu-emacs/blob - lisp/vc-hooks.el

   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 ;; Maintainer: ttn@netcom.com
   7 ;; Version: 5.3 + CVS hacks by ceder@lysator.liu.se made in Jan-Feb 1994.
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; See the commentary of vc.el.
  28
  29 ;;; Code:
  30
  31 (defvar vc-master-templates
  32   '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS)
  33     ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS)
  34     vc-find-cvs-master)
  35   "*Where to look for version-control master files.
  36 The first pair corresponding to a given back end is used as a template
  37 when creating new masters.")
  38
  39 (defvar vc-make-backup-files nil
  40   "*If non-nil, backups of registered files are made as with other files.
  41 If nil (the default), files covered by version control don't get backups.")
  42
  43 (defvar vc-display-status t
  44   "*If non-nil, display revision number and lock status in modeline.
  45 Otherwise, not displayed.")
  46
  47 ;; Tell Emacs about this new kind of minor mode
  48 (if (not (assoc 'vc-mode minor-mode-alist))
  49     (setq minor-mode-alist (cons '(vc-mode vc-mode)
  50                                  minor-mode-alist)))
  51
  52 (make-variable-buffer-local 'vc-mode)
  53 (put 'vc-mode 'permanent-local t)
  54
  55 ;; We need a notion of per-file properties because the version
  56 ;; control state of a file is expensive to derive --- we don't
  57 ;; want to recompute it even on every find.
  58
  59 (defmacro vc-error-occurred (&rest body)
  60   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  61
  62 (defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
  63   "Obarray for per-file properties.")
  64
  65 (defun vc-file-setprop (file property value)
  66   ;; set per-file property
  67   (put (intern file vc-file-prop-obarray) property value))
  68
  69 (defun vc-file-getprop (file property)
  70   ;; get per-file property
  71   (get (intern file vc-file-prop-obarray) property))
  72
  73 ;;; actual version-control code starts here
  74
  75 (defun vc-registered (file)
  76   (let (handler handlers)
  77     (if (boundp 'file-name-handler-alist)
  78         (setq handler (find-file-name-handler file 'vc-registered)))
  79     (if handler
  80         (funcall handler 'vc-registered file)
  81       ;; Search for a master corresponding to the given file
  82       (let ((dirname (or (file-name-directory file) ""))
  83             (basename (file-name-nondirectory file)))
  84         (catch 'found
  85           (mapcar
  86            (function (lambda (s)
  87               (if (atom s)
  88                   (funcall s dirname basename)
  89                 (let ((trial (format (car s) dirname basename)))
  90                   (if (and (file-exists-p trial)
  91                            ;; Make sure the file we found with name
  92                            ;; TRIAL is not the source file itself.
  93                            ;; That can happen with RCS-style names
  94                            ;; if the file name is truncated
  95                            ;; (e.g. to 14 chars).  See if either
  96                            ;; directory or attributes differ.
  97                            (or (not (string= dirname
  98                                              (file-name-directory trial)))
  99                                (not (equal
 100                                      (file-attributes file)
 101                                      (file-attributes trial)))))
 102                       (throw 'found (cons trial (cdr s))))))))
 103            vc-master-templates)
 104           nil)))))
 105
 106 (defun vc-find-cvs-master (dirname basename)
 107   ;; Check if DIRNAME/BASENAME is handled by CVS.
 108   ;; If it is, do a (throw 'found (cons MASTER 'CVS)).
 109   ;; Note: If the file is ``cvs add''ed but not yet ``cvs commit''ed
 110   ;; the MASTER will not actually exist yet.  The other parts of VC
 111   ;; checks for this condition.  This function returns something random if
 112   ;; DIRNAME/BASENAME is not handled by CVS.
 113   (if (and (file-directory-p (concat dirname "CVS/"))
 114            (file-readable-p (concat dirname "CVS/Entries")))
 115       (let ((bufs nil))
 116         (unwind-protect
 117             (save-excursion
 118               (setq bufs (list
 119                           (find-file-noselect (concat dirname "CVS/Entries"))))
 120               (set-buffer (car bufs))
 121               (goto-char (point-min))
 122               (cond
 123                ((re-search-forward
 124                  (concat "^/" (regexp-quote basename) "/\\([^/]*\\)/")
 125                  nil t)
 126                 ;; We found it.  Store away version number, now
 127                 ;; that we are anyhow so close to finding it.
 128                 (vc-file-setprop (concat dirname basename)
 129                                  'vc-your-latest-version
 130                                  (buffer-substring (match-beginning 1)
 131                                                    (match-end 1)))
 132                 (setq bufs (cons (find-file-noselect
 133                                   (concat dirname "CVS/Repository"))
 134                                  bufs))
 135                 (set-buffer (car bufs))
 136                 (let ((master
 137                        (concat (file-name-as-directory
 138                                 (buffer-substring (point-min)
 139                                                   (1- (point-max))))
 140                                basename
 141                                ",v")))
 142                   (throw 'found (cons master 'CVS))))))
 143           (mapcar (function kill-buffer) bufs)))))
 144
 145 (defun vc-name (file)
 146   "Return the master name of a file, nil if it is not registered."
 147   (or (vc-file-getprop file 'vc-name)
 148       (let ((name-and-type (vc-registered file)))
 149         (if name-and-type
 150             (progn
 151               (vc-file-setprop file 'vc-backend (cdr name-and-type))
 152               (vc-file-setprop file 'vc-name (car name-and-type)))))))
 153
 154 (defun vc-backend-deduce (file)
 155   "Return the version-control type of a file, nil if it is not registered."
 156   (and file
 157        (or (vc-file-getprop file 'vc-backend)
 158            (let ((name-and-type (vc-registered file)))
 159              (if name-and-type
 160                  (progn
 161                    (vc-file-setprop file 'vc-name (car name-and-type))
 162                    (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
 163
 164 (defun vc-toggle-read-only (&optional verbose)
 165   "Change read-only status of current buffer, perhaps via version control.
 166 If the buffer is visiting a file registered with version control,
 167 then check the file in or out.  Otherwise, just change the read-only flag
 168 of the buffer.
 169 If you provide a prefix argument, we pass it on to `vc-next-action'."
 170   (interactive "P")
 171   (if (vc-backend-deduce (buffer-file-name))
 172       (vc-next-action verbose)
 173     (toggle-read-only)))
 174 (define-key global-map "\C-x\C-q" 'vc-toggle-read-only)
 175
 176 (defun vc-mode-line (file &optional label)
 177   "Set `vc-mode' to display type of version control for FILE.
 178 The value is set in the current buffer, which should be the buffer
 179 visiting FILE.  Second optional arg LABEL is put in place of version
 180 control system name."
 181   (interactive (list buffer-file-name nil))
 182   (if file
 183       (let ((vc-type (vc-backend-deduce file)))
 184         (setq vc-mode
 185               (if vc-type
 186                   (concat " " (or label (symbol-name vc-type))
 187                           (if vc-display-status
 188                               (vc-status file vc-type)))))
 189         ;; Even root shouldn't modify a registered file without
 190         ;; locking it first.
 191         (and vc-type
 192              (not buffer-read-only)
 193              (zerop (user-uid))
 194              (require 'vc)
 195              (not (equal (user-login-name) (vc-locking-user file)))
 196              (setq buffer-read-only t))
 197         (and (null vc-type)
 198              (file-symlink-p file)
 199              (let ((link-type (vc-backend-deduce (file-symlink-p file))))
 200                (if link-type
 201                    (message
 202                     "Warning: symbolic link to %s-controlled source file"
 203                     link-type))))
 204         (force-mode-line-update)
 205         ;;(set-buffer-modified-p (buffer-modified-p))  ;;use this if Emacs 18
 206         vc-type)))
 207
 208 (defun vc-status (file vc-type)
 209   ;; Return string for placement in modeline by `vc-mode-line'.
 210   ;; If FILE is not registered, return nil.
 211   ;; If FILE is registered but not locked, return " REV" if there is a head
 212   ;; revision and " @@" otherwise.
 213   ;; If FILE is locked then return all locks in a string of the
 214   ;; form " LOCKER1:REV1 LOCKER2:REV2 ...", where "LOCKERi:" is empty if you
 215   ;; are the locker, and otherwise is the name of the locker followed by ":".
 216
 217   ;; Algorithm:
 218
 219   ;; Check for master file corresponding to FILE being visited.
 220   ;;
 221   ;; RCS: Insert the first few characters of the master file into a
 222   ;; work buffer.  Search work buffer for "locks...;" phrase; if not
 223   ;; found, then keep inserting more characters until the phrase is
 224   ;; found.  Extract the locks, and remove control characters
 225   ;; separating them, like newlines; the string " user1:revision1
 226   ;; user2:revision2 ..." is returned.
 227   ;;
 228   ;; SCCS: Check if the p-file exists.  If it does, read it and
 229   ;; extract the locks, giving them the right format.  Else use prs to
 230   ;; find the revision number.
 231   ;;
 232   ;; CVS: vc-find-cvs-master has already stored the current revision
 233   ;; number.  Fetch it from the file property.
 234
 235   ;; Limitations:
 236
 237   ;; The output doesn't show which version you are actually looking at.
 238   ;; The modeline can get quite cluttered when there are multiple locks.
 239   ;; The head revision is probably not what you want if you've used `rcs -b'.
 240
 241   (let ((master (vc-name file))
 242         found
 243         status)
 244
 245     ;; If master file exists, then parse its contents, otherwise we
 246     ;; return the nil value of this if form.
 247     (if (and master vc-type)
 248         (save-excursion
 249
 250           ;; Create work buffer.
 251           (set-buffer (get-buffer-create " *vc-status*"))
 252           (setq buffer-read-only nil
 253                 default-directory (file-name-directory master))
 254           (erase-buffer)
 255
 256           ;; Set the `status' var to the return value.
 257           (cond
 258
 259            ;; RCS code.
 260            ((eq vc-type 'RCS)
 261             ;; Check if we have enough of the header.
 262             ;; If not, then keep including more.
 263             (while
 264                 (not (or found
 265                          (let ((s (buffer-size)))
 266                            (goto-char (1+ s))
 267                            (zerop (car (cdr (insert-file-contents
 268                                              master nil s (+ s 8192))))))))
 269               (beginning-of-line)
 270               (setq found (re-search-forward "^locks\\([^;]*\\);" nil t)))
 271
 272             (if found
 273                 ;; Clean control characters and self-locks from text.
 274                 (let* ((lock-pattern
 275                         (concat "[ \b\t\n\v\f\r]+\\("
 276                                 (regexp-quote (user-login-name))
 277                                 ":\\)?"))
 278                        (locks
 279                         (save-restriction
 280                           (narrow-to-region (match-beginning 1) (match-end 1))
 281                           (goto-char (point-min))
 282                           (while (re-search-forward lock-pattern nil t)
 283                             (replace-match (if (eobp) "" ":") t t))
 284                           (buffer-string))))
 285                   (setq status
 286                         (if (not (string-equal locks ""))
 287                             locks
 288                           (goto-char (point-min))
 289                           (if (looking-at "head[ \b\t\n\v\f\r]+\\([.0-9]+\\)")
 290                               (concat "-"
 291                                       (buffer-substring (match-beginning 1)
 292                                                         (match-end 1)))
 293                             " @@"))))))
 294
 295            ;; SCCS code.
 296            ((eq vc-type 'SCCS)
 297             ;; Build the name of the p-file and put it in the work buffer.
 298             (insert master)
 299             (search-backward "/s.")
 300             (delete-char 2)
 301             (insert "/p")
 302             (if (not (file-exists-p (buffer-string)))
 303                 ;; No lock.
 304                 (let ((exec-path (if vc-path (append exec-path vc-path)
 305                                    exec-path)))
 306                   (erase-buffer)
 307                   (insert "-")
 308                   (if (zerop (call-process "prs" nil t nil "-d:I:" master))
 309                       (setq status (buffer-substring 1 (1- (point-max))))))
 310               ;; Locks exist.
 311               (insert-file-contents (buffer-string) nil nil nil t)
 312               (while (looking-at "[^ ]+ \\([^ ]+\\) \\([^ ]+\\).*\n")
 313                 (replace-match " \\2:\\1"))
 314               (setq status (buffer-string))
 315               (aset status 0 ?:)))
 316            ;; CVS code.
 317            ((eq vc-type 'CVS)
 318             (let ((version (vc-file-getprop
 319                             file 'vc-your-latest-version)))
 320               (setq status (concat ":" (if (string= "0" version)
 321                                            " @@" ;added, not yet committed.
 322                                          version))))))
 323
 324           ;; Clean work buffer.
 325           (erase-buffer)
 326           (set-buffer-modified-p nil)
 327           status))))
 328
 329 ;;; install a call to the above as a find-file hook
 330 (defun vc-find-file-hook ()
 331   ;; Recompute whether file is version controlled,
 332   ;; if user has killed the buffer and revisited.
 333   (if buffer-file-name
 334       (vc-file-setprop buffer-file-name 'vc-backend nil))
 335   (if (and (vc-mode-line buffer-file-name) (not vc-make-backup-files))
 336       (progn
 337         ;; Use this variable, not make-backup-files,
 338         ;; because this is for things that depend on the file name.
 339         (make-local-variable 'backup-inhibited)
 340         (setq backup-inhibited t))))
 341
 342 (add-hook 'find-file-hooks 'vc-find-file-hook)
 343
 344 ;;; more hooks, this time for file-not-found
 345 (defun vc-file-not-found-hook ()
 346   "When file is not found, try to check it out from RCS or SCCS.
 347 Returns t if checkout was successful, nil otherwise."
 348   (if (vc-backend-deduce buffer-file-name)
 349       (save-excursion
 350         (require 'vc)
 351         (not (vc-error-occurred (vc-checkout buffer-file-name))))))
 352
 353 (add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)
 354
 355 ;;; Now arrange for bindings and autoloading of the main package.
 356 ;;; Bindings for this have to go in the global map, as we'll often
 357 ;;; want to call them from random buffers.
 358
 359 (setq vc-prefix-map (lookup-key global-map "\C-xv"))
 360 (if (not (keymapp vc-prefix-map))
 361     (progn
 362       (setq vc-prefix-map (make-sparse-keymap))
 363       (define-key global-map "\C-xv" vc-prefix-map)
 364       (define-key vc-prefix-map "a" 'vc-update-change-log)
 365       (define-key vc-prefix-map "c" 'vc-cancel-version)
 366       (define-key vc-prefix-map "d" 'vc-directory)
 367       (define-key vc-prefix-map "h" 'vc-insert-headers)
 368       (define-key vc-prefix-map "i" 'vc-register)
 369       (define-key vc-prefix-map "l" 'vc-print-log)
 370       (define-key vc-prefix-map "r" 'vc-retrieve-snapshot)
 371       (define-key vc-prefix-map "s" 'vc-create-snapshot)
 372       (define-key vc-prefix-map "u" 'vc-revert-buffer)
 373       (define-key vc-prefix-map "v" 'vc-next-action)
 374       (define-key vc-prefix-map "=" 'vc-diff)
 375       (define-key vc-prefix-map "~" 'vc-version-other-window)))
 376
 377 (if (not (boundp 'vc-menu-map))
 378     ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar
 379     ;; vc-menu-map.
 380     ()
 381   ;;(define-key vc-menu-map [show-files]
 382   ;;  '("Show Files under VC" . (vc-directory t)))
 383   (define-key vc-menu-map [vc-directory] '("Show Locked Files" . vc-directory))
 384   (define-key vc-menu-map [separator1] '("----"))
 385   (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file))
 386   (define-key vc-menu-map [vc-version-other-window]
 387     '("Show Other Version" . vc-version-other-window))
 388   (define-key vc-menu-map [vc-diff] '("Compare with Last Version" . vc-diff))
 389   (define-key vc-menu-map [vc-update-change-log]
 390     '("Update ChangeLog" . vc-update-change-log))
 391   (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log))
 392   (define-key vc-menu-map [separator2] '("----"))
 393   (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version))
 394   (define-key vc-menu-map [vc-revert-buffer]
 395     '("Revert to Last Version" . vc-revert-buffer))
 396   (define-key vc-menu-map [vc-insert-header]
 397     '("Insert Header" . vc-insert-headers))
 398   (define-key vc-menu-map [vc-menu-check-in] '("Check In" . vc-next-action))
 399   (define-key vc-menu-map [vc-check-out] '("Check Out" . vc-toggle-read-only))
 400   (define-key vc-menu-map [vc-register] '("Register" . vc-register))
 401   (put 'vc-rename-file 'menu-enable 'vc-mode)
 402   (put 'vc-version-other-window 'menu-enable 'vc-mode)
 403   (put 'vc-diff 'menu-enable 'vc-mode)
 404   (put 'vc-update-change-log 'menu-enable
 405        '(eq (vc-backend-deduce (buffer-file-name)) 'RCS))
 406   (put 'vc-print-log 'menu-enable 'vc-mode)
 407   (put 'vc-cancel-version 'menu-enable 'vc-mode)
 408   (put 'vc-revert-buffer 'menu-enable 'vc-mode)
 409   (put 'vc-insert-headers 'menu-enable 'vc-mode)
 410   (put 'vc-next-action 'menu-enable '(and vc-mode (not buffer-read-only)))
 411   (put 'vc-toggle-read-only 'menu-enable '(and vc-mode buffer-read-only))
 412   (put 'vc-register 'menu-enable '(not vc-mode))
 413   )
 414
 415 (provide 'vc-hooks)
 416
 417 ;;; vc-hooks.el ends here