| 1 | ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage |
| 2 | |
| 3 | ;; Copyright (C) 2002-2013 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Jonathan Yavner <jyavner@engineer.com> |
| 6 | ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> |
| 7 | ;; Keywords: safety lisp utility |
| 8 | ;; Package: testcover |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or |
| 15 | ;; (at your option) any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | (require 'testcover) |
| 26 | |
| 27 | (defvar safe-functions) |
| 28 | |
| 29 | ;;;These forms are all considered safe |
| 30 | (defconst testcover-unsafep-safe |
| 31 | '(((lambda (x) (* x 2)) 14) |
| 32 | (apply 'cdr (mapcar (lambda (x) (car x)) y)) |
| 33 | (cond ((= x 4) 5) (t 27)) |
| 34 | (condition-case x (car y) (error (car x))) |
| 35 | (dolist (x y) (message "here: %s" x)) |
| 36 | (dotimes (x 14 (* x 2)) (message "here: %d" x)) |
| 37 | (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) |
| 38 | (let (x) (apply (lambda (x) (* x 2)) 14)) |
| 39 | (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) |
| 40 | (let ((x 1) (y 2)) (setq x (+ x y))) |
| 41 | (let ((x 1)) (let ((y (+ x 3))) (* x y))) |
| 42 | (let* nil (current-time)) |
| 43 | (let* ((x 1) (y (+ x 3))) (* x y)) |
| 44 | (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) |
| 45 | (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") |
| 46 | (setq buffer-display-count 14 mark-active t) |
| 47 | ;;This is not safe if you insert it into a buffer! |
| 48 | (propertize "x" 'display '(height (progn (delete-file "x") 1)))) |
| 49 | "List of forms that `unsafep' should decide are safe.") |
| 50 | |
| 51 | ;;;These forms are considered unsafe |
| 52 | (defconst testcover-unsafep-unsafe |
| 53 | '(( (add-to-list x y) |
| 54 | . (unquoted x)) |
| 55 | ( (add-to-list y x) |
| 56 | . (unquoted y)) |
| 57 | ( (add-to-list 'y x) |
| 58 | . (global-variable y)) |
| 59 | ( (not (delete-file "unsafep.el")) |
| 60 | . (function delete-file)) |
| 61 | ( (cond (t (aset local-abbrev-table 0 0))) |
| 62 | . (function aset)) |
| 63 | ( (cond (t (setq unsafep-vars ""))) |
| 64 | . (risky-local-variable unsafep-vars)) |
| 65 | ( (condition-case format-alist 1) |
| 66 | . (risky-local-variable format-alist)) |
| 67 | ( (condition-case x 1 (error (setq format-alist ""))) |
| 68 | . (risky-local-variable format-alist)) |
| 69 | ( (dolist (x (sort globalvar 'car)) (princ x)) |
| 70 | . (function sort)) |
| 71 | ( (dotimes (x 14) (delete-file "x")) |
| 72 | . (function delete-file)) |
| 73 | ( (let ((post-command-hook "/tmp/")) 1) |
| 74 | . (risky-local-variable post-command-hook)) |
| 75 | ( (let ((x (delete-file "x"))) 2) |
| 76 | . (function delete-file)) |
| 77 | ( (let (x) (add-to-list 'x (delete-file "x"))) |
| 78 | . (function delete-file)) |
| 79 | ( (let (x) (condition-case y (setq x 1 z 2))) |
| 80 | . (global-variable z)) |
| 81 | ( (let (x) (condition-case z 1 (error (delete-file "x")))) |
| 82 | . (function delete-file)) |
| 83 | ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) |
| 84 | . (function setcar)) |
| 85 | ( (let (y) (push (delete-file "x") y)) |
| 86 | . (function delete-file)) |
| 87 | ( (let* ((x 1)) (setq y 14)) |
| 88 | . (global-variable y)) |
| 89 | ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) |
| 90 | . (function kill-buffer)) |
| 91 | ( (mapcar x y) |
| 92 | . (unquoted x)) |
| 93 | ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) |
| 94 | . (function rename-file)) |
| 95 | ( (mapconcat x1 x2 " ") |
| 96 | . (unquoted x1)) |
| 97 | ( (pop format-alist) |
| 98 | . (risky-local-variable format-alist)) |
| 99 | ( (push 1 format-alist) |
| 100 | . (risky-local-variable format-alist)) |
| 101 | ( (setq buffer-display-count (delete-file "x")) |
| 102 | . (function delete-file)) |
| 103 | ;;These are actually safe (they signal errors) |
| 104 | ( (apply '(x) '(1 2 3)) |
| 105 | . (function (x))) |
| 106 | ( (let (((x))) 1) |
| 107 | . (variable (x))) |
| 108 | ( (let (1) 2) |
| 109 | . (variable 1)) |
| 110 | ) |
| 111 | "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") |
| 112 | |
| 113 | (declare-function unsafep-function "unsafep" (fun)) |
| 114 | |
| 115 | ;;;######################################################################### |
| 116 | (defun testcover-unsafep () |
| 117 | "Executes all unsafep tests and displays the coverage results." |
| 118 | (interactive) |
| 119 | (testcover-unmark-all "unsafep.el") |
| 120 | (testcover-start "unsafep.el") |
| 121 | (let (save-functions) |
| 122 | (dolist (x testcover-unsafep-safe) |
| 123 | (if (unsafep x) |
| 124 | (error "%S should be safe" x))) |
| 125 | (dolist (x testcover-unsafep-unsafe) |
| 126 | (if (not (equal (unsafep (car x)) (cdr x))) |
| 127 | (error "%S should be unsafe: %s" (car x) (cdr x)))) |
| 128 | (setq safe-functions t) |
| 129 | (if (or (unsafep '(delete-file "x")) |
| 130 | (unsafep-function 'delete-file)) |
| 131 | (error "safe-functions=t should allow delete-file")) |
| 132 | (setq safe-functions '(setcar)) |
| 133 | (if (unsafep '(setcar x 1)) |
| 134 | (error "safe-functions=(setcar) should allow setcar")) |
| 135 | (if (not (unsafep '(setcdr x 1))) |
| 136 | (error "safe-functions=(setcar) should not allow setcdr"))) |
| 137 | (testcover-mark-all "unsafep.el") |
| 138 | (testcover-end "unsafep.el") |
| 139 | (message "Done")) |
| 140 | |
| 141 | ;; testcover-unsafep.el ends here. |