unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob 8b43c6a87262756f8158648282608e35bc6783ec 16094 bytes (raw)
name: lisp/emacs-lisp/warnings.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
 
;;; warnings.el --- log and display warnings  -*- lexical-binding:t -*-

;; Copyright (C) 2002-2024 Free Software Foundation, Inc.

;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal

;; 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
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This file implements the entry points `warn', `lwarn'
;; and `display-warning'.

;;; Code:

(require 'icons)

(defgroup warnings nil
  "Log and display warnings."
  :version "22.1"
  :group 'lisp)

(defvar warning-levels
  '((:emergency "Emergency%s: " ding)
    (:error "Error%s: ")
    (:warning "Warning%s: ")
    (:debug "Debug%s: "))
  "List of severity level definitions for `display-warning'.
Each element looks like (LEVEL STRING FUNCTION) and
defines LEVEL as a severity level.  STRING specifies the
description of this level.  STRING should use `%s' to
specify where to put the warning type information,
or it can omit the `%s' so as not to include that information.

The optional FUNCTION, if non-nil, is a function to call
with no arguments, to get the user's attention.

The standard levels are :emergency, :error, :warning and :debug.
See `display-warning' for documentation of their meanings.
Level :debug is ignored by default (see `warning-minimum-level').")
(put 'warning-levels 'risky-local-variable t)

;; These are for compatibility with XEmacs.
;; I don't think there is any chance of designing meaningful criteria
;; to distinguish so many levels.
(defvar warning-level-aliases
  '((emergency . :emergency)
    (error . :error)
    (warning . :warning)
    (notice . :warning)
    (info . :warning)
    (critical . :emergency)
    (alarm . :emergency))
  "Alist of aliases for severity levels for `display-warning'.
Each element looks like (ALIAS . LEVEL) and defines ALIAS as
equivalent to LEVEL.  LEVEL must be defined in `warning-levels';
it may not itself be an alias.")
(make-obsolete-variable 'warning-level-aliases 'warning-levels "28.1")
\f
(define-obsolete-variable-alias 'display-warning-minimum-level
  'warning-minimum-level "28.1")
(defcustom warning-minimum-level :warning
  "Minimum severity level for displaying the warning buffer.
If a warning's severity level is lower than this,
the warning is logged in the warnings buffer, but the buffer
is not immediately displayed.  See also `warning-minimum-log-level'."
  :type '(choice (const :emergency) (const :error)
                 (const :warning) (const :debug))
  :version "22.1")

(define-obsolete-variable-alias 'log-warning-minimum-level
  'warning-minimum-log-level "28.1")
(defcustom warning-minimum-log-level :warning
  "Minimum severity level for logging a warning.
If a warning severity level is lower than this,
the warning is completely ignored.
Value must be lower or equal than `warning-minimum-level',
because warnings not logged aren't displayed either."
  :type '(choice (const :emergency) (const :error)
                 (const :warning) (const :debug))
  :version "22.1")

(defcustom warning-suppress-log-types nil
  "List of warning types that should not be logged.
If any element of this list matches the TYPE argument to `display-warning',
the warning is completely ignored.
The element must match the first elements of TYPE.
Thus, (foo bar) as an element matches (foo bar)
or (foo bar ANYTHING...) as TYPE.
If TYPE is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it."
  :type '(repeat (repeat symbol))
  :version "22.1")

;;;###autoload
(defcustom warning-suppress-types nil
  "List of warning types not to display immediately.
If any element of this list matches the TYPE argument to `display-warning',
the warning is logged nonetheless, but the warnings buffer is
not immediately displayed.
The element must match an initial segment of the list TYPE.
Thus, (foo bar) as an element matches (foo bar)
or (foo bar ANYTHING...) as TYPE.
If TYPE is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it.
See also `warning-suppress-log-types'."
  :type '(repeat (repeat symbol))
  :version "22.1")
\f
;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-prefix-function nil
  "Function to generate warning prefixes.
This function, if non-nil, is called with two arguments,
the severity level and its entry in `warning-levels',
and should return the entry that should actually be used.
The warnings buffer is current when this function is called
and the function can insert text in it.  This text becomes
the beginning of the warning.")

;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-series nil
  "Non-nil means treat multiple `display-warning' calls as a series.
A marker indicates a position in the warnings buffer
which is the start of the current series; it means that
additional warnings in the same buffer should not move point.
If t, the next warning begins a series (and stores a marker here).
A symbol with a function definition is like t, except
also call that function before the next warning.")
(put 'warning-series 'risky-local-variable t)

;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-fill-prefix nil
  "Non-nil means fill each warning text using this string as `fill-prefix'.")

