From: Eli Zaretskii Date: Tue, 30 Dec 2003 08:26:00 +0000 (+0000) Subject: emacs-lisp/tcover-unsafep.el, emacs-lisp/tcover-ses.el: Renamed X-Git-Tag: ttn-vms-21-2-B4~8052 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ab5136eab7bceb5de1f81eb919d03465c81df5c1;p=emacs.git 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. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c6694b0ad03..a5bdef47c48 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2003-12-29 Eli Zaretskii + + * 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. + 2003-12-29 Richard M. Stallman * textmodes/flyspell.el (mail-mode-flyspell-verify): diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el new file mode 100644 index 00000000000..48ec9fa64da --- /dev/null +++ b/lisp/emacs-lisp/tcover-ses.el @@ -0,0 +1,712 @@ +;;;; testcover-ses.el -- Example use of `testcover' to test "SES" + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Jonathan Yavner +;; Maintainer: Jonathan Yavner +;; Keywords: spreadsheet lisp utility + +;; 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) + +;;;Here are some macros that exercise SES. Set `pause' to t if you want the +;;;macros to pause after each step. +(let* ((pause nil) + (x (if pause "q" "")) + (y "ses-test.ses\r<")) + ;;Fiddle with the existing spreadsheet + (fset 'ses-exercise-example + (concat "" data-directory "ses-example.ses\r<" + x "10" + x " " + x "" + x "pses-center\r" + x "p\r" + x "\t\t" + x "\r A9 B9\r" + x "" + x "\r 2\r" + x "" + x "50\r" + x "4" + x " " + x "" + x "(+ o\0" + x "-1o \r" + x "" + x)) + ;;Create a new spreadsheet + (fset 'ses-exercise-new + (concat y + x "\"%.8g\"\r" + x "2\r" + x "" + x "" + x "2" + x "\"Header\r" + x "(sqrt 1\r" + x "pses-center\r" + x "\t" + x "(+ A2 A3\r" + x "(* B2 A3\r" + x "2" + x "\rB3\r" + x "" + x)) + ;;Basic cell display + (fset 'ses-exercise-display + (concat y ":(revert-buffer t t)\r" + x "" + x "\"Very long\r" + x "w3\r" + x "w3\r" + x "(/ 1 0\r" + x "234567\r" + x "5w" + x "\t1\r" + x "" + x "234567\r" + x "\t" + x "" + x "345678\r" + x "3w" + x "\0>" + x "" + x "" + x "" + x "" + x "" + x "" + x "" + x "1\r" + x "" + x "" + x "\"1234567-1234567-1234567\r" + x "123\r" + x "2" + x "\"1234567-1234567-1234567\r" + x "123\r" + x "w8\r" + x "\"1234567\r" + x "w5\r" + x)) + ;;Cell formulas + (fset 'ses-exercise-formulas + (concat y ":(revert-buffer t t)\r" + x "\t\t" + x "\t" + x "(* B1 B2 D1\r" + x "(* B2 B3\r" + x "(apply '+ (ses-range B1 B3)\r" + x "(apply 'ses+ (ses-range B1 B3)\r" + x "(apply 'ses+ (ses-range A2 A3)\r" + x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r" + x "(apply 'concat (reverse (ses-range A3 D3))\r" + x "(* (+ A2 A3) (ses+ B2 B3)\r" + x "" + x "2" + x "5\t" + x "(apply 'ses+ (ses-range E1 E2)\r" + x "(apply 'ses+ (ses-range A5 B5)\r" + x "(apply 'ses+ (ses-range E1 F1)\r" + x "(apply 'ses+ (ses-range D1 E1)\r" + x "\t" + x "(ses-average (ses-range A2 A5)\r" + x "(apply 'ses+ (ses-range A5 A6)\r" + x "k" + x " " + x "" + x "2" + x "3 " + x "o" + x "2o" + x "3k" + x "(ses-average (ses-range B3 E3)\r" + x "k" + x "12345678\r" + x)) + ;;Recalculating and reconstructing + (fset 'ses-exercise-recalc + (concat y ":(revert-buffer t t)\r" + x " " + x "\t\t" + x "" + x "(/ 1 0\r" + x "" + x "\n" + x "" + x "\"%.6g\"\r" + x " " + x ">nw" + x "\0>xdelete-region\r" + x " " + x "8" + x "\0>xdelete-region\r" + x " " + x "" + x " k" + x " " + x "\"Very long\r" + x "" + x "\r\r" + x "" + x "o" + x "" + x "\"Very long2\r" + x "o" + x "" + x "\rC3\r" + x "\rC2\r" + x "\0" + x "\rC4\r" + x "\rC2\r" + x "\0" + x "" + x "xses-mode\r" + x "<" + x "2k" + x)) + ;;Header line + (fset 'ses-exercise-header-row + (concat y ":(revert-buffer t t)\r" + x "<" + x ">" + x "6<" + x ">" + x "7<" + x ">" + x "8<" + x "2<" + x ">" + x "3w" + x "10<" + x ">" + x "2 " + x)) + ;;Detecting unsafe formulas and printers + (fset 'ses-exercise-unsafe + (concat y ":(revert-buffer t t)\r" + x "p(lambda (x) (delete-file x))\rn" + x "p(lambda (x) (delete-file \"ses-nothing\"))\ry" + x "\0n" + x "(delete-file \"x\"\rn" + x "(delete-file \"ses-nothing\"\ry" + x "\0n" + x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry" + x "\0n" + x)) + ;;Inserting and deleting rows + (fset 'ses-exercise-rows + (concat y ":(revert-buffer t t)\r" + x "" + x "\"%s=\"\r" + x "20" + x "p\"%s+\"\r" + x "" + x "123456789\r" + x "\021" + x "" + x " " + x "(not B25\r" + x "k" + x "jA3\r" + x "19 " + x " " + x "100" ;Make this approx your CPU speed in MHz + x)) + ;;Inserting and deleting columns + (fset 'ses-exercise-columns + (concat y ":(revert-buffer t t)\r" + x "\"%s@\"\r" + x "o" + x "" + x "o" + x " " + x "k" + x "w8\r" + x "p\"%.7s*\"\r" + x "o" + x "" + x "2o" + x "3k" + x "\"%.6g\"\r" + x "26o" + x "\026\t" + x "26o" + x "0\r" + x "26\t" + x "400" + x "50k" + x "\0D" + x)) + (fset 'ses-exercise-editing + (concat y ":(revert-buffer t t)\r" + x "1\r" + x "('x\r" + x "" + x "" + x "\r\r" + x "w9\r" + x "\r.5\r" + x "\r 10\r" + x "w12\r" + x "\r'\r" + x "\r\r" + x "jA4\r" + x "(+ A2 100\r" + x "3\r" + x "jB1\r" + x "(not A1\r" + x "\"Very long\r" + x "" + x "h" + x "H" + x "" + x ">\t" + x "" + x "" + x "2" + x "" + x "o" + x "h" + x "\0" + x "\"Also very long\r" + x "H" + x "\0'\r" + x "'Trial\r" + x "'qwerty\r" + x "(concat o<\0" + x "-1o\r" + x "(apply '+ o<\0-1o\r" + x "2" + x "-2" + x "-2" + x "2" + x " " + x "H" + x "\0" + x "\"Another long one\r" + x "H" + x "" + x "<" + x "" + x ">" + x "\0" + x)) + ;;Sorting of columns + (fset 'ses-exercise-sort-column + (concat y ":(revert-buffer t t)\r" + x "\"Very long\r" + x "99\r" + x "o13\r" + x "(+ A3 B3\r" + x "7\r8\r(* A4 B4\r" + x "\0A\r" + x "\0B\r" + x "\0C\r" + x "o" + x "\0C\r" + x)) + ;;Simple cell printers + (fset 'ses-exercise-cell-printers + (concat y ":(revert-buffer t t)\r" + x "\"4\t76\r" + x "\"4\n7\r" + x "p\"{%S}\"\r" + x "p(\"[%s]\")\r" + x "p(\"<%s>\")\r" + x "\0" + x "p\r" + x "pnil\r" + x "pses-dashfill\r" + x "48\r" + x "\t" + x "\0p\r" + x "p\r" + x "pses-dashfill\r" + x "\0pnil\r" + x "5\r" + x "pses-center\r" + x "\"%s\"\r" + x "w8\r" + x "p\r" + x "p\"%.7g@\"\r" + x "\r" + x "\"%.6g#\"\r" + x "\"%.6g.\"\r" + x "\"%.6g.\"\r" + x "pidentity\r" + x "6\r" + x "\"UPCASE\r" + x "pdowncase\r" + x "(* 3 4\r" + x "p(lambda (x) '(\"Hi\"))\r" + x "p(lambda (x) '(\"Bye\"))\r" + x)) + ;;Spanning cell printers + (fset 'ses-exercise-spanning-printers + (concat y ":(revert-buffer t t)\r" + x "p\"%.6g*\"\r" + x "pses-dashfill-span\r" + x "5\r" + x "pses-tildefill-span\r" + x "\"4\r" + x "p\"$%s\"\r" + x "p(\"$%s\")\r" + x "8\r" + x "p(\"!%s!\")\r" + x "\t\"12345678\r" + x "pses-dashfill-span\r" + x "\"23456789\r" + x "\t" + x "(not t\r" + x "w6\r" + x "\"5\r" + x "o" + x "k" + x "k" + x "\t" + x "" + x "o" + x "2k" + x "k" + x)) + ;;Cut/copy/paste - within same buffer + (fset 'ses-exercise-paste-1buf + (concat y ":(revert-buffer t t)\r" + x "\0w" + x "" + x "o" + x "\"middle\r" + x "\0" + x "w" + x "\0" + x "w" + x "" + x "" + x "2y" + x "y" + x "y" + x ">" + x "y" + x ">y" + x "<" + x "p\"<%s>\"\r" + x "pses-dashfill\r" + x "\0" + x "" + x "" + x "y" + x "\r\0w" + x "\r" + x "3(+ G2 H1\r" + x "\0w" + x ">" + x "" + x "8(ses-average (ses-range G2 H2)\r" + x "\0k" + x "7" + x "" + x "(ses-average (ses-range E7 E9)\r" + x "\0 " + x "" + x "(ses-average (ses-range E7 F7)\r" + x "\0k" + x "" + x "(ses-average (ses-range D6 E6)\r" + x "\0k" + x "" + x "2" + x "\"Line A\r" + x "pses-tildefill-span\r" + x "\"Subline A(1)\r" + x "pses-dashfill-span\r" + x "\0w" + x "" + x "" + x "\0w" + x "" + x)) + ;;Cut/copy/paste - between two buffers + (fset 'ses-exercise-paste-2buf + (concat y ":(revert-buffer t t)\r" + x "o\"middle\r\0" + x "" + x "4bses-test.txt\r" + x " " + x "\"xxx\0" + x "wo" + x "" + x "" + x "o\"\0" + x "wo" + x "o123.45\0" + x "o" + x "o1 \0" + x "o" + x ">y" + x "o symb\0" + x "oy2y" + x "o1\t\0" + x "o" + x "w9\np\"<%s>\"\n" + x "o\n2\t\"3\nxxx\t5\n\0" + x "oy" + x)) + ;;Export text, import it back + (fset 'ses-exercise-import-export + (concat y ":(revert-buffer t t)\r" + x "\0xt" + x "4bses-test.txt\r" + x "\n-1o" + x "xTo-1o" + x "'crunch\r" + x "pses-center-span\r" + x "\0xT" + x "o\n-1o" + x "\0y" + x "\0xt" + x "\0y" + x "12345678\r" + x "'bunch\r" + x "\0xtxT" + x))) + +(defun ses-exercise-macros () + "Executes all SES coverage-test macros." + (dolist (x '(ses-exercise-example + ses-exercise-new + ses-exercise-display + ses-exercise-formulas + ses-exercise-recalc + ses-exercise-header-row + ses-exercise-unsafe + ses-exercise-rows + ses-exercise-columns + ses-exercise-editing + ses-exercise-sort-column + ses-exercise-cell-printers + ses-exercise-spanning-printers + ses-exercise-paste-1buf + ses-exercise-paste-2buf + ses-exercise-import-export)) + (message "" x) + (execute-kbd-macro x))) + +(defun ses-exercise-signals () + "Exercise code paths that lead to error signals, other than those for +spreadsheet files with invalid formatting." + (message "") + (switch-to-buffer "ses-test.ses") + (deactivate-mark) + (ses-jump 'A1) + (ses-set-curcell) + (dolist (x '((ses-column-widths 14) + (ses-column-printers "%s") + (ses-column-printers ["%s" "%s" "%s"]) ;Should be two + (ses-column-widths [14]) + (ses-delete-column -99) + (ses-delete-column 2) + (ses-delete-row -1) + (ses-goto-data 'hogwash) + (ses-header-row -56) + (ses-header-row 99) + (ses-insert-column -14) + (ses-insert-row 0) + (ses-jump 'B8) ;Covered by preceding cell + (ses-printer-validate '("%s" t)) + (ses-printer-validate '([47])) + (ses-read-header-row -1) + (ses-read-header-row 32767) + (ses-relocate-all 0 0 -1 1) + (ses-relocate-all 0 0 1 -1) + (ses-select (ses-range A1 A2) 'x (ses-range B1 B1)) + (ses-set-cell 0 0 'hogwash nil) + (ses-set-column-width 0 0) + (ses-yank-cells #("a\nb" + 0 1 (ses (A1 nil nil)) + 2 3 (ses (A3 nil nil))) + nil) + (ses-yank-cells #("ab" + 0 1 (ses (A1 nil nil)) + 1 2 (ses (A2 nil nil))) + nil) + (ses-yank-pop nil) + (ses-yank-tsf "1\t2\n3" nil) + (let ((curcell nil)) (ses-check-curcell)) + (let ((curcell 'A1)) (ses-check-curcell 'needrange)) + (let ((curcell '(A1 . A2))) (ses-check-curcell 'end)) + (let ((curcell '(A1 . A2))) (ses-sort-column "B")) + (let ((curcell '(C1 . D2))) (ses-sort-column "B")) + (execute-kbd-macro "jB10\n2") + (execute-kbd-macro [?j ?B ?9 ?\n ?\C-@ ?\C-f ?\C-f cut]) + (progn (kill-new "x") (execute-kbd-macro ">n")) + (execute-kbd-macro "\0w"))) + (condition-case nil + (progn + (eval x) + (signal 'singularity-error nil)) ;Shouldn't get here + (singularity-error (error "No error from %s?" x)) + (error nil))) + ;;Test quit-handling in ses-update-cells. Cant' use `eval' here. + (let ((inhibit-quit t)) + (setq quit-flag t) + (condition-case nil + (progn + (ses-update-cells '(A1)) + (signal 'singularity-error nil)) + (singularity-error (error "Quit failure in ses-update-cells")) + (error nil)) + (setq quit-flag nil))) + +(defun ses-exercise-invalid-spreadsheets () + "Execute code paths that detect invalid spreadsheet files." + ;;Detect invalid spreadsheets + (let ((p&d "\n\n \n(ses-cell A1 nil nil nil nil)\n\n") + (cw "(ses-column-widths [7])\n") + (cp "(ses-column-printers [ses-center])\n") + (dp "(ses-default-printer \"%.7g\")\n") + (hr "(ses-header-row 0)\n") + (p11 "(2 1 1)") + (igp ses-initial-global-parameters)) + (dolist (x (list "(1)" + "(x 2 3)" + "(1 x 3)" + "(1 -1 0)" + "(1 2 x)" + "(1 2 -1)" + "(3 1 1)" + "\n\n (2 1 1)" + "\n\n \n(ses-cell)(2 1 1)" + "\n\n \n(x)\n(2 1 1)" + "\n\n\n \n(ses-cell A2)\n(2 2 2)" + "\n\n\n \n(ses-cell B1)\n(2 2 2)" + "\n\n \n(ses-cell A1 nil nil nil nil)\n(2 1 1)" + (concat p&d "(x)\n(x)\n(x)\n(x)\n" p11) + (concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11) + (concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)") + (concat p&d cw "(ses-column-printers)(x)\n(x)\n" p11) + (concat p&d cw cp "(x)\n(x)\n" p11) + (concat p&d cw cp "(ses-default-printer)(x)\n" p11) + (concat p&d cw cp dp "(x)\n" p11) + (concat p&d cw cp dp "(ses-header-row)" p11) + (concat p&d cw cp dp hr p11) + (concat p&d cw cp dp "\n" hr igp))) + (condition-case nil + (with-temp-buffer + (insert x) + (ses-load) + (signal 'singularity-error nil)) ;Shouldn't get here + (singularity-error (error "%S is an invalid spreadsheet!" x)) + (error nil))))) + +(defun ses-exercise-startup () + "Prepare for coverage tests" + ;;Clean up from any previous runs + (condition-case nil (kill-buffer "ses-example.ses") (error nil)) + (condition-case nil (kill-buffer "ses-test.ses") (error nil)) + (condition-case nil (delete-file "ses-test.ses") (file-error nil)) + (delete-other-windows) ;Needed for "\C-xo" in ses-exercise-editing + (setq ses-mode-map nil) ;Force rebuild + (testcover-unmark-all "ses.el") + ;;Enable + (let ((testcover-1value-functions + ;;forward-line always returns 0, for us. + ;;remove-text-properties always returns t for us. + ;;ses-recalculate-cell returns the same " " any time curcell is a cons + ;;Macros ses-dorange and ses-dotimes-msg generate code that always + ;; returns nil + (append '(forward-line remove-text-properties ses-recalculate-cell + ses-dorange ses-dotimes-msg) + testcover-1value-functions)) + (testcover-constants + ;;These maps get initialized, then never changed again + (append '(ses-mode-map ses-mode-print-map ses-mode-edit-map) + testcover-constants))) + (testcover-start "ses.el" t)) + (require 'unsafep)) ;In case user has safe-functions = t! + + +;;;######################################################################### +(defun ses-exercise () + "Executes all SES coverage tests and displays the results." + (interactive) + (ses-exercise-startup) + ;;Run the keyboard-macro tests + (let ((safe-functions nil) + (ses-initial-size '(1 . 1)) + (ses-initial-column-width 7) + (ses-initial-default-printer "%.7g") + (ses-after-entry-functions '(forward-char)) + (ses-mode-hook nil)) + (ses-exercise-macros) + (ses-exercise-signals) + (ses-exercise-invalid-spreadsheets) + ;;Upgrade of old-style spreadsheet + (with-temp-buffer + (insert " \n\n \n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n") + (ses-load)) + ;;ses-vector-delete is always called from buffer-undo-list with the same + ;;symbol as argument. We'll give it a different one here. + (let ((x [1 2 3])) + (ses-vector-delete 'x 0 0)) + ;;ses-create-header-string behaves differently in a non-window environment + ;;but we always test under windows. + (let ((window-system (not window-system))) + (scroll-left 7) + (ses-create-header-string)) + ;;Test for nonstandard after-entry functions + (let ((ses-after-entry-functions '(forward-line)) + ses-mode-hook) + (ses-read-cell 0 0 1) + (ses-read-symbol 0 0 t))) + ;;Tests with unsafep disabled + (let ((safe-functions t) + ses-mode-hook) + (message "") + (kill-buffer "ses-example.ses") + (find-file "ses-example.ses")) + ;;Checks for nonstandard default values for new spreadsheets + (let (ses-mode-hook) + (dolist (x '(("%.6g" 8 (2 . 2)) + ("%.8g" 6 (3 . 3)))) + (let ((ses-initial-size (nth 2 x)) + (ses-initial-column-width (nth 1 x)) + (ses-initial-default-printer (nth 0 x))) + (with-temp-buffer + (set-buffer-modified-p t) + (ses-mode))))) + ;;Test error-handling in command hook, outside a macro. + ;;This will ring the bell. + (let (curcell-overlay) + (ses-command-hook)) + ;;Due to use of run-with-timer, ses-command-hook sometimes gets called + ;;after we switch to another buffer. + (switch-to-buffer "*scratch*") + (ses-command-hook) + ;;Print results + (message "") + (testcover-mark-all "ses.el") + (testcover-next-mark) + ;;Cleanup + (delete-other-windows) + (kill-buffer "ses-test.txt") + ;;Could do this here: (testcover-end "ses.el") + (message "Done")) + +;;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 +;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el new file mode 100644 index 00000000000..4359209b4d4 --- /dev/null +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -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 +;; Maintainer: Jonathan Yavner +;; 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. diff --git a/lisp/emacs-lisp/testcover-ses.el b/lisp/emacs-lisp/testcover-ses.el deleted file mode 100644 index 48ec9fa64da..00000000000 --- a/lisp/emacs-lisp/testcover-ses.el +++ /dev/null @@ -1,712 +0,0 @@ -;;;; testcover-ses.el -- Example use of `testcover' to test "SES" - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Jonathan Yavner -;; Maintainer: Jonathan Yavner -;; Keywords: spreadsheet lisp utility - -;; 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) - -;;;Here are some macros that exercise SES. Set `pause' to t if you want the -;;;macros to pause after each step. -(let* ((pause nil) - (x (if pause "q" "")) - (y "ses-test.ses\r<")) - ;;Fiddle with the existing spreadsheet - (fset 'ses-exercise-example - (concat "" data-directory "ses-example.ses\r<" - x "10" - x " " - x "" - x "pses-center\r" - x "p\r" - x "\t\t" - x "\r A9 B9\r" - x "" - x "\r 2\r" - x "" - x "50\r" - x "4" - x " " - x "" - x "(+ o\0" - x "-1o \r" - x "" - x)) - ;;Create a new spreadsheet - (fset 'ses-exercise-new - (concat y - x "\"%.8g\"\r" - x "2\r" - x "" - x "" - x "2" - x "\"Header\r" - x "(sqrt 1\r" - x "pses-center\r" - x "\t" - x "(+ A2 A3\r" - x "(* B2 A3\r" - x "2" - x "\rB3\r" - x "" - x)) - ;;Basic cell display - (fset 'ses-exercise-display - (concat y ":(revert-buffer t t)\r" - x "" - x "\"Very long\r" - x "w3\r" - x "w3\r" - x "(/ 1 0\r" - x "234567\r" - x "5w" - x "\t1\r" - x "" - x "234567\r" - x "\t" - x "" - x "345678\r" - x "3w" - x "\0>" - x "" - x "" - x "" - x "" - x "" - x "" - x "" - x "1\r" - x "" - x "" - x "\"1234567-1234567-1234567\r" - x "123\r" - x "2" - x "\"1234567-1234567-1234567\r" - x "123\r" - x "w8\r" - x "\"1234567\r" - x "w5\r" - x)) - ;;Cell formulas - (fset 'ses-exercise-formulas - (concat y ":(revert-buffer t t)\r" - x "\t\t" - x "\t" - x "(* B1 B2 D1\r" - x "(* B2 B3\r" - x "(apply '+ (ses-range B1 B3)\r" - x "(apply 'ses+ (ses-range B1 B3)\r" - x "(apply 'ses+ (ses-range A2 A3)\r" - x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r" - x "(apply 'concat (reverse (ses-range A3 D3))\r" - x "(* (+ A2 A3) (ses+ B2 B3)\r" - x "" - x "2" - x "5\t" - x "(apply 'ses+ (ses-range E1 E2)\r" - x "(apply 'ses+ (ses-range A5 B5)\r" - x "(apply 'ses+ (ses-range E1 F1)\r" - x "(apply 'ses+ (ses-range D1 E1)\r" - x "\t" - x "(ses-average (ses-range A2 A5)\r" - x "(apply 'ses+ (ses-range A5 A6)\r" - x "k" - x " " - x "" - x "2" - x "3 " - x "o" - x "2o" - x "3k" - x "(ses-average (ses-range B3 E3)\r" - x "k" - x "12345678\r" - x)) - ;;Recalculating and reconstructing - (fset 'ses-exercise-recalc - (concat y ":(revert-buffer t t)\r" - x " " - x "\t\t" - x "" - x "(/ 1 0\r" - x "" - x "\n" - x "" - x "\"%.6g\"\r" - x " " - x ">nw" - x "\0>xdelete-region\r" - x " " - x "8" - x "\0>xdelete-region\r" - x " " - x "" - x " k" - x " " - x "\"Very long\r" - x "" - x "\r\r" - x "" - x "o" - x "" - x "\"Very long2\r" - x "o" - x "" - x "\rC3\r" - x "\rC2\r" - x "\0" - x "\rC4\r" - x "\rC2\r" - x "\0" - x "" - x "xses-mode\r" - x "<" - x "2k" - x)) - ;;Header line - (fset 'ses-exercise-header-row - (concat y ":(revert-buffer t t)\r" - x "<" - x ">" - x "6<" - x ">" - x "7<" - x ">" - x "8<" - x "2<" - x ">" - x "3w" - x "10<" - x ">" - x "2 " - x)) - ;;Detecting unsafe formulas and printers - (fset 'ses-exercise-unsafe - (concat y ":(revert-buffer t t)\r" - x "p(lambda (x) (delete-file x))\rn" - x "p(lambda (x) (delete-file \"ses-nothing\"))\ry" - x "\0n" - x "(delete-file \"x\"\rn" - x "(delete-file \"ses-nothing\"\ry" - x "\0n" - x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry" - x "\0n" - x)) - ;;Inserting and deleting rows - (fset 'ses-exercise-rows - (concat y ":(revert-buffer t t)\r" - x "" - x "\"%s=\"\r" - x "20" - x "p\"%s+\"\r" - x "" - x "123456789\r" - x "\021" - x "" - x " " - x "(not B25\r" - x "k" - x "jA3\r" - x "19 " - x " " - x "100" ;Make this approx your CPU speed in MHz - x)) - ;;Inserting and deleting columns - (fset 'ses-exercise-columns - (concat y ":(revert-buffer t t)\r" - x "\"%s@\"\r" - x "o" - x "" - x "o" - x " " - x "k" - x "w8\r" - x "p\"%.7s*\"\r" - x "o" - x "" - x "2o" - x "3k" - x "\"%.6g\"\r" - x "26o" - x "\026\t" - x "26o" - x "0\r" - x "26\t" - x "400" - x "50k" - x "\0D" - x)) - (fset 'ses-exercise-editing - (concat y ":(revert-buffer t t)\r" - x "1\r" - x "('x\r" - x "" - x "" - x "\r\r" - x "w9\r" - x "\r.5\r" - x "\r 10\r" - x "w12\r" - x "\r'\r" - x "\r\r" - x "jA4\r" - x "(+ A2 100\r" - x "3\r" - x "jB1\r" - x "(not A1\r" - x "\"Very long\r" - x "" - x "h" - x "H" - x "" - x ">\t" - x "" - x "" - x "2" - x "" - x "o" - x "h" - x "\0" - x "\"Also very long\r" - x "H" - x "\0'\r" - x "'Trial\r" - x "'qwerty\r" - x "(concat o<\0" - x "-1o\r" - x "(apply '+ o<\0-1o\r" - x "2" - x "-2" - x "-2" - x "2" - x " " - x "H" - x "\0" - x "\"Another long one\r" - x "H" - x "" - x "<" - x "" - x ">" - x "\0" - x)) - ;;Sorting of columns - (fset 'ses-exercise-sort-column - (concat y ":(revert-buffer t t)\r" - x "\"Very long\r" - x "99\r" - x "o13\r" - x "(+ A3 B3\r" - x "7\r8\r(* A4 B4\r" - x "\0A\r" - x "\0B\r" - x "\0C\r" - x "o" - x "\0C\r" - x)) - ;;Simple cell printers - (fset 'ses-exercise-cell-printers - (concat y ":(revert-buffer t t)\r" - x "\"4\t76\r" - x "\"4\n7\r" - x "p\"{%S}\"\r" - x "p(\"[%s]\")\r" - x "p(\"<%s>\")\r" - x "\0" - x "p\r" - x "pnil\r" - x "pses-dashfill\r" - x "48\r" - x "\t" - x "\0p\r" - x "p\r" - x "pses-dashfill\r" - x "\0pnil\r" - x "5\r" - x "pses-center\r" - x "\"%s\"\r" - x "w8\r" - x "p\r" - x "p\"%.7g@\"\r" - x "\r" - x "\"%.6g#\"\r" - x "\"%.6g.\"\r" - x "\"%.6g.\"\r" - x "pidentity\r" - x "6\r" - x "\"UPCASE\r" - x "pdowncase\r" - x "(* 3 4\r" - x "p(lambda (x) '(\"Hi\"))\r" - x "p(lambda (x) '(\"Bye\"))\r" - x)) - ;;Spanning cell printers - (fset 'ses-exercise-spanning-printers - (concat y ":(revert-buffer t t)\r" - x "p\"%.6g*\"\r" - x "pses-dashfill-span\r" - x "5\r" - x "pses-tildefill-span\r" - x "\"4\r" - x "p\"$%s\"\r" - x "p(\"$%s\")\r" - x "8\r" - x "p(\"!%s!\")\r" - x "\t\"12345678\r" - x "pses-dashfill-span\r" - x "\"23456789\r" - x "\t" - x "(not t\r" - x "w6\r" - x "\"5\r" - x "o" - x "k" - x "k" - x "\t" - x "" - x "o" - x "2k" - x "k" - x)) - ;;Cut/copy/paste - within same buffer - (fset 'ses-exercise-paste-1buf - (concat y ":(revert-buffer t t)\r" - x "\0w" - x "" - x "o" - x "\"middle\r" - x "\0" - x "w" - x "\0" - x "w" - x "" - x "" - x "2y" - x "y" - x "y" - x ">" - x "y" - x ">y" - x "<" - x "p\"<%s>\"\r" - x "pses-dashfill\r" - x "\0" - x "" - x "" - x "y" - x "\r\0w" - x "\r" - x "3(+ G2 H1\r" - x "\0w" - x ">" - x "" - x "8(ses-average (ses-range G2 H2)\r" - x "\0k" - x "7" - x "" - x "(ses-average (ses-range E7 E9)\r" - x "\0 " - x "" - x "(ses-average (ses-range E7 F7)\r" - x "\0k" - x "" - x "(ses-average (ses-range D6 E6)\r" - x "\0k" - x "" - x "2" - x "\"Line A\r" - x "pses-tildefill-span\r" - x "\"Subline A(1)\r" - x "pses-dashfill-span\r" - x "\0w" - x "" - x "" - x "\0w" - x "" - x)) - ;;Cut/copy/paste - between two buffers - (fset 'ses-exercise-paste-2buf - (concat y ":(revert-buffer t t)\r" - x "o\"middle\r\0" - x "" - x "4bses-test.txt\r" - x " " - x "\"xxx\0" - x "wo" - x "" - x "" - x "o\"\0" - x "wo" - x "o123.45\0" - x "o" - x "o1 \0" - x "o" - x ">y" - x "o symb\0" - x "oy2y" - x "o1\t\0" - x "o" - x "w9\np\"<%s>\"\n" - x "o\n2\t\"3\nxxx\t5\n\0" - x "oy" - x)) - ;;Export text, import it back - (fset 'ses-exercise-import-export - (concat y ":(revert-buffer t t)\r" - x "\0xt" - x "4bses-test.txt\r" - x "\n-1o" - x "xTo-1o" - x "'crunch\r" - x "pses-center-span\r" - x "\0xT" - x "o\n-1o" - x "\0y" - x "\0xt" - x "\0y" - x "12345678\r" - x "'bunch\r" - x "\0xtxT" - x))) - -(defun ses-exercise-macros () - "Executes all SES coverage-test macros." - (dolist (x '(ses-exercise-example - ses-exercise-new - ses-exercise-display - ses-exercise-formulas - ses-exercise-recalc - ses-exercise-header-row - ses-exercise-unsafe - ses-exercise-rows - ses-exercise-columns - ses-exercise-editing - ses-exercise-sort-column - ses-exercise-cell-printers - ses-exercise-spanning-printers - ses-exercise-paste-1buf - ses-exercise-paste-2buf - ses-exercise-import-export)) - (message "" x) - (execute-kbd-macro x))) - -(defun ses-exercise-signals () - "Exercise code paths that lead to error signals, other than those for -spreadsheet files with invalid formatting." - (message "") - (switch-to-buffer "ses-test.ses") - (deactivate-mark) - (ses-jump 'A1) - (ses-set-curcell) - (dolist (x '((ses-column-widths 14) - (ses-column-printers "%s") - (ses-column-printers ["%s" "%s" "%s"]) ;Should be two - (ses-column-widths [14]) - (ses-delete-column -99) - (ses-delete-column 2) - (ses-delete-row -1) - (ses-goto-data 'hogwash) - (ses-header-row -56) - (ses-header-row 99) - (ses-insert-column -14) - (ses-insert-row 0) - (ses-jump 'B8) ;Covered by preceding cell - (ses-printer-validate '("%s" t)) - (ses-printer-validate '([47])) - (ses-read-header-row -1) - (ses-read-header-row 32767) - (ses-relocate-all 0 0 -1 1) - (ses-relocate-all 0 0 1 -1) - (ses-select (ses-range A1 A2) 'x (ses-range B1 B1)) - (ses-set-cell 0 0 'hogwash nil) - (ses-set-column-width 0 0) - (ses-yank-cells #("a\nb" - 0 1 (ses (A1 nil nil)) - 2 3 (ses (A3 nil nil))) - nil) - (ses-yank-cells #("ab" - 0 1 (ses (A1 nil nil)) - 1 2 (ses (A2 nil nil))) - nil) - (ses-yank-pop nil) - (ses-yank-tsf "1\t2\n3" nil) - (let ((curcell nil)) (ses-check-curcell)) - (let ((curcell 'A1)) (ses-check-curcell 'needrange)) - (let ((curcell '(A1 . A2))) (ses-check-curcell 'end)) - (let ((curcell '(A1 . A2))) (ses-sort-column "B")) - (let ((curcell '(C1 . D2))) (ses-sort-column "B")) - (execute-kbd-macro "jB10\n2") - (execute-kbd-macro [?j ?B ?9 ?\n ?\C-@ ?\C-f ?\C-f cut]) - (progn (kill-new "x") (execute-kbd-macro ">n")) - (execute-kbd-macro "\0w"))) - (condition-case nil - (progn - (eval x) - (signal 'singularity-error nil)) ;Shouldn't get here - (singularity-error (error "No error from %s?" x)) - (error nil))) - ;;Test quit-handling in ses-update-cells. Cant' use `eval' here. - (let ((inhibit-quit t)) - (setq quit-flag t) - (condition-case nil - (progn - (ses-update-cells '(A1)) - (signal 'singularity-error nil)) - (singularity-error (error "Quit failure in ses-update-cells")) - (error nil)) - (setq quit-flag nil))) - -(defun ses-exercise-invalid-spreadsheets () - "Execute code paths that detect invalid spreadsheet files." - ;;Detect invalid spreadsheets - (let ((p&d "\n\n \n(ses-cell A1 nil nil nil nil)\n\n") - (cw "(ses-column-widths [7])\n") - (cp "(ses-column-printers [ses-center])\n") - (dp "(ses-default-printer \"%.7g\")\n") - (hr "(ses-header-row 0)\n") - (p11 "(2 1 1)") - (igp ses-initial-global-parameters)) - (dolist (x (list "(1)" - "(x 2 3)" - "(1 x 3)" - "(1 -1 0)" - "(1 2 x)" - "(1 2 -1)" - "(3 1 1)" - "\n\n (2 1 1)" - "\n\n \n(ses-cell)(2 1 1)" - "\n\n \n(x)\n(2 1 1)" - "\n\n\n \n(ses-cell A2)\n(2 2 2)" - "\n\n\n \n(ses-cell B1)\n(2 2 2)" - "\n\n \n(ses-cell A1 nil nil nil nil)\n(2 1 1)" - (concat p&d "(x)\n(x)\n(x)\n(x)\n" p11) - (concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11) - (concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)") - (concat p&d cw "(ses-column-printers)(x)\n(x)\n" p11) - (concat p&d cw cp "(x)\n(x)\n" p11) - (concat p&d cw cp "(ses-default-printer)(x)\n" p11) - (concat p&d cw cp dp "(x)\n" p11) - (concat p&d cw cp dp "(ses-header-row)" p11) - (concat p&d cw cp dp hr p11) - (concat p&d cw cp dp "\n" hr igp))) - (condition-case nil - (with-temp-buffer - (insert x) - (ses-load) - (signal 'singularity-error nil)) ;Shouldn't get here - (singularity-error (error "%S is an invalid spreadsheet!" x)) - (error nil))))) - -(defun ses-exercise-startup () - "Prepare for coverage tests" - ;;Clean up from any previous runs - (condition-case nil (kill-buffer "ses-example.ses") (error nil)) - (condition-case nil (kill-buffer "ses-test.ses") (error nil)) - (condition-case nil (delete-file "ses-test.ses") (file-error nil)) - (delete-other-windows) ;Needed for "\C-xo" in ses-exercise-editing - (setq ses-mode-map nil) ;Force rebuild - (testcover-unmark-all "ses.el") - ;;Enable - (let ((testcover-1value-functions - ;;forward-line always returns 0, for us. - ;;remove-text-properties always returns t for us. - ;;ses-recalculate-cell returns the same " " any time curcell is a cons - ;;Macros ses-dorange and ses-dotimes-msg generate code that always - ;; returns nil - (append '(forward-line remove-text-properties ses-recalculate-cell - ses-dorange ses-dotimes-msg) - testcover-1value-functions)) - (testcover-constants - ;;These maps get initialized, then never changed again - (append '(ses-mode-map ses-mode-print-map ses-mode-edit-map) - testcover-constants))) - (testcover-start "ses.el" t)) - (require 'unsafep)) ;In case user has safe-functions = t! - - -;;;######################################################################### -(defun ses-exercise () - "Executes all SES coverage tests and displays the results." - (interactive) - (ses-exercise-startup) - ;;Run the keyboard-macro tests - (let ((safe-functions nil) - (ses-initial-size '(1 . 1)) - (ses-initial-column-width 7) - (ses-initial-default-printer "%.7g") - (ses-after-entry-functions '(forward-char)) - (ses-mode-hook nil)) - (ses-exercise-macros) - (ses-exercise-signals) - (ses-exercise-invalid-spreadsheets) - ;;Upgrade of old-style spreadsheet - (with-temp-buffer - (insert " \n\n \n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n") - (ses-load)) - ;;ses-vector-delete is always called from buffer-undo-list with the same - ;;symbol as argument. We'll give it a different one here. - (let ((x [1 2 3])) - (ses-vector-delete 'x 0 0)) - ;;ses-create-header-string behaves differently in a non-window environment - ;;but we always test under windows. - (let ((window-system (not window-system))) - (scroll-left 7) - (ses-create-header-string)) - ;;Test for nonstandard after-entry functions - (let ((ses-after-entry-functions '(forward-line)) - ses-mode-hook) - (ses-read-cell 0 0 1) - (ses-read-symbol 0 0 t))) - ;;Tests with unsafep disabled - (let ((safe-functions t) - ses-mode-hook) - (message "") - (kill-buffer "ses-example.ses") - (find-file "ses-example.ses")) - ;;Checks for nonstandard default values for new spreadsheets - (let (ses-mode-hook) - (dolist (x '(("%.6g" 8 (2 . 2)) - ("%.8g" 6 (3 . 3)))) - (let ((ses-initial-size (nth 2 x)) - (ses-initial-column-width (nth 1 x)) - (ses-initial-default-printer (nth 0 x))) - (with-temp-buffer - (set-buffer-modified-p t) - (ses-mode))))) - ;;Test error-handling in command hook, outside a macro. - ;;This will ring the bell. - (let (curcell-overlay) - (ses-command-hook)) - ;;Due to use of run-with-timer, ses-command-hook sometimes gets called - ;;after we switch to another buffer. - (switch-to-buffer "*scratch*") - (ses-command-hook) - ;;Print results - (message "") - (testcover-mark-all "ses.el") - (testcover-next-mark) - ;;Cleanup - (delete-other-windows) - (kill-buffer "ses-test.txt") - ;;Could do this here: (testcover-end "ses.el") - (message "Done")) - -;;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 -;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/testcover-unsafep.el b/lisp/emacs-lisp/testcover-unsafep.el deleted file mode 100644 index 4359209b4d4..00000000000 --- a/lisp/emacs-lisp/testcover-unsafep.el +++ /dev/null @@ -1,140 +0,0 @@ -;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Jonathan Yavner -;; Maintainer: Jonathan Yavner -;; 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.