comparison lisp/fast-lock.el @ 23752:001e0e875d56

* fast-lock.el (fast-lock-save-cache-1): (fast-lock-cache-data): Rewritten to use with-temp-message.

23751:3fdde7281f9b

;;; fast-lock.el --- Automagic text properties caching for fast Font Lock mode.

;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc.

;; Author: Simon Marshall <[e-mail]>
;; Keywords: faces files
;; Version: 3.13

;;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; - Made `fast-lock-save-cache-1' save syntactic fontification data
;; - Made `fast-lock-cache-data' take syntactic fontification data
;; - Added `fast-lock-get-syntactic-properties'
;; - Renamed `fast-lock-set-face-properties' to `fast-lock-add-properties'
;; - Made `fast-lock-add-properties' add syntactic and face fontification data

;;; Code:

(require 'font-lock)

	       (while (unless (memq (car faces) fast-lock-save-faces)
			(setq faces (cdr faces))))
	       faces)))))
  ;;
  ;; We use this for compatibility with a future Emacs.
  (or (fboundp 'defcustom)
      (defmacro defcustom (symbol value doc &rest args) 
	(` (defvar (, symbol) (, value) (, doc))))))

;(defun fast-lock-submit-bug-report ()
;  "Submit via mail a bug report on fast-lock.el."
;  (interactive)
;  (let ((reporter-prompt-for-summary-p t))
;    (reporter-submit-bug-report "[e-mail]" "fast-lock 3.13"
;     '(fast-lock-cache-directories fast-lock-minimum-size
;       fast-lock-save-others fast-lock-save-events fast-lock-save-faces
;       fast-lock-verbose)
;     nil nil
;     (concat "Hi Si.,

(defvar fast-lock-cache-timestamp nil)	; For saving/reading.
(defvar fast-lock-cache-filename nil)	; For deleting.

;; User Variables:

(defcustom fast-lock-minimum-size (* 25 1024)
  "*Minimum size of a buffer for cached fontification.
Only buffers more than this can have associated Font Lock cache files saved.
If nil, means cache files are never created.
If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE),
where MAJOR-MODE is a symbol or t (meaning the default).  For example:

(defcustom fast-lock-verbose font-lock-verbose
  "*If non-nil, means show status messages for cache processing.
If a number, only buffers greater than this size have processing messages."
  :type '(choice (const :tag "never" nil)
		 (integer :tag "size")
		 (other :tag "always" t))
  :group 'fast-lock)

(defvar fast-lock-save-faces
  (when (save-match-data (string-match "XEmacs" (emacs-version)))
    ;; XEmacs uses extents for everything, so we have to pick the right ones.

  (let ((tpbuf (generate-new-buffer " *fast-lock*"))
	(verbose (if (numberp fast-lock-verbose)
		     (> (buffer-size) fast-lock-verbose)
		   fast-lock-verbose))
	(saved t))
    (if verbose (message "Saving %s font lock cache..." (buffer-name)))
    (condition-case nil
	(save-excursion
	  (print (list 'fast-lock-cache-data 3
		       (list 'quote timestamp)
		       (list 'quote font-lock-syntactic-keywords)
		       (list 'quote (fast-lock-get-syntactic-properties))
		       (list 'quote font-lock-keywords)
		       (list 'quote (fast-lock-get-face-properties)))
		 tpbuf)
	  (set-buffer tpbuf)
	  (write-region (point-min) (point-max) file nil 'quietly)
	  (setq fast-lock-cache-timestamp timestamp
		fast-lock-cache-filename file))
      (error (setq saved 'error)) (quit (setq saved 'quit)))
    (kill-buffer tpbuf)
    (if verbose (message "Saving %s font lock cache...%s" (buffer-name)
			 (cond ((eq saved 'error) "failed")
			       ((eq saved 'quit) "aborted")
			       (t "done"))))
    ;; We return non-nil regardless of whether a failure occurred.
    saved))

(defun fast-lock-cache-data (version timestamp
			     syntactic-keywords syntactic-properties

	    (buffer-modified-p)
	    (not (equal timestamp buf-timestamp))
	    (not (equal syntactic-keywords font-lock-syntactic-keywords))
	    (not (equal keywords font-lock-keywords)))
	(setq loaded nil)
      (if verbose (message "Loading %s font lock cache..." (buffer-name)))
      (condition-case nil
	  (fast-lock-add-properties syntactic-properties face-properties)
	(error (setq loaded 'error)) (quit (setq loaded 'quit)))
      (if verbose (message "Loading %s font lock cache...%s" (buffer-name)
			   (cond ((eq loaded 'error) "failed")
				 ((eq loaded 'quit) "aborted")
				 (t "done")))))
    (setq font-lock-fontified (eq loaded t)
	  fast-lock-cache-timestamp (and (eq loaded t) timestamp))))

;; Text Properties Processing Functions:

(unless (fboundp 'font-lock-value-in-major-mode)
  (defun font-lock-value-in-major-mode (alist)
    (if (consp alist)
	(cdr (or (assq major-mode alist) (assq t alist)))
      alist)))

;; Install ourselves:

(add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file)
(add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer)

23752:001e0e875d56

;;; fast-lock.el --- Automagic text properties caching for fast Font Lock mode.

;; Copyright (C) 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.

;; Author: Simon Marshall <[e-mail]>
;; Keywords: faces files
;; Version: 3.14

;;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; - Made `fast-lock-save-cache-1' save syntactic fontification data
;; - Made `fast-lock-cache-data' take syntactic fontification data
;; - Added `fast-lock-get-syntactic-properties'
;; - Renamed `fast-lock-set-face-properties' to `fast-lock-add-properties'
;; - Made `fast-lock-add-properties' add syntactic and face fontification data
;; 3.13--3.14:
;; - Made `fast-lock-cache-name' cope with `windowsnt' (Geoff Voelker fix)
;; - Made `fast-lock-verbose' use `other' widget (Andreas Schwab fix)
;; - Used `with-temp-message' where possible to make messages temporary.

;;; Code:

(require 'font-lock)

	       (while (unless (memq (car faces) fast-lock-save-faces)
			(setq faces (cdr faces))))
	       faces)))))
  ;;
  ;; We use this for compatibility with a future Emacs.
  (or (fboundp 'with-temp-message)
      (defmacro with-temp-message (message &rest body)
	(` (let ((current-message (current-message)))
	     (unwind-protect
		 (progn (message (, message)) (,@ body))
	       (message current-message))))))
  ;;
  ;; We use this for compatibility with a future Emacs.
  (or (fboundp 'defcustom)
      (defmacro defcustom (symbol value doc &rest args) 
	(` (defvar (, symbol) (, value) (, doc))))))

;(defun fast-lock-submit-bug-report ()
;  "Submit via mail a bug report on fast-lock.el."
;  (interactive)
;  (let ((reporter-prompt-for-summary-p t))
;    (reporter-submit-bug-report "[e-mail]" "fast-lock 3.14"
;     '(fast-lock-cache-directories fast-lock-minimum-size
;       fast-lock-save-others fast-lock-save-events fast-lock-save-faces
;       fast-lock-verbose)
;     nil nil
;     (concat "Hi Si.,

(defvar fast-lock-cache-timestamp nil)	; For saving/reading.
(defvar fast-lock-cache-filename nil)	; For deleting.

;; User Variables:

(defcustom fast-lock-minimum-size 25600
  "*Minimum size of a buffer for cached fontification.
Only buffers more than this can have associated Font Lock cache files saved.
If nil, means cache files are never created.
If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE),
where MAJOR-MODE is a symbol or t (meaning the default).  For example:

(defcustom fast-lock-verbose font-lock-verbose
  "*If non-nil, means show status messages for cache processing.
If a number, only buffers greater than this size have processing messages."
  :type '(choice (const :tag "never" nil)
		 (other :tag "always" t)
		 (integer :tag "size"))
  :group 'fast-lock)

(defvar fast-lock-save-faces
  (when (save-match-data (string-match "XEmacs" (emacs-version)))
    ;; XEmacs uses extents for everything, so we have to pick the right ones.

  (let ((tpbuf (generate-new-buffer " *fast-lock*"))
	(verbose (if (numberp fast-lock-verbose)
		     (> (buffer-size) fast-lock-verbose)
		   fast-lock-verbose))
	(saved t))
    (with-temp-message
	(if verbose
	    (format "Saving %s font lock cache..." (buffer-name))
	  (current-message))
      (condition-case nil
	  (save-excursion
	    (print (list 'fast-lock-cache-data 3
			 (list 'quote timestamp)
			 (list 'quote font-lock-syntactic-keywords)
			 (list 'quote (fast-lock-get-syntactic-properties))
			 (list 'quote font-lock-keywords)
			 (list 'quote (fast-lock-get-face-properties)))
		   tpbuf)
	    (set-buffer tpbuf)
	    (write-region (point-min) (point-max) file nil 'quietly)
	    (setq fast-lock-cache-timestamp timestamp
		  fast-lock-cache-filename file))
	(error (setq saved 'error)) (quit (setq saved 'quit)))
      (kill-buffer tpbuf))
    (cond ((eq saved 'quit)
	   (message "Saving %s font lock cache...quit" (buffer-name)))
	  ((eq saved 'error)
	   (message "Saving %s font lock cache...failed" (buffer-name))))
    ;; We return non-nil regardless of whether a failure occurred.
    saved))

(defun fast-lock-cache-data (version timestamp
			     syntactic-keywords syntactic-properties

	    (buffer-modified-p)
	    (not (equal timestamp buf-timestamp))
	    (not (equal syntactic-keywords font-lock-syntactic-keywords))
	    (not (equal keywords font-lock-keywords)))
	(setq loaded nil)
      (with-temp-message
	  (if verbose
	      (format "Loading %s font lock cache..." (buffer-name))
	    (current-message))
	(condition-case nil
	    (fast-lock-add-properties syntactic-properties face-properties)
	  (error (setq loaded 'error)) (quit (setq loaded 'quit))))
      (cond ((eq loaded 'quit)
	     (message "Loading %s font lock cache...quit" (buffer-name)))
	    ((eq loaded 'error)
	     (message "Loading %s font lock cache...failed" (buffer-name)))))
    (setq font-lock-fontified (eq loaded t)
	  fast-lock-cache-timestamp (and (eq loaded t) timestamp))))

;; Text Properties Processing Functions:

(unless (fboundp 'font-lock-value-in-major-mode)
  (defun font-lock-value-in-major-mode (alist)
    (if (consp alist)
	(cdr (or (assq major-mode alist) (assq t alist)))
      alist)))

(unless (fboundp 'current-message)
  (defun current-message ()
    ""))

;; Install ourselves:

(add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file)
(add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer)