Initial revision

1 files changed, 122 insertions, 0 deletions

diff --git a/tests/safe.test b/tests/safe.test
new file mode 100644
index 0000000..65aed36
--- /dev/null
+++ b/tests/safe.test
@@ -0,0 +1,122 @@
+# This file is a Tcl script to test the Safe Tk facility. It is organized
+# in the standard fashion for Tk tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) safe.test 1.15 97/08/13 16:05:17
+
+if {[info procs test] != "test"} {
+    source defs
+}
+
+foreach i [winfo children .] {
+    destroy $i
+}
+
+# The set of hidden commands is platform dependent:
+
+if {"$tcl_platform(platform)" == "macintosh"} {
+    set hidden_cmds {beep bell cd clipboard echo exit fconfigure file glob grab load ls menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm}
+} elseif {"$tcl_platform(platform)" == "windows"} {
+    set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm}
+} else {
+    set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection send socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm}
+}
+
+test safe-1.1 {Safe Tk loading into an interpreter} {
+    catch {safe::interpDelete a}
+    safe::loadTk [safe::interpCreate a]
+    safe::interpDelete a
+    set x {}
+    set x
+} ""
+test safe-1.2 {Safe Tk loading into an interpreter} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set l [lsort [interp hidden a]]
+    safe::interpDelete a
+    set l
+} $hidden_cmds
+test safe-1.3 {Safe Tk loading into an interpreter} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set l [lsort [interp aliases a]]
+    safe::interpDelete a
+    set l
+} {exit file load source}
+
+test safe-2.1 {Unsafe commands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {toplevel .t}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    set status
+} ok
+test safe-2.2 {Unsafe commands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {menu .m}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    set status
+} ok
+
+test safe-3.1 {Unsafe commands are available hidden} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status ok
+    if {[catch {interp invokehidden a toplevel .t} msg]} {
+	set status broken
+    }
+    safe::interpDelete a
+    set status
+} ok
+test safe-3.2 {Unsafe commands are available hidden} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status ok
+    if {[catch {interp invokehidden a menu .m} msg]} {
+	set status broken
+    }
+    safe::interpDelete a
+    set status
+} ok
+
+test safe-4.1 {testing loadTk} {
+    # no error shall occur, the user will
+    # eventually see a new toplevel
+    set i [safe::loadTk [safe::interpCreate]]
+    interp eval $i {button .b -text "hello world!"; pack .b}
+# lets don't update because it might impy that the user has
+# to position the window (if the wm does not do it automatically)
+# and thus make the test suite not runable non interactively
+    safe::interpDelete $i
+} {}
+
+test safe-4.2 {testing loadTk -use} {
+    set w .safeTkFrame
+    catch {destroy $w}
+    frame $w -container 1;
+    pack .safeTkFrame
+    set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
+    interp eval $i {button .b -text "hello world!"; pack .b}
+    safe::interpDelete $i
+    destroy $w
+} {}
+
+unset hidden_cmds