blob: 65aed36a64d3652316b0f5d4d09e92bbac65ccfa (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
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
|