;; I don't see why it can't just use the buffer-local fill-column,
;; but at least this is better than hard-coding 78.
(defvar warning-fill-column 78
  "Value to use for `fill-column' when filling warnings.")

;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-type-format (purecopy " (%s)")
  "Format for displaying the warning type in the warning message.
The result of formatting the type this way gets included in the
message under the control of the string in `warning-levels'.")
\f
(defun warning-numeric-level (level)
  "Return a numeric measure of the warning severity level LEVEL."
  (let* ((elt (assq level warning-levels))
	 (link (memq elt warning-levels)))
    (length link)))

(defun warning-suppress-p (type suppress-list)
  "Non-nil if a warning with type TYPE should be suppressed.
SUPPRESS-LIST is the list of kinds of warnings to suppress."
  (let (some-match)
    (dolist (elt suppress-list)
      (if (symbolp type)
	  ;; If TYPE is a symbol, the ELT must be (TYPE).
	  (if (and (consp elt)
		   (eq (car elt) type)
		   (null (cdr elt)))
	      (setq some-match t))
	;; If TYPE is a list, ELT must match it or some initial segment of it.
	(let ((tem1 type)
	      (tem2 elt)
	      (match t))
	  ;; Check elements of ELT until we run out of them.
	  (while tem2
	    (if (not (equal (car tem1) (car tem2)))
		(setq match nil))
	    (setq tem1 (cdr tem1)
		  tem2 (cdr tem2)))
	  ;; If ELT is an initial segment of TYPE, MATCH is t now.
	  ;; So set SOME-MATCH.
	  (if match
	      (setq some-match t)))))
    ;; If some element of SUPPRESS-LIST matched,
    ;; we return t.
    some-match))
\f
(define-icon warnings-suppress button
  `((emoji "⛔")
    ;; Many MS-Windows console fonts don't have good glyphs for U+25A0.
    (symbol ,(if (and (eq system-type 'windows-nt)
                      (null window-system))
                 " » "
               " ■ "))
    (text " stop "))
  "Suppress warnings."
  :version "29.1"
  :help-echo "Click to suppress this warning type")

(defun warnings-suppress (type)
  (pcase (car
          (read-multiple-choice
           (format "Suppress `%s' warnings? " type)
           `((?y ,(format "yes, ignore `%s' warnings completely" type))
             (?n "no, just disable showing them")
             (?q "quit and do nothing"))))
    (?y
     (customize-save-variable 'warning-suppress-log-types
                              (if (consp type)
                                  (cons type warning-suppress-log-types)
                                (cons (list type) warning-suppress-log-types))))
    (?n
     (customize-save-variable 'warning-suppress-types
                              (if (consp type)
                                  (cons type warning-suppress-types)
                                (cons (list type) warning-suppress-types))))
    (_ (message "Exiting"))))

