lisp/emacs-lisp/warnings.el

   1 ;;; warnings.el --- log and display warnings
   2
   3 ;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: internal
   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 3 of the License, or
  13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This file implements the entry points `warn', `lwarn'
  26 ;; and `display-warning'.
  27
  28 ;;; Code:
  29
  30 (defgroup warnings nil
  31   "Log and display warnings."
  32   :version "22.1"
  33   :group 'lisp)
  34
  35 (defvar warning-levels
  36   '((:emergency "Emergency%s: " ding)
  37     (:error "Error%s: ")
  38     (:warning "Warning%s: ")
  39     (:debug "Debug%s: "))
  40   "List of severity level definitions for `display-warning'.
  41 Each element looks like (LEVEL STRING FUNCTION) and
  42 defines LEVEL as a severity level.  STRING specifies the
  43 description of this level.  STRING should use `%s' to
  44 specify where to put the warning type information,
  45 or it can omit the `%s' so as not to include that information.
  46
  47 The optional FUNCTION, if non-nil, is a function to call
  48 with no arguments, to get the user's attention.
  49
  50 The standard levels are :emergency, :error, :warning and :debug.
  51 See `display-warning' for documentation of their meanings.
  52 Level :debug is ignored by default (see `warning-minimum-level').")
  53 (put 'warning-levels 'risky-local-variable t)
  54
  55 ;; These are for compatibility with XEmacs.
  56 ;; I don't think there is any chance of designing meaningful criteria
  57 ;; to distinguish so many levels.
  58 (defvar warning-level-aliases
  59   '((emergency . :emergency)
  60     (error . :error)
  61     (warning . :warning)
  62     (notice . :warning)
  63     (info . :warning)
  64     (critical . :emergency)
  65     (alarm . :emergency))
  66   "Alist of aliases for severity levels for `display-warning'.
  67 Each element looks like (ALIAS . LEVEL) and defines ALIAS as
  68 equivalent to LEVEL.  LEVEL must be defined in `warning-levels';
  69 it may not itself be an alias.")
  70 \f
  71 (defcustom warning-minimum-level :warning
  72   "Minimum severity level for displaying the warning buffer.
  73 If a warning's severity level is lower than this,
  74 the warning is logged in the warnings buffer, but the buffer
  75 is not immediately displayed.  See also `warning-minimum-log-level'."
  76   :group 'warnings
  77   :type '(choice (const :emergency) (const :error)
  78                  (const :warning) (const :debug))
  79   :version "22.1")
  80 (defvaralias 'display-warning-minimum-level 'warning-minimum-level)
  81
  82 (defcustom warning-minimum-log-level :warning
  83   "Minimum severity level for logging a warning.
  84 If a warning severity level is lower than this,
  85 the warning is completely ignored.
  86 Value must be lower or equal than `warning-minimum-level',
  87 because warnings not logged aren't displayed either."
  88   :group 'warnings
  89   :type '(choice (const :emergency) (const :error)
  90                  (const :warning) (const :debug))
  91   :version "22.1")
  92 (defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
  93
  94 (defcustom warning-suppress-log-types nil
  95   "List of warning types that should not be logged.
  96 If any element of this list matches the TYPE argument to `display-warning',
  97 the warning is completely ignored.
  98 The element must match the first elements of TYPE.
  99 Thus, (foo bar) as an element matches (foo bar)
 100 or (foo bar ANYTHING...) as TYPE.
 101 If TYPE is a symbol FOO, that is equivalent to the list (FOO),
 102 so only the element (FOO) will match it."
 103   :group 'warnings
 104   :type '(repeat (repeat symbol))
 105   :version "22.1")
 106
 107 (defcustom warning-suppress-types nil
 108   "List of warning types not to display immediately.
 109 If any element of this list matches the TYPE argument to `display-warning',
 110 the warning is logged nonetheless, but the warnings buffer is
 111 not immediately displayed.
 112 The element must match an initial segment of the list TYPE.
 113 Thus, (foo bar) as an element matches (foo bar)
 114 or (foo bar ANYTHING...) as TYPE.
 115 If TYPE is a symbol FOO, that is equivalent to the list (FOO),
 116 so only the element (FOO) will match it.
 117 See also `warning-suppress-log-types'."
 118   :group 'warnings
 119   :type '(repeat (repeat symbol))
 120   :version "22.1")
 121 \f
 122 ;; The autoload cookie is so that programs can bind this variable
 123 ;; safely, testing the existing value, before they call one of the
 124 ;; warnings functions.
 125 ;;;###autoload
 126 (defvar warning-prefix-function nil
 127   "Function to generate warning prefixes.
 128 This function, if non-nil, is called with two arguments,
 129 the severity level and its entry in `warning-levels',
 130 and should return the entry that should actually be used.
 131 The warnings buffer is current when this function is called
 132 and the function can insert text in it.  This text becomes
 133 the beginning of the warning.")
 134
 135 ;; The autoload cookie is so that programs can bind this variable
 136 ;; safely, testing the existing value, before they call one of the
 137 ;; warnings functions.
 138 ;;;###autoload
 139 (defvar warning-series nil
 140   "Non-nil means treat multiple `display-warning' calls as a series.
 141 A marker indicates a position in the warnings buffer
 142 which is the start of the current series; it means that
 143 additional warnings in the same buffer should not move point.
 144 If t, the next warning begins a series (and stores a marker here).
 145 A symbol with a function definition is like t, except
 146 also call that function before the next warning.")
 147 (put 'warning-series 'risky-local-variable t)
 148
 149 ;; The autoload cookie is so that programs can bind this variable
 150 ;; safely, testing the existing value, before they call one of the
 151 ;; warnings functions.
 152 ;;;###autoload
 153 (defvar warning-fill-prefix nil
 154   "Non-nil means fill each warning text using this string as `fill-prefix'.")
 155
 156 ;; The autoload cookie is so that programs can bind this variable
 157 ;; safely, testing the existing value, before they call one of the
 158 ;; warnings functions.
 159 ;;;###autoload
 160 (defvar warning-type-format (purecopy " (%s)")
 161   "Format for displaying the warning type in the warning message.
 162 The result of formatting the type this way gets included in the
 163 message under the control of the string in `warning-levels'.")
 164 \f
 165 (defun warning-numeric-level (level)
 166   "Return a numeric measure of the warning severity level LEVEL."
 167   (let* ((elt (assq level warning-levels))
 168          (link (memq elt warning-levels)))
 169     (length link)))
 170
 171 (defun warning-suppress-p (type suppress-list)
 172   "Non-nil if a warning with type TYPE should be suppressed.
 173 SUPPRESS-LIST is the list of kinds of warnings to suppress."
 174   (let (some-match)
 175     (dolist (elt suppress-list)
 176       (if (symbolp type)
 177           ;; If TYPE is a symbol, the ELT must be (TYPE).
 178           (if (and (consp elt)
 179                    (eq (car elt) type)
 180                    (null (cdr elt)))
 181               (setq some-match t))
 182         ;; If TYPE is a list, ELT must match it or some initial segment of it.
 183         (let ((tem1 type)
 184               (tem2 elt)
 185               (match t))
 186           ;; Check elements of ELT until we run out of them.
 187           (while tem2
 188             (if (not (equal (car tem1) (car tem2)))
 189                 (setq match nil))
 190             (setq tem1 (cdr tem1)
 191                   tem2 (cdr tem2)))
 192           ;; If ELT is an initial segment of TYPE, MATCH is t now.
 193           ;; So set SOME-MATCH.
 194           (if match
 195               (setq some-match t)))))
 196     ;; If some element of SUPPRESS-LIST matched,
 197     ;; we return t.
 198     some-match))
 199 \f
 200 ;;;###autoload
 201 (defun display-warning (type message &optional level buffer-name)
 202   "Display a warning message, MESSAGE.
 203 TYPE is the warning type: either a custom group name (a symbol),
 204 or a list of symbols whose first element is a custom group name.
 205 \(The rest of the symbols represent subcategories, for warning purposes
 206 only, and you can use whatever symbols you like.)
 207
 208 LEVEL should be either :debug, :warning, :error, or :emergency
 209 \(but see `warning-minimum-level' and `warning-minimum-log-level').
 210 Default is :warning.
 211
 212 :emergency -- a problem that will seriously impair Emacs operation soon
 213               if you do not attend to it promptly.
 214 :error     -- data or circumstances that are inherently wrong.
 215 :warning   -- data or circumstances that are not inherently wrong,
 216               but raise suspicion of a possible problem.
 217 :debug     -- info for debugging only.
 218
 219 BUFFER-NAME, if specified, is the name of the buffer for logging
 220 the warning.  By default, it is `*Warnings*'.  If this function
 221 has to create the buffer, it disables undo in the buffer.
 222
 223 See the `warnings' custom group for user customization features.
 224
 225 See also `warning-series', `warning-prefix-function' and
 226 `warning-fill-prefix' for additional programming features."
 227   (unless level
 228     (setq level :warning))
 229   (unless buffer-name
 230     (setq buffer-name "*Warnings*"))
 231   (if (assq level warning-level-aliases)
 232       (setq level (cdr (assq level warning-level-aliases))))
 233   (or (< (warning-numeric-level level)
 234          (warning-numeric-level warning-minimum-log-level))
 235       (warning-suppress-p type warning-suppress-log-types)
 236       (let* ((typename (if (consp type) (car type) type))
 237              (old (get-buffer buffer-name))
 238              (buffer (or old (get-buffer-create buffer-name)))
 239              (level-info (assq level warning-levels))
 240              start end)
 241         (with-current-buffer buffer
 242           ;; If we created the buffer, disable undo.
 243           (unless old
 244             (special-mode)
 245             (setq buffer-read-only t)
 246             (setq buffer-undo-list t))
 247           (goto-char (point-max))
 248           (when (and warning-series (symbolp warning-series))
 249             (setq warning-series
 250                   (prog1 (point-marker)
 251                     (unless (eq warning-series t)
 252                       (funcall warning-series)))))
 253           (let ((inhibit-read-only t))
 254             (unless (bolp)
 255               (newline))
 256             (setq start (point))
 257             (if warning-prefix-function
 258                 (setq level-info (funcall warning-prefix-function
 259                                           level level-info)))
 260             (insert (format (nth 1 level-info)
 261                             (format warning-type-format typename))
 262                     message)
 263             (newline)
 264             (when (and warning-fill-prefix (not (string-match "\n" message)))
 265               (let ((fill-prefix warning-fill-prefix)
 266                     (fill-column 78))
 267                 (fill-region start (point))))
 268             (setq end (point)))
 269           (when (and (markerp warning-series)
 270                      (eq (marker-buffer warning-series) buffer))
 271             (goto-char warning-series)))
 272         (if (nth 2 level-info)
 273             (funcall (nth 2 level-info)))
 274         (cond (noninteractive
 275                ;; Noninteractively, take the text we inserted
 276                ;; in the warnings buffer and print it.
 277                ;; Do this unconditionally, since there is no way
 278                ;; to view logged messages unless we output them.
 279                (with-current-buffer buffer
 280                  (save-excursion
 281                    ;; Don't include the final newline in the arg
 282                    ;; to `message', because it adds a newline.
 283                    (goto-char end)
 284                    (if (bolp)
 285                        (forward-char -1))
 286                    (message "%s" (buffer-substring start (point))))))
 287               ((and (daemonp) (null after-init-time))
 288                ;; Warnings assigned during daemon initialization go into
 289                ;; the messages buffer.
 290                (message "%s"
 291                         (with-current-buffer buffer
 292                           (save-excursion
 293                             (goto-char end)
 294                             (if (bolp)
 295                                 (forward-char -1))
 296                             (buffer-substring start (point))))))
 297               (t
 298                ;; Interactively, decide whether the warning merits
 299                ;; immediate display.
 300                (or (< (warning-numeric-level level)
 301                       (warning-numeric-level warning-minimum-level))
 302                    (warning-suppress-p type warning-suppress-types)
 303                    (let ((window (display-buffer buffer)))
 304                      (when (and (markerp warning-series)
 305                                 (eq (marker-buffer warning-series) buffer))
 306                        (set-window-start window warning-series))
 307                      (sit-for 0))))))))
 308 \f
 309 ;;;###autoload
 310 (defun lwarn (type level message &rest args)
 311   "Display a warning message made from (format MESSAGE ARGS...).
 312 Aside from generating the message with `format',
 313 this is equivalent to `display-warning'.
 314
 315 TYPE is the warning type: either a custom group name (a symbol),
 316 or a list of symbols whose first element is a custom group name.
 317 \(The rest of the symbols represent subcategories and
 318 can be whatever you like.)
 319
 320 LEVEL should be either :debug, :warning, :error, or :emergency
 321 \(but see `warning-minimum-level' and `warning-minimum-log-level').
 322
 323 :emergency -- a problem that will seriously impair Emacs operation soon
 324               if you do not attend to it promptly.
 325 :error     -- invalid data or circumstances.
 326 :warning   -- suspicious data or circumstances.
 327 :debug     -- info for debugging only."
 328   (display-warning type (apply 'format message args) level))
 329
 330 ;;;###autoload
 331 (defun warn (message &rest args)
 332   "Display a warning message made from (format MESSAGE ARGS...).
 333 Aside from generating the message with `format',
 334 this is equivalent to `display-warning', using
 335 `emacs' as the type and `:warning' as the level."
 336   (display-warning 'emacs (apply 'format message args)))
 337
 338 (provide 'warnings)
 339
 340 ;;; warnings.el ends here