Commit | Line | Data |
---|---|---|
7ed9159a JY |
1 | ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2002-2012 Free Software Foundation, Inc. |
7ed9159a JY |
4 | |
5 | ;; Author: Jonathan Yavner <jyavner@engineer.com> | |
6 | ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> | |
7 | ;; Keywords: safety lisp utility | |
bd78fa1d | 8 | ;; Package: testcover |
7ed9159a JY |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
d6cba7ae | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
7ed9159a | 13 | ;; it under the terms of the GNU General Public License as published by |
d6cba7ae GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
7ed9159a JY |
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 | |
d6cba7ae | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
7ed9159a JY |
24 | |
25 | (require 'testcover) | |
26 | ||
dfc9a078 JB |
27 | (defvar safe-functions) |
28 | ||
7ed9159a JY |
29 | ;;;These forms are all considered safe |
30 | (defconst testcover-unsafep-safe | |
31 | '(((lambda (x) (* x 2)) 14) | |
4f91a816 | 32 | (apply 'cdr (mapcar (lambda (x) (car x)) y)) |
7ed9159a JY |
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))) | |
4f91a816 | 38 | (let (x) (apply (lambda (x) (* x 2)) 14)) |
7ed9159a JY |
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)) | |
4f91a816 | 93 | ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) |
7ed9159a JY |
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)) | |
58179cce | 103 | ;;These are actually safe (they signal errors) |
7ed9159a JY |
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 | ||
6d00e226 | 113 | (declare-function unsafep-function "unsafep" (fun)) |
7ed9159a JY |
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. |