;;;###autoload
(defun display-warning (type message &optional level buffer-name)
  "Display a warning message, MESSAGE.
TYPE is the warning type: either a custom group name (a symbol),
or a list of symbols whose first element is a custom group name.
\(The rest of the symbols represent subcategories, for warning purposes
only, and you can use whatever symbols you like.)

LEVEL should be either :debug, :warning, :error, or :emergency
\(but see `warning-minimum-level' and `warning-minimum-log-level').
Default is :warning.

:emergency -- a problem that will seriously impair Emacs operation soon
	      if you do not attend to it promptly.
:error     -- data or circumstances that are inherently wrong.
:warning   -- data or circumstances that are not inherently wrong,
	      but raise suspicion of a possible problem.
:debug     -- info for debugging only.

BUFFER-NAME, if specified, is the name of the buffer for logging
the warning.  By default, it is `*Warnings*'.  If this function
has to create the buffer, it disables undo in the buffer.

See the `warnings' custom group for user customization features.

See also `warning-series', `warning-prefix-function',
`warning-fill-prefix', and `warning-fill-column' for additional
programming features.

This will also display buttons allowing the user to permanently
disable automatic display of the warning or disable the warning
entirely by setting `warning-suppress-types' or
`warning-suppress-log-types' on their behalf."
  (if (not (or after-init-time noninteractive (daemonp)))
      ;; Ensure warnings that happen early in the startup sequence
      ;; are visible when startup completes (bug#20792).
      (delay-warning type message level buffer-name)
    (unless level
      (setq level :warning))
    (unless buffer-name
      (setq buffer-name "*Warnings*"))
    (with-suppressed-warnings ((obsolete warning-level-aliases))
      (when-let ((new (cdr (assq level warning-level-aliases))))
        (warn "Warning level `%s' is obsolete; use `%s' instead" level new)
        (setq level new)))
    (or (< (warning-numeric-level level)
	   (warning-numeric-level warning-minimum-log-level))
	(warning-suppress-p type warning-suppress-log-types)
	(let* ((typename (if (consp type) (car type) type))
	       (old (get-buffer buffer-name))
	       (buffer (or old (get-buffer-create buffer-name)))
	       (level-info (assq level warning-levels))
               ;; `newline' may be unbound during bootstrap.
               (newline (if (fboundp 'newline) #'newline
                          (lambda () (insert "\n"))))
	       start end)
	  (with-current-buffer buffer
	    ;; If we created the buffer, disable undo.
	    (unless old
	      (when (fboundp 'special-mode) ; Undefined during bootstrap.
                (special-mode))
	      (setq buffer-read-only t)
	      (setq buffer-undo-list t))
	    (goto-char (point-max))
	    (when (and warning-series (symbolp warning-series))
	      (setq warning-series
		    (prog1 (point-marker)
		      (unless (eq warning-series t)
			(funcall warning-series)))))
	    (let ((inhibit-read-only t))
	      (unless (bolp)
		(funcall newline))
	      (setq start (point))
              ;; Don't output the button when doing batch compilation
              ;; and similar.
              (unless (or noninteractive (eq type 'bytecomp))
                (insert (buttonize (icon-string 'warnings-suppress)
                                   #'warnings-suppress type)
                        " "))
	      (if warning-prefix-function
		  (setq level-info (funcall warning-prefix-function
					    level level-info)))
	      (insert (format (nth 1 level-info)
			      (format warning-type-format typename))
		      message)
              (funcall newline)
	      (when (and warning-fill-prefix
                         (not (string-search "\n" message))
                         (not noninteractive))
		(let ((fill-prefix warning-fill-prefix)
		      (fill-column warning-fill-column))
		  (fill-region start (point))))
	      (setq end (point)))
	    (when (and (markerp warning-series)
		       (eq (marker-buffer warning-series) buffer))
	      (goto-char warning-series)))
	  (if (nth 2 level-info)
	      (funcall (nth 2 level-info)))
	  (cond (noninteractive
		 ;; Noninteractively, take the text we inserted
		 ;; in the warnings buffer and print it.
		 ;; Do this unconditionally, since there is no way
		 ;; to view logged messages unless we output them.
		 (with-current-buffer buffer
		   (save-excursion
		     ;; Don't include the final newline in the arg
		     ;; to `message', because it adds a newline.
		     (goto-char end)
		     (if (bolp)
			 (forward-char -1))
		     (message "%s" (buffer-substring start (point))))))
		((and (daemonp) (null after-init-time))
		 ;; Warnings assigned during daemon initialization go into
		 ;; the messages buffer.
		 (message "%s"
			  (with-current-buffer buffer
			    (save-excursion
			      (goto-char end)
			      (if (bolp)
				  (forward-char -1))
			      (buffer-substring start (point))))))
		(t
		 ;; Interactively, decide whether the warning merits
		 ;; immediate display.
		 (or (< (warning-numeric-level level)
			(warning-numeric-level warning-minimum-level))
		     (warning-suppress-p type warning-suppress-types)
		     (let ((window (display-buffer buffer)))
		       (when (and (markerp warning-series)
				  (eq (marker-buffer warning-series) buffer))
			 (set-window-start window warning-series))
		       (sit-for 0)))))))))
\f
;; Use \\<special-mode-map> so that help-enable-autoload can do its thing.
;; Any keymap that is defined will do.
;;;###autoload
(defun lwarn (type level message &rest args)
  "Display a warning message made from (format-message MESSAGE ARGS...).
\\<special-mode-map>
Aside from generating the message with `format-message',
this is equivalent to `display-warning'.

TYPE is the warning type: either a custom group name (a symbol),
or a list of symbols whose first element is a custom group name.
\(The rest of the symbols represent subcategories and
can be whatever you like.)

LEVEL should be either :debug, :warning, :error, or :emergency
\(but see `warning-minimum-level' and `warning-minimum-log-level').

:emergency -- a problem that will seriously impair Emacs operation soon
	      if you do not attend to it promptly.
:error     -- invalid data or circumstances.
:warning   -- suspicious data or circumstances.
:debug     -- info for debugging only."
  (display-warning type (apply #'format-message message args) level))

;;;###autoload
(defun warn (message &rest args)
  "Display a warning message made from (format-message MESSAGE ARGS...).
Aside from generating the message with `format-message',
this is equivalent to `display-warning', using
`emacs' as the type and `:warning' as the level."
  (display-warning 'emacs (apply #'format-message message args)))

(provide 'warnings)

;;; warnings.el ends here

debug log:

solving 8b43c6a8726 ...
found 8b43c6a8726 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).