Mercurial > emacs
diff lisp/emacs-lisp/tcover-unsafep.el @ 53440:296b4cb363cc
emacs-lisp/tcover-unsafep.el, emacs-lisp/tcover-ses.el: Renamed
from testcover-unsafep.el and testcover-ses.el to avoid file-name
clashes on 8+3 DOS filesystems.
author | Eli Zaretskii <eliz@is.elta.co.il> |
---|---|
date | Tue, 30 Dec 2003 08:24:49 +0000 |
parents | |
children | 18a818a2ee7c |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/tcover-unsafep.el Tue Dec 30 08:24:49 2003 +0000 @@ -0,0 +1,140 @@ +;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Jonathan Yavner <jyavner@engineer.com> +;; Maintainer: Jonathan Yavner <jyavner@engineer.com> +;; Keywords: safety lisp utility + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(require 'testcover) + +;;;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 actualy 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.") + + +;;;######################################################################### +(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")) + +;;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 +;; testcover-unsafep.el ends here.