diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 21 | ||||
| -rw-r--r-- | lisp/emacs-lisp/tcover-unsafep.el | 140 | ||||
| -rw-r--r-- | lisp/emacs-lisp/warnings.el | 30 |
3 files changed, 40 insertions, 151 deletions
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 4825b5c5e6c..772c907c284 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.8.0 +;; Version: 1.10.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -573,7 +573,8 @@ Meant as a value for `eldoc-documentation-strategy'." (let* ((callback (eldoc--make-callback :enthusiast)) (str (funcall f callback))) (if (stringp str) (funcall callback str)) - nil)))) + nil))) + t) ;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't ;; make the "old" `eldoc-documentation-function' point to the new @@ -739,14 +740,14 @@ should endeavour to display the docstrings eventually produced." (when (and string (cl-loop for (p) in docs-registered never (< p pos))) (setq docs-registered '()) - (register-doc pos string plist) - (when (and (timerp eldoc--enthusiasm-curbing-timer) - (memq eldoc--enthusiasm-curbing-timer - timer-list)) - (cancel-timer eldoc--enthusiasm-curbing-timer)) - (setq eldoc--enthusiasm-curbing-timer - (run-at-time (unless (zerop pos) 0.3) - nil #'display-doc))) + (register-doc pos string plist)) + (when (and (timerp eldoc--enthusiasm-curbing-timer) + (memq eldoc--enthusiasm-curbing-timer + timer-list)) + (cancel-timer eldoc--enthusiasm-curbing-timer)) + (setq eldoc--enthusiasm-curbing-timer + (run-at-time (unless (zerop pos) 0.3) + nil #'display-doc)) t)) (:patient (cl-incf want) diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el deleted file mode 100644 index 108dee3d95d..00000000000 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ /dev/null @@ -1,140 +0,0 @@ -;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage - -;; Copyright (C) 2002-2020 Free Software Foundation, Inc. - -;; Author: Jonathan Yavner <jyavner@member.fsf.org> -;; Keywords: safety lisp utility -;; Package: testcover - -;; 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/>. - -(require 'testcover) - -(defvar safe-functions) - -;;;These forms are all considered safe -(defconst testcover-unsafep-safe - '(((lambda (x) (* x 2)) 14) - (apply 'cdr (mapcar (lambda (x) (car x)) y)) - (cond ((= x 4) 5) (t 27)) - (condition-case x (car y) (error (car x))) - (dolist (x y) (message "here: %s" x)) - (dotimes (x 14 (* x 2)) (message "here: %d" x)) - (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) - (let (x) (apply (lambda (x) (* x 2)) 14)) - (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) - (let ((x 1) (y 2)) (setq x (+ x y))) - (let ((x 1)) (let ((y (+ x 3))) (* x y))) - (let* nil (current-time)) - (let* ((x 1) (y (+ x 3))) (* x y)) - (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) - (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") - (setq buffer-display-count 14 mark-active t) - ;;This is not safe if you insert it into a buffer! - (propertize "x" 'display '(height (progn (delete-file "x") 1)))) - "List of forms that `unsafep' should decide are safe.") - -;;;These forms are considered unsafe -(defconst testcover-unsafep-unsafe - '(( (add-to-list x y) - . (unquoted x)) - ( (add-to-list y x) - . (unquoted y)) - ( (add-to-list 'y x) - . (global-variable y)) - ( (not (delete-file "unsafep.el")) - . (function delete-file)) - ( (cond (t (aset local-abbrev-table 0 0))) - . (function aset)) - ( (cond (t (setq unsafep-vars ""))) - . (risky-local-variable unsafep-vars)) - ( (condition-case format-alist 1) - . (risky-local-variable format-alist)) - ( (condition-case x 1 (error (setq format-alist ""))) - . (risky-local-variable format-alist)) - ( (dolist (x (sort globalvar 'car)) (princ x)) - . (function sort)) - ( (dotimes (x 14) (delete-file "x")) - . (function delete-file)) - ( (let ((post-command-hook "/tmp/")) 1) - . (risky-local-variable post-command-hook)) - ( (let ((x (delete-file "x"))) 2) - . (function delete-file)) - ( (let (x) (add-to-list 'x (delete-file "x"))) - . (function delete-file)) - ( (let (x) (condition-case y (setq x 1 z 2))) - . (global-variable z)) - ( (let (x) (condition-case z 1 (error (delete-file "x")))) - . (function delete-file)) - ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) - . (function setcar)) - ( (let (y) (push (delete-file "x") y)) - . (function delete-file)) - ( (let* ((x 1)) (setq y 14)) - . (global-variable y)) - ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) - . (function kill-buffer)) - ( (mapcar x y) - . (unquoted x)) - ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) - . (function rename-file)) - ( (mapconcat x1 x2 " ") - . (unquoted x1)) - ( (pop format-alist) - . (risky-local-variable format-alist)) - ( (push 1 format-alist) - . (risky-local-variable format-alist)) - ( (setq buffer-display-count (delete-file "x")) - . (function delete-file)) - ;;These are actually safe (they signal errors) - ( (apply '(x) '(1 2 3)) - . (function (x))) - ( (let (((x))) 1) - . (variable (x))) - ( (let (1) 2) - . (variable 1)) - ) - "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") - -(declare-function unsafep-function "unsafep" (fun)) - -;;;######################################################################### -(defun testcover-unsafep () - "Executes all unsafep tests and displays the coverage results." - (interactive) - (testcover-unmark-all "unsafep.el") - (testcover-start "unsafep.el") - (let (save-functions) - (dolist (x testcover-unsafep-safe) - (if (unsafep x) - (error "%S should be safe" x))) - (dolist (x testcover-unsafep-unsafe) - (if (not (equal (unsafep (car x)) (cdr x))) - (error "%S should be unsafe: %s" (car x) (cdr x)))) - (setq safe-functions t) - (if (or (unsafep '(delete-file "x")) - (unsafep-function 'delete-file)) - (error "safe-functions=t should allow delete-file")) - (setq safe-functions '(setcar)) - (if (unsafep '(setcar x 1)) - (error "safe-functions=(setcar) should allow setcar")) - (if (not (unsafep '(setcdr x 1))) - (error "safe-functions=(setcar) should not allow setcdr"))) - (testcover-mark-all "unsafep.el") - (testcover-end "unsafep.el") - (message "Done")) - -;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index b1fd6ed80ad..3a568cb834c 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -200,6 +200,21 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." ;; we return t. some-match)) +(define-button-type 'warning-suppress-warning + 'action #'warning-suppress-action + 'help-echo "mouse-2, RET: Don't display this warning automatically") +(defun warning-suppress-action (button) + (customize-save-variable 'warning-suppress-types + (cons (list (button-get button 'warning-type)) + warning-suppress-types))) +(define-button-type 'warning-suppress-log-warning + 'action #'warning-suppress-log-action + 'help-echo "mouse-2, RET: Don't log this warning") +(defun warning-suppress-log-action (button) + (customize-save-variable 'warning-suppress-log-types + (cons (list (button-get button 'warning-type)) + warning-suppress-types))) + ;;;###autoload (defun display-warning (type message &optional level buffer-name) "Display a warning message, MESSAGE. @@ -227,7 +242,12 @@ 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." +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). @@ -272,6 +292,14 @@ programming features." (insert (format (nth 1 level-info) (format warning-type-format typename)) message) + (insert " ") + (insert-button "Disable showing" + 'type 'warning-suppress-warning + 'warning-type type) + (insert " ") + (insert-button "Disable logging" + 'type 'warning-suppress-log-warning + 'warning-type type) (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) |