Tk Source Code
Check-in [dcd76b16]
Not logged in
Tcl 2016 Conference, Houston/TX, US, Nov 14-18
Send your abstracts to tclconference@googlegroups.com by Sep 12.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
SHA1 Hash:dcd76b16d128eda1d308714a2f7f347f83590c5b
Date: 2011-11-29 14:26:54
User: dkf
Comment:tests/safe.test: [Bug 1847925]: Update list of hidden commands.
Tags And Properties
Context
2011-12-13
11:22
[0c6e7a48] Make example follow best practices. (user: dkf, tags: trunk)
2011-11-29
14:26
[dcd76b16] tests/safe.test: [Bug 1847925]: Update list of hidden commands. (user: dkf, tags: trunk)
2011-11-22
17:12
[174503e2] [Bug 1945073]: Demo square.tcl cannot run; need package tktest (user: jan.nijtmans, tags: trunk)
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.





1
2
3
4
5
6
7




2011-11-22  Jan Nijtmans  <nijtmans@users.sf.net>

	* unix/Makefile.in: [Bug 1945073]: Demo square.tcl
	* win/Makefile.in: cannot run; need package tktest

2011-11-17  Jan Nijtmans  <nijtmans@users.sf.net>

>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
2011-11-29  Donal K. Fellows  <dkf@users.sf.net>

	* tests/safe.test: [Bug 1847925]: Update list of hidden commands.

2011-11-22  Jan Nijtmans  <nijtmans@users.sf.net>

	* unix/Makefile.in: [Bug 1945073]: Demo square.tcl
	* win/Makefile.in: cannot run; need package tktest

2011-11-17  Jan Nijtmans  <nijtmans@users.sf.net>

Changes to tests/safe.test.

1
2
3
4
5
6
7
8
9
..
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166


167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241




# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
................................................................................
#     invoked from within
# "uplevel #0 [list source $file]"
# 
# 
# This probably means that tk wasn't installed properly.

## it indicates that something went wrong sourcing tk.tcl.
## Ensure that any changes that occured to tk.tcl will work or
## are properly prevented in a safe interpreter.  -- hobbs

# The set of hidden commands is platform dependent:

if {[string equal $tcl_platform(platform) "windows"]} {
    set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel unload wm}











} else {
    set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel unload wm}

}

set saveAutoPath $::auto_path
set auto_path [list [info library] $::tk_library]


test safe-1.1 {Safe Tk loading into an interpreter} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::loadTk [safe::interpCreate a]
    safe::interpDelete a
    set x {}
    return $x
} -result {}
test safe-1.2 {Safe Tk loading into an interpreter} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    lsort [interp hidden a]
} -cleanup {
    safe::interpDelete a
} -result $hidden_cmds
test safe-1.3 {Safe Tk loading into an interpreter} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    lsort [interp aliases a]
} -cleanup {
    safe::interpDelete a
} -match glob -result {*encoding*exit*file*load*source*}


test safe-2.1 {Unsafe commands not available} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {toplevel .t}} msg]} {
	set status ok
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-2.2 {Unsafe commands not available} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {menu .m}} msg]} {
	set status ok
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-2.3 {Unsafe subcommands not available} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {tk appname}} msg]} {
	set status ok
    }
    list $status $msg
} -cleanup {
	safe::interpDelete a
} -result {ok {appname not accessible in a safe interpreter}}
test safe-2.4 {Unsafe subcommands not available} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {tk scaling}} msg]} {
	set status ok
    }
    list $status $msg
} -cleanup {
	safe::interpDelete a
} -result {ok {scaling not accessible in a safe interpreter}}


test safe-3.1 {Unsafe commands are available hidden} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status ok
    if {[catch {interp invokehidden a toplevel .t} msg]} {
	set status broken
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-3.2 {Unsafe commands are available hidden} -setup {
	catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status ok
    if {[catch {interp invokehidden a menu .m} msg]} {
	set status broken
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok


test safe-4.1 {testing loadTk} -body {
    # 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 imply 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
} -result {}

test safe-4.2 {testing loadTk -use} -body {


    set w .safeTkFrame
    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
} -result {}


test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
    set i [safe::interpCreate]
    interp eval $i {load {} Tk}
} -cleanup {
    safe::interpDelete $i
} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit}

test safe-5.2 {multi-level Tk loading with clearance} -body {
    # No error shall occur in that test and no window
    # shall remain at the end.
    set i [safe::interpCreate]
    set j [list $i x]
    set j [safe::interpCreate $j]
    safe::loadTk $j
    interp eval $j {
	    button .b -text Ok -command {destroy .}
	    pack .b
#	    tkwait window . ; # for interactive testing/debugging
    }
} -cleanup {
    safe::interpDelete $j
    safe::interpDelete $i
} -result {}


test safe-6.1 {loadTk -use windowPath} -body {
    set w .safeTkFrame
    destroy $w
    frame $w -container 1;
    pack .safeTkFrame
    set i [safe::loadTk [safe::interpCreate] -use $w]
    interp eval $i {button .b -text "hello world!"; pack .b}
    safe::interpDelete $i
    destroy $w
} -result {}

test safe-6.2 {loadTk -use windowPath, conflicting -display} -body {
    set w .safeTkFrame
    destroy $w
    frame $w -container 1;
    pack .safeTkFrame
    set i     [safe::interpCreate]
    catch {safe::loadTk $i -use $w -display :23.56} msg
    string range $msg 0 36
} -cleanup {
    safe::interpDelete $i
    destroy $w
} -result {conflicting -display :23.56 and -use }


test safe-7.1 {canvas printing} -body {
    set i [safe::loadTk [safe::interpCreate]]
    interp eval $i {canvas .c; .c postscript}
} -cleanup {
    safe::interpDelete $i
} -returnCodes ok -match glob -result *

# cleanup
set ::auto_path $saveAutoPath
unset hidden_cmds
cleanupTests
return






|
|







 







|
|



<
|
>
>
>
>
>
>
>
>
>
>
>

<
>




>
|

|







|








|








<

|












|












|









|


|









|


<

|












|












<

|
<


|
|
|


<
|
>
>

<

|





<







<

|
<





|
|
|






|
|
|
|
|
|





|
|
|
|
|
|








<






|






<
>
>
>
>
1
2
3
4
5
6
7
8
9
..
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
123
124
125
126
127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

163
164

165
166
167
168
169
170
171

172
173
174
175

176
177
178
179
180
181
182

183
184
185
186
187
188
189

190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237
238
239
240
241
242
243

244
245
246
247
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
................................................................................
#     invoked from within
# "uplevel #0 [list source $file]"
# 
# 
# This probably means that tk wasn't installed properly.

## it indicates that something went wrong sourcing tk.tcl.
## Ensure that any changes that occured to tk.tcl will work or are properly
## prevented in a safe interpreter.  -- hobbs

# The set of hidden commands is platform dependent:


set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source toplevel unload wm}
lappend hidden_cmds {*}[apply {{} {
    foreach cmd {
	atime attributes copy delete dirname executable exists extension
	isdirectory isfile link lstat mkdir mtime nativename normalize owned
	readable readlink rename rootname size stat tail tempfile type
	volumes writable
    } {lappend result tcl:file:$cmd}; return $result
}}]
if {$tcl_platform(platform) eq "windows"} {
    lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \
	tk_getSaveFile tk_messageBox
} else {

    lappend hidden_cmds send
}

