lisp/fast-lock.el

   1 ;;; fast-lock.el --- Automagic text properties saving for fast font-lock-mode.
   2
   3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Marshall <Simon.Marshall@mail.esrin.esa.it>
   6 ;; Keywords: faces files
   7 ;; Version: 3.05
   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 ;; Purpose:
  28 ;;
  29 ;; To make visiting a file in `font-lock-mode' faster by restoring its face
  30 ;; text properties from automatically saved associated font lock cache files.
  31 ;;
  32 ;; See also the face-lock package.
  33 ;; See also the lazy-lock package.  (But don't use the two at the same time!)
  34
  35 ;; Note that:
  36 ;;
  37 ;; - A cache will be saved when visiting a compressed file using crypt++, but
  38 ;;   not be read.  This is a "feature"/"consequence"/"bug" of crypt++.
  39
  40 ;; Installation:
  41 ;;
  42 ;; Put this file somewhere where Emacs can find it (i.e., in one of the paths
  43 ;; in your `load-path'), `byte-compile-file' it, and put in your ~/.emacs:
  44 ;;
  45 ;; (autoload 'turn-on-fast-lock "fast-lock"
  46 ;;   "Unconditionally turn on Fast Lock mode.")
  47 ;;
  48 ;; (add-hook 'font-lock-mode-hook 'turn-on-fast-lock)
  49 ;;
  50 ;; Start up a new Emacs and use font-lock as usual (except that you can use the
  51 ;; so-called "gaudier" fontification regexps on big files without frustration).
  52 ;;
  53 ;; When you visit a file (which has `font-lock-mode' enabled) that has a
  54 ;; corresponding font lock cache file associated with it, the font lock cache
  55 ;; will be loaded from that file instead of being generated by font-lock code.
  56 ;;
  57 ;; Font lock caches will be saved:
  58 ;;  - For all buffers with Fast Lock mode enabled when you exit from Emacs.
  59 ;;  - For a buffer with Fast Lock mode enabled when you kill the buffer.
  60 ;; To provide control over how such cache files are written automagically, see
  61 ;; variable `fast-lock-cache-directories'.  To provide control over which such
  62 ;; cache files are written, see variables `fast-lock-save-others' and
  63 ;; `fast-lock-save-size'.  Only cache files which were generated using the same
  64 ;; `font-lock-keywords' as you are using will be used.
  65 ;;
  66 ;; As an illustration of the time saving, a 115k file of Emacs C code took 95
  67 ;; seconds to fontify using Emacs 19.25 on a Sun SparcStation 2 LX (using
  68 ;; `c-font-lock-keywords-2').  The font lock cache file takes around 2 seconds
  69 ;; to load (with around 4 seconds to generate and save).  Bite it.  Believe it.
  70 ;; (For Lucid Emacs 19.10, the figures on a similar machine, file, and regexps,
  71 ;; are 70, around 4, and around 4, seconds, respectively; for Emacs 19.28 the
  72 ;; fontification takes around 26 seconds.)
  73
  74 ;; Feedback:
  75 ;;
  76 ;; Please send me bug reports, bug fixes, and extensions, so that I can
  77 ;; merge them into the master source.
  78 ;;     - Simon Marshall (Simon.Marshall@mail.esrin.esa.it)
  79 \f
  80 (require 'font-lock)
  81
  82 (eval-when-compile
  83   ;; Shut Emacs' byte-compiler up (cf. stop me getting mail from users).
  84   (setq byte-compile-warnings '(free-vars callargs redefine)))
  85
  86 ;; User variables:
  87
  88 (defvar fast-lock-cache-directories '("." "~/.emacs-flc")
  89 ; - `internal', keep each file's font lock cache file in the same file.
  90 ; - `external', keep each file's font lock cache file in the same directory.
  91   "Directories in which font lock cache files are saved and read.
  92 Each item should be either DIR or a cons pair of the form (REGEXP . DIR) where
  93 DIR is a directory name (relative or absolute) and REGEXP is a regexp.
  94
  95 An attempt will be made to save or read font lock cache files using these items
  96 until one succeeds (i.e., until a readable or writable one is found).  If an
  97 item contains REGEXP, DIR is used only if the buffer file name matches REGEXP.
  98 For example:
  99
 100  (list (cons (concat \"^\" (regexp-quote (expand-file-name \"~\"))) \".\")
 101        \"~/.emacs-flc\")
 102
 103 would cause a file's current directory to be used if the file is under your
 104 home directory hierarchy, and the absolute directory otherwise.")
 105
 106 (defvar fast-lock-save-size (* 10 1024)
 107   "If non-nil, the minimum size for buffer files.
 108 Only buffer files at least this size can have associated font lock cache files
 109 saved.  If nil, means size is irrelevant.")
 110
 111 (defvar fast-lock-save-others t
 112   "If non-nil, save font lock cache files irrespective of file owner.
 113 If nil, means only buffer files owned by you have a font lock cache saved.")
 114
 115 (defvar fast-lock-mode nil)             ; for modeline
 116 (defvar fast-lock-cache-timestamp nil)  ; for saving/reading
 117 (make-variable-buffer-local 'fast-lock-cache-timestamp)
 118 \f
 119 ;; Functions:
 120
 121 (defun fast-lock-mode (&optional arg)
 122   "Toggle Fast Lock mode.
 123 With arg, turn Fast Lock mode on if and only if arg is positive and the buffer
 124 is associated with a file.
 125
 126 If Fast Lock mode is enabled, and the current buffer does not contain any text
 127 properties, any associated font lock cache is used (by `fast-lock-read-cache')
 128 if the same `font-lock-keywords' were used for the cache as you are using.
 129
 130 Font lock caches will be saved:
 131  - For all buffers with Fast Lock mode enabled when you exit from Emacs.
 132  - For a buffer with Fast Lock mode enabled when you kill the buffer.
 133 Saving is done by `fast-lock-save-cache' and `fast-lock-save-caches'.
 134
 135 Various methods of control are provided for the font lock cache.  In general,
 136 see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'.
 137 For saving, see variables `fast-lock-save-others' and `fast-lock-save-size'."
 138   (interactive "P")
 139   (set (make-local-variable 'fast-lock-mode)
 140        (and (buffer-file-name)
 141             (if arg (> (prefix-numeric-value arg) 0) (not fast-lock-mode))))
 142   (if (and fast-lock-mode (not font-lock-fontified))
 143       (fast-lock-read-cache)))
 144
 145 (defun fast-lock-read-cache ()
 146   "Read the font lock cache for the current buffer.
 147 Returns t if the font lock cache file is read.
 148
 149 The following criteria must be met for a font lock cache file to be read:
 150  - Fast Lock mode must be turned on in the buffer.
 151  - The buffer's `font-lock-keywords' must match the cache's.
 152  - The buffer file's timestamp must match the cache's.
 153  - Criteria imposed by `fast-lock-cache-directories'.
 154
 155 See also `fast-lock-save-cache' and `fast-lock-cache-name'."
 156   (interactive)
 157   (let ((directories fast-lock-cache-directories) directory
 158         (modified (buffer-modified-p))
 159         (fontified font-lock-fontified))
 160     (set (make-local-variable 'font-lock-fontified) nil)
 161     ;; Keep trying directories until fontification is turned off.
 162     (while (and directories (not font-lock-fontified))
 163       (setq directory (fast-lock-cache-directory (car directories) nil)
 164             directories (cdr directories))
 165       (if directory
 166           (condition-case nil
 167               (load (fast-lock-cache-name directory) t t t)
 168             (error nil) (quit nil))))
 169     (set-buffer-modified-p modified)
 170     (or font-lock-fontified (setq font-lock-fontified fontified))))
 171
 172 (defun fast-lock-save-cache (&optional buffer)
 173   "Save the font lock cache of BUFFER or the current buffer.
 174 Returns t if the font lock cache file is saved.
 175
 176 The following criteria must be met for a font lock cache file to be saved:
 177  - Fast Lock mode must be turned on in the buffer.
 178  - The buffer must be at least `fast-lock-save-size' bytes long.
 179  - The buffer file must be owned by you, or `fast-lock-save-others' must be t.
 180  - The buffer must contain at least one `face' text property.
 181  - The buffer file's timestamp must be different than its associated text
 182    properties file's timestamp.
 183  - Criteria imposed by `fast-lock-cache-directories'.
 184
 185 See also `fast-lock-save-caches', `fast-lock-read-cache' and `fast-lock-mode'."
 186   (interactive)
 187   (let* ((bufile (buffer-file-name buffer))
 188          (buatts (and bufile (file-attributes bufile)))
 189          (bufile-timestamp (nth 5 buatts))
 190          (bufuid (nth 2 buatts)) (saved nil))
 191     (save-excursion
 192       (and buffer (set-buffer buffer))
 193       (if (and fast-lock-mode
 194                ;; Only save if the timestamp of the file has changed.
 195                (not (equal fast-lock-cache-timestamp bufile-timestamp))
 196                ;; User's restrictions?
 197                (or fast-lock-save-others (eq (user-uid) bufuid))
 198                (<= (or fast-lock-save-size 0) (buffer-size))
 199                ;; Only save if there are properties to save.
 200                (text-property-not-all (point-min) (point-max) 'face nil))
 201           (let ((directories fast-lock-cache-directories) directory)
 202             (while (and directories (not saved))
 203               (setq directory (fast-lock-cache-directory (car directories) t)
 204                     directories (cdr directories))
 205               (if directory
 206                   (setq saved (fast-lock-save-cache-data
 207                                directory bufile-timestamp))))))
 208       ;; Set the buffer's timestamp if saved.
 209       (and saved (setq fast-lock-cache-timestamp bufile-timestamp)))
 210     saved))
 211
 212 (defun fast-lock-save-cache-data (directory timestamp)
 213   ;; Save the file with the timestamp, if we can, in the given directory, as:
 214   ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES).
 215   (let ((buname (buffer-name))
 216         (tpfile (fast-lock-cache-name directory))
 217         (saved nil))
 218     (if (file-writable-p tpfile)
 219         (let ((tpbuf (generate-new-buffer " *fast-lock*")))
 220           (message "Saving %s font lock cache..." buname)
 221           (unwind-protect
 222               (save-excursion
 223                 (print (list 'fast-lock-cache-data 2
 224                              (list 'quote timestamp)
 225                              (list 'quote font-lock-keywords)
 226                              (list 'quote (fast-lock-get-face-properties)))
 227                        tpbuf)
 228                 (set-buffer tpbuf)
 229                 (write-region (point-min) (point-max) tpfile nil 'quietly)
 230                 (setq saved t))
 231             (kill-buffer tpbuf))
 232           (message "Saving %s font lock cache... done." buname)))
 233     saved))
 234 \f
 235 ;; Miscellaneous functions:
 236
 237 (defun turn-on-fast-lock ()
 238   "Unconditionally turn on Fast Lock mode."
 239   (fast-lock-mode 1))
 240
 241 (defun fast-lock-save-caches ()
 242   "Save the font lock caches of all buffers.
 243 Returns list of cache save success of buffers in `buffer-list'.
 244 See `fast-lock-save-cache' for details of save criteria."
 245   (mapcar 'fast-lock-save-cache (buffer-list)))
 246
 247 (defun fast-lock-cache-directory (directory create)
 248   "Return usable directory based on DIRECTORY.
 249 Returns nil if the directory does not exist, or, if CREATE non-nil, cannot be
 250 created.  DIRECTORY may be a string or a cons pair of the form (REGEXP . DIR).
 251 See `fast-lock-cache-directories'."
 252   (let ((dir (cond ((not buffer-file-name)
 253                     nil)
 254                    ((stringp directory)
 255                     directory)
 256                    (t
 257                     (let ((bufile (expand-file-name
 258                                    (abbreviate-file-name
 259                                     (file-truename buffer-file-name))))
 260                           (case-fold-search nil))
 261                       (if (string-match (car directory) bufile)
 262                           (cdr directory)))))))
 263     (cond ((not dir)
 264            nil)
 265           ((not create)
 266            (and (file-accessible-directory-p dir) dir))
 267           (t
 268            (if (file-accessible-directory-p dir)
 269                dir
 270              (condition-case nil (make-directory dir t) (error nil))
 271              (and (file-accessible-directory-p dir) dir))))))
 272
 273 (defun fast-lock-cache-name (directory)
 274   "Return full cache path name using caching DIRECTORY.
 275 If DIRECTORY is `.', the path is the buffer file name appended with `.flc'.
 276 Otherwise, the path name is constructed from DIRECTORY and the buffer's true
 277 abbreviated file name, with all `/' characters in the name replaced with `#'
 278 characters, and appended with `.flc'.
 279
 280 See `fast-lock-mode'."
 281   (if (string-equal directory ".")
 282       (concat buffer-file-name ".flc")
 283     (let* ((bufile (expand-file-name
 284                     (abbreviate-file-name (file-truename buffer-file-name))))
 285            (chars-alist
 286             (if (eq system-type 'emx)
 287                 '((?/ . (?#)) (?# . (?# ?#)) (?: . (?\;)) (?\; . (?\; ?\;)))
 288               '((?/ . (?#)) (?# . (?# ?#)))))
 289            (mapchars
 290             (function (lambda (c) (or (cdr (assq c chars-alist)) (list c))))))
 291       (concat
 292        (file-name-as-directory (expand-file-name directory))
 293        (mapconcat 'char-to-string (apply 'append (mapcar mapchars bufile)) "")
 294        ".flc"))))
 295 \f
 296 ;; Font lock cache processing functions:
 297
 298 (defun fast-lock-cache-data (version timestamp keywords properties
 299                              &rest ignored)
 300   ;; Use the font lock cache PROPERTIES if we're using cache VERSION format 2,
 301   ;; the current buffer's file timestamp matches the TIMESTAMP, and the current
 302   ;; buffer's font-lock-keywords are the same as KEYWORDS.
 303   (let ((buf-timestamp (nth 5 (file-attributes buffer-file-name)))
 304         (buname (buffer-name)) (inhibit-read-only t) (loaded t))
 305     (if (or (/= version 2)
 306             (not (equal timestamp buf-timestamp))
 307             (not (equal keywords font-lock-keywords)))
 308         (setq loaded nil)
 309       (message "Loading %s font lock cache..." buname)
 310       (condition-case nil
 311           (fast-lock-set-face-properties properties)
 312         (error (setq loaded nil)) (quit (setq loaded nil)))
 313       (message "Loading %s font lock cache... done." buname))
 314     ;; If we used the text properties, stop fontification and keep timestamp.
 315     (setq font-lock-fontified loaded
 316           fast-lock-cache-timestamp (and loaded timestamp))))
 317
 318 (defun fast-lock-get-face-properties (&optional buffer)
 319   "Return a list of all `face' text properties in BUFFER.
 320 Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
 321 where VALUE is a `face' property value and STARTx and ENDx are positions."
 322   (save-excursion
 323     (and buffer (set-buffer buffer))
 324     (save-restriction
 325       (widen)
 326       (let ((start (text-property-not-all (point-min) (point-max) 'face nil))
 327             (limit (point-max)) end properties value cell)
 328         (while start
 329           (setq end (next-single-property-change start 'face nil limit)
 330                 value (get-text-property start 'face))
 331           ;; Make or add to existing list of regions with same `face' property.
 332           (if (setq cell (assq value properties))
 333               (setcdr cell (cons start (cons end (cdr cell))))
 334             (setq properties (cons (list value start end) properties)))
 335           (setq start (next-single-property-change end 'face)))
 336         properties))))
 337
 338 (defun fast-lock-set-face-properties (properties &optional buffer)
 339   "Set all `face' text properties to PROPERTIES in BUFFER.
 340 Any existing `face' text properties are removed first.  Leaves BUFFER modified.
 341 See `fast-lock-get-face-properties' for the format of PROPERTIES."
 342   (save-excursion
 343     (and buffer (set-buffer buffer))
 344     (save-restriction
 345       (widen)
 346       (font-lock-unfontify-region (point-min) (point-max))
 347       (while properties
 348         (let ((plist (list 'face (car (car properties))))
 349               (regions (cdr (car properties))))
 350           ;; Set the `face' property for each start/end region.
 351           (while regions
 352             (set-text-properties (nth 0 regions) (nth 1 regions) plist buffer)
 353             (setq regions (nthcdr 2 regions)))
 354           (setq properties (cdr properties)))))))
 355 \f
 356 ;; Functions for Lucid:
 357
 358 (or (fboundp 'face-list)
 359     (defalias 'face-list 'list-faces))
 360
 361 (if (save-match-data (string-match "Lucid" (emacs-version)))
 362     ;; This is about a bazillion times faster at generating the cache in Lucid.
 363     (defun fast-lock-get-face-properties (&optional buffer)
 364       "Return a list of all `face' text properties in BUFFER.
 365 Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
 366 where VALUE is a `face' property value and STARTx and ENDx are positions."
 367       (save-excursion
 368         (and buffer (set-buffer buffer))
 369         (save-restriction
 370           (widen)
 371           (let ((properties ()))
 372             (map-extents
 373              (function (lambda (extent ignore)
 374               (let* ((face (extent-face extent))
 375                      (start (extent-start-position extent))
 376                      (end (extent-end-position extent))
 377                      (facedata (assoc face properties)))
 378                 (if facedata
 379                     ;; Prepend the new start and end points onto the list.
 380                     (setcdr facedata (cons start (cons end (cdr facedata))))
 381                   (setq properties (cons (list face start end) properties)))
 382                 ;; Return nil to keep `map-extents' going.
 383                 nil))))
 384             properties)))))
 385
 386 (if (save-match-data (string-match "Lucid" (emacs-version)))
 387     ;; This is faster at using the cache in Lucid.
 388     (defun fast-lock-set-face-properties (properties &optional buffer)
 389       "Set all `face' text properties to PROPERTIES in BUFFER.
 390 Any existing `face' text properties are removed first.  Leaves BUFFER modified.
 391 See `fast-lock-get-face-properties' for the format of PROPERTIES."
 392       (save-excursion
 393         (and buffer (set-buffer buffer))
 394         (save-restriction
 395           (widen)
 396           (font-lock-unfontify-region (point-min) (point-max))
 397           (while properties
 398             (let ((property (car (car properties)))
 399                   (regions (cdr (car properties))) extent)
 400               ;; Set the `face' property for each start/end region.
 401               (while regions
 402                 (setq extent (make-extent (nth 0 regions) (nth 1 regions))
 403                       regions (nthcdr 2 regions))
 404                 (set-extent-face extent property)
 405                 (set-extent-property extent 'text-prop 'face))
 406               (setq properties (cdr properties))))))))
 407
 408 (if (and (boundp 'emacs-minor-version) (< emacs-minor-version 12))
 409     ;; Must be [LX]Emacs; fix the 19.11 (at least) `text-property-not-all' bug.
 410     (defun text-property-not-all (start end prop value &optional buffer)
 411       "Check text from START to END to see if PROP is ever not `eq' to VALUE.
 412 If so, return the position of the first character whose PROP is not
 413 `eq' to VALUE.  Otherwise, return nil."
 414       (let ((maxend start))
 415         (map-extents
 416          (function
 417           (lambda (e ignore)
 418             ;;### no, actually, this is harder.  We need to collect all props
 419             ;; for a given character, and then determine whether no extent
 420             ;; contributes the given value.  Doing this without consing lots
 421             ;; of lists is the tricky part.
 422             (if (not (eq value (extent-property e prop)))
 423                 (max start maxend)
 424               (setq maxend (extent-end-position e))
 425               nil)))
 426          nil start end buffer))))
 427 \f
 428 ;; Install ourselves:
 429
 430 (or (assq 'fast-lock-mode minor-mode-alist)
 431     (setq minor-mode-alist (cons '(fast-lock-mode " Fast") minor-mode-alist)))
 432
 433 (add-hook 'kill-buffer-hook 'fast-lock-save-cache)
 434 (add-hook 'kill-emacs-hook 'fast-lock-save-caches)
 435
 436 ;; Provide ourselves:
 437
 438 (provide 'fast-lock)
 439
 440 ;;; fast-lock.el ends here
 441