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