Line data Source code
1 : ;;; warnings.el --- log and display warnings
2 :
3 : ;; Copyright (C) 2002-2017 Free Software Foundation, Inc.
4 :
5 : ;; Maintainer: emacs-devel@gnu.org
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 :
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 :
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 :
165 : (defun warning-numeric-level (level)
166 : "Return a numeric measure of the warning severity level LEVEL."
167 0 : (let* ((elt (assq level warning-levels))
168 0 : (link (memq elt warning-levels)))
169 0 : (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 0 : (let (some-match)
175 0 : (dolist (elt suppress-list)
176 0 : (if (symbolp type)
177 : ;; If TYPE is a symbol, the ELT must be (TYPE).
178 0 : (if (and (consp elt)
179 0 : (eq (car elt) type)
180 0 : (null (cdr elt)))
181 0 : (setq some-match t))
182 : ;; If TYPE is a list, ELT must match it or some initial segment of it.
183 0 : (let ((tem1 type)
184 0 : (tem2 elt)
185 : (match t))
186 : ;; Check elements of ELT until we run out of them.
187 0 : (while tem2
188 0 : (if (not (equal (car tem1) (car tem2)))
189 0 : (setq match nil))
190 0 : (setq tem1 (cdr tem1)
191 0 : tem2 (cdr tem2)))
192 : ;; If ELT is an initial segment of TYPE, MATCH is t now.
193 : ;; So set SOME-MATCH.
194 0 : (if match
195 0 : (setq some-match t)))))
196 : ;; If some element of SUPPRESS-LIST matched,
197 : ;; we return t.
198 0 : some-match))
199 :
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 0 : (if (not (or after-init-time noninteractive (daemonp)))
228 : ;; Ensure warnings that happen early in the startup sequence
229 : ;; are visible when startup completes (bug#20792).
230 0 : (delay-warning type message level buffer-name)
231 0 : (unless level
232 0 : (setq level :warning))
233 0 : (unless buffer-name
234 0 : (setq buffer-name "*Warnings*"))
235 0 : (if (assq level warning-level-aliases)
236 0 : (setq level (cdr (assq level warning-level-aliases))))
237 0 : (or (< (warning-numeric-level level)
238 0 : (warning-numeric-level warning-minimum-log-level))
239 0 : (warning-suppress-p type warning-suppress-log-types)
240 0 : (let* ((typename (if (consp type) (car type) type))
241 0 : (old (get-buffer buffer-name))
242 0 : (buffer (or old (get-buffer-create buffer-name)))
243 0 : (level-info (assq level warning-levels))
244 : start end)
245 0 : (with-current-buffer buffer
246 : ;; If we created the buffer, disable undo.
247 0 : (unless old
248 0 : (special-mode)
249 0 : (setq buffer-read-only t)
250 0 : (setq buffer-undo-list t))
251 0 : (goto-char (point-max))
252 0 : (when (and warning-series (symbolp warning-series))
253 0 : (setq warning-series
254 0 : (prog1 (point-marker)
255 0 : (unless (eq warning-series t)
256 0 : (funcall warning-series)))))
257 0 : (let ((inhibit-read-only t))
258 0 : (unless (bolp)
259 0 : (newline))
260 0 : (setq start (point))
261 0 : (if warning-prefix-function
262 0 : (setq level-info (funcall warning-prefix-function
263 0 : level level-info)))
264 0 : (insert (format (nth 1 level-info)
265 0 : (format warning-type-format typename))
266 0 : message)
267 0 : (newline)
268 0 : (when (and warning-fill-prefix (not (string-match "\n" message)))
269 0 : (let ((fill-prefix warning-fill-prefix)
270 : (fill-column 78))
271 0 : (fill-region start (point))))
272 0 : (setq end (point)))
273 0 : (when (and (markerp warning-series)
274 0 : (eq (marker-buffer warning-series) buffer))
275 0 : (goto-char warning-series)))
276 0 : (if (nth 2 level-info)
277 0 : (funcall (nth 2 level-info)))
278 0 : (cond (noninteractive
279 : ;; Noninteractively, take the text we inserted
280 : ;; in the warnings buffer and print it.
281 : ;; Do this unconditionally, since there is no way
282 : ;; to view logged messages unless we output them.
283 0 : (with-current-buffer buffer
284 0 : (save-excursion
285 : ;; Don't include the final newline in the arg
286 : ;; to `message', because it adds a newline.
287 0 : (goto-char end)
288 0 : (if (bolp)
289 0 : (forward-char -1))
290 0 : (message "%s" (buffer-substring start (point))))))
291 0 : ((and (daemonp) (null after-init-time))
292 : ;; Warnings assigned during daemon initialization go into
293 : ;; the messages buffer.
294 0 : (message "%s"
295 0 : (with-current-buffer buffer
296 0 : (save-excursion
297 0 : (goto-char end)
298 0 : (if (bolp)
299 0 : (forward-char -1))
300 0 : (buffer-substring start (point))))))
301 : (t
302 : ;; Interactively, decide whether the warning merits
303 : ;; immediate display.
304 0 : (or (< (warning-numeric-level level)
305 0 : (warning-numeric-level warning-minimum-level))
306 0 : (warning-suppress-p type warning-suppress-types)
307 0 : (let ((window (display-buffer buffer)))
308 0 : (when (and (markerp warning-series)
309 0 : (eq (marker-buffer warning-series) buffer))
310 0 : (set-window-start window warning-series))
311 0 : (sit-for 0)))))))))
312 :
313 : ;; Use \\<special-mode-map> so that help-enable-auto-load can do its thing.
314 : ;; Any keymap that is defined will do.
315 : ;;;###autoload
316 : (defun lwarn (type level message &rest args)
317 : "Display a warning message made from (format-message MESSAGE ARGS...).
318 : \\<special-mode-map>
319 : Aside from generating the message with `format-message',
320 : this is equivalent to `display-warning'.
321 :
322 : TYPE is the warning type: either a custom group name (a symbol),
323 : or a list of symbols whose first element is a custom group name.
324 : \(The rest of the symbols represent subcategories and
325 : can be whatever you like.)
326 :
327 : LEVEL should be either :debug, :warning, :error, or :emergency
328 : \(but see `warning-minimum-level' and `warning-minimum-log-level').
329 :
330 : :emergency -- a problem that will seriously impair Emacs operation soon
331 : if you do not attend to it promptly.
332 : :error -- invalid data or circumstances.
333 : :warning -- suspicious data or circumstances.
334 : :debug -- info for debugging only."
335 0 : (display-warning type (apply #'format-message message args) level))
336 :
337 : ;;;###autoload
338 : (defun warn (message &rest args)
339 : "Display a warning message made from (format-message MESSAGE ARGS...).
340 : Aside from generating the message with `format-message',
341 : this is equivalent to `display-warning', using
342 : `emacs' as the type and `:warning' as the level."
343 0 : (display-warning 'emacs (apply #'format-message message args)))
344 :
345 : (provide 'warnings)
346 :
347 : ;;; warnings.el ends here
|