set saveAutoPath $::auto_path
set auto_path [list [info library] $::tk_library]
set hidden_cmds [lsort $hidden_cmds]
 
test safe-1.1 {Safe Tk loading into an interpreter} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::loadTk [safe::interpCreate a]
    safe::interpDelete a
    set x {}
    return $x
} -result {}
test safe-1.2 {Safe Tk loading into an interpreter} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    lsort [interp hidden a]
} -cleanup {
    safe::interpDelete a
} -result $hidden_cmds
test safe-1.3 {Safe Tk loading into an interpreter} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    lsort [interp aliases a]
} -cleanup {
    safe::interpDelete a
} -match glob -result {*encoding*exit*file*load*source*}


test safe-2.1 {Unsafe commands not available} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {toplevel .t}} msg]} {
	set status ok
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-2.2 {Unsafe commands not available} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {menu .m}} msg]} {
	set status ok
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-2.3 {Unsafe subcommands not available} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {tk appname}} msg]} {
	set status ok
    }
    list $status $msg
} -cleanup {
    safe::interpDelete a
} -result {ok {appname not accessible in a safe interpreter}}
test safe-2.4 {Unsafe subcommands not available} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status broken
    if {[catch {interp eval a {tk scaling}} msg]} {
	set status ok
    }
    list $status $msg
} -cleanup {
    safe::interpDelete a
} -result {ok {scaling not accessible in a safe interpreter}}


test safe-3.1 {Unsafe commands are available hidden} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status ok
    if {[catch {interp invokehidden a toplevel .t} msg]} {
	set status broken
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok
test safe-3.2 {Unsafe commands are available hidden} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::interpCreate a
    safe::loadTk a
    set status ok
    if {[catch {interp invokehidden a menu .m} msg]} {
	set status broken
    }
    return $status
} -cleanup {
    safe::interpDelete a
} -result ok


test safe-4.1 {testing loadTk} -body {
    # 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 imply 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
} -result {}

test safe-4.2 {testing loadTk -use} -setup {
    destroy .safeTkFrame
} -body {
    set w .safeTkFrame

    frame $w -container 1;
    pack $w
    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
} -result {}


test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
    set i [safe::interpCreate]
    interp eval $i {load {} Tk}
} -cleanup {
    safe::interpDelete $i
} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit}

test safe-5.2 {multi-level Tk loading with clearance} -body {
    # No error shall occur in that test and no window shall remain at the end.

    set i [safe::interpCreate]
    set j [list $i x]
    set j [safe::interpCreate $j]
    safe::loadTk $j
    interp eval $j {
	button .b -text Ok -command {destroy .}
	pack .b
#	tkwait window . ; # for interactive testing/debugging
    }
} -cleanup {
    safe::interpDelete $j
    safe::interpDelete $i
} -result {}

test safe-6.1 {loadTk -use windowPath} -setup {
    destroy .safeTkFrame
} -body {
    set w .safeTkFrame
    frame $w -container 1;
    pack $w
    set i [safe::loadTk [safe::interpCreate] -use $w]
    interp eval $i {button .b -text "hello world!"; pack .b}
    safe::interpDelete $i
    destroy $w
} -result {}
test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
    destroy .safeTkFrame
} -body {
    set w .safeTkFrame
    frame $w -container 1;
    pack $w
    set i     [safe::interpCreate]
    catch {safe::loadTk $i -use $w -display :23.56} msg
    string range $msg 0 36
} -cleanup {
    safe::interpDelete $i
    destroy $w
} -result {conflicting -display :23.56 and -use }


test safe-7.1 {canvas printing} -body {
    set i [safe::loadTk [safe::interpCreate]]
    interp eval $i {canvas .c; .c postscript}
} -cleanup {
    safe::interpDelete $i
} -returnCodes ok -match glob -result *
 
# cleanup
set ::auto_path $saveAutoPath
unset hidden_cmds
cleanupTests
return


# Local Variables:
# mode: tcl
# fill-column: 78
# End: