aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/tests/safe.test
blob: c23f06aa18c81c99749a53f89db894a527337703 (plain) (blame)
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
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
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 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.34 97/11/19 14:59:13

if {[string compare test [info procs test]] == 1} then {source defs}

foreach i [interp slaves] {
  interp delete $i
}

# Force actual loading of the safe package 
# because we use un exported (and thus un-autoindexed) APIs
# in this test result arguments:
catch {safe::interpConfigure}

proc equiv {x} {return $x}

test safe-1.1 {safe::interpConfigure syntax} {
    list [catch {safe::interpConfigure} msg] $msg;
} {1 {no value given for parameter "slave" (use -help for full usage) :
    slave name () name of the slave}}

test safe-1.2 {safe::interpCreate syntax} {
    list [catch {safe::interpCreate -help} msg] $msg;
} {1 {Usage information:
    Var/FlagName  Type     Value   Help
    ------------  ----     -----   ----
    ( -help                        gives this help )
    ?slave?       name     ()      name of the slave (optional)
    -accessPath   list     ()      access path for the slave
    -noStatics    boolflag (false) prevent loading of statically linked pkgs
    -statics      boolean  (true)  loading of statically linked pkgs
    -nestedLoadOk boolflag (false) allow nested loading
    -nested       boolean  (false) nested loading
    -deleteHook   script   ()      delete hook}}

test safe-1.3 {safe::interpInit syntax} {
    list [catch {safe::interpInit -noStatics} msg] $msg;
} {1 {bad value "-noStatics" for parameter
    slave name () name of the slave}}


test safe-2.1 {creating interpreters, should have no aliases} {
    interp aliases
} ""
test safe-2.2 {creating interpreters, should have no aliases} {
    catch {safe::interpDelete a}
    interp create a
    set l [a aliases]
    safe::interpDelete a
    set l
} ""
test safe-2.3 {creating safe interpreters, should have no aliases} {
    catch {safe::interpDelete a}
    interp create a -safe
    set l [a aliases]
    interp delete a
    set l
} ""

test safe-3.1 {calling safe::interpInit is safe} {
    catch {safe::interpDelete a}
    interp create a -safe 
    safe::interpInit a
    catch {interp eval a exec ls} msg
    safe::interpDelete a
    set msg
} {invalid command name "exec"}
test safe-3.2 {calling safe::interpCreate on trusted interp} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    set l [lsort [a aliases]]
    safe::interpDelete a
    set l
} {exit file load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    set x [interp eval a {source [file join $tcl_library init.tcl]}]
    safe::interpDelete a
    set x
} ""
test safe-3.4 {calling safe::interpCreate on trusted interp} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    catch {set x \
		[interp eval a {source [file join $tcl_library init.tcl]}]} msg
    safe::interpDelete a
    list $x $msg
} {{} {}}

test safe-4.1 {safe::interpDelete} {
    catch {safe::interpDelete a}
    interp create a
    safe::interpDelete a
} ""
test safe-4.2 {safe::interpDelete, indirectly} {
    catch {safe::interpDelete a}
    interp create a
    a alias exit safe::interpDelete a
    a eval exit
} ""
test safe-4.3 {safe::interpDelete, state array (not a public api)} {
    catch {safe::interpDelete a}
    namespace eval safe {set [InterpStateName a](foo) 33}
    # not an error anymore to call it if interp is already
    # deleted, to make trhings smooth if it's called twice...
    catch {safe::interpDelete a} m1
    catch {namespace eval safe {set [InterpStateName a](foo)}} m2
    list $m1 $m2
} "{}\
   {can't read \"[safe::InterpStateName a]\": no such variable}"


test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    namespace eval safe {set [InterpStateName a](foo) 33}
    a eval exit
    catch {namespace eval safe {set [InterpStateName a](foo)}} msg
} 1

test safe-4.5 {safe::interpDelete} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    catch {safe::interpCreate a} msg
    set msg
} {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    a eval exit
} ""

# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading.

test safe-5.1 {test auto-loading in safe interpreters} {
    catch {safe::interpDelete a}
    safe::interpCreate a
    set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
    safe::interpDelete a
    list $r $msg
} {0 -1}

# test safe interps 'information leak'
proc SI {} {
    global I
    set I [interp create -safe];
}
proc DI {} {
    global I;
    interp delete $I;
}
test safe-6.1 {test safe interpreters knowledge of the world} {
    SI; set r [lsort [$I eval {info globals}]]; DI; set r
} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
test safe-6.2 {test safe interpreters knowledge of the world} {
    SI; set r [$I eval {info script}]; DI; set r
} {}
test safe-6.3 {test safe interpreters knowledge of the world} {
    SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r
} {byteOrder platform}

# more test should be added to check that hostname, nameofexecutable,
# aren't leaking infos, but they still do...

# high level general test
test safe-7.1 {tests that everything works at high level} {
    set i [safe::interpCreate];
    # no error shall occur:
    # (because the default access_path shall include 1st level sub dirs
    #  so package require in a slave works like in the master)
    set v [interp eval $i {package require http 1}]
    # no error shall occur:
    interp eval $i {http_config};
    safe::interpDelete $i
    set v
} 1.0

test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
    set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
    # should not add anything (p0)
    set token1 [safe::interpAddToAccessPath $i [info library]]
    # should add as p1
    set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
    # an error shall occur (http is not anymore in the secure 0-level
    # provided deep path)
    list $token1 $token2 \
	    [catch {interp eval $i {package require http 1}} msg] $msg \
	    [safe::interpConfigure $i]\
	    [safe::interpDelete $i]
} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"


# test source control on file name
test safe-8.1 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    list  [catch {$i eval {source}} msg] \
	    $msg \
	    [safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}

# test source control on file name
test safe-8.2 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    list  [catch {$i eval {source}} msg] \
	    $msg \
	    [safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}

test safe-8.3 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [catch {$i eval {source .}} msg] \
	    $msg \
	    $log \
	    [safe::setLogCmd $prevlog; unset log] \
	    [safe::interpDelete $i] ;
} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}


test safe-8.4 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [catch {$i eval {source /abc/def}} msg] \
	    $msg \
	    $log \
	    [safe::setLogCmd $prevlog; unset log] \
	    [safe::interpDelete $i] ;
} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}


test safe-8.5 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [catch {$i eval {source [file join [info lib] blah]}} msg] \
	    $msg \
	    $log \
	    [safe::setLogCmd $prevlog; unset log] \
	    [safe::interpDelete $i] ;
} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}"


test safe-8.6 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
	    $msg \
	    $log \
	    [safe::setLogCmd $prevlog; unset log] \
	    [safe::interpDelete $i] ;
} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}"


test safe-8.7 {safe source control on file} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
		 msg] \
	    $msg \
	    $log \
	    [safe::setLogCmd $prevlog; unset log] \
	    [safe::interpDelete $i] ;
} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}"

test safe-8.8 {safe source forbids -rsrc} {
    set i "a";
    catch {safe::interpDelete $i}
    safe::interpCreate $i;
    list  [catch {$i eval {source -rsrc Init}} msg] \
	    $msg \
	    [safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}


test safe-9.1 {safe interps' deleteHook} {
    set i "a";
    catch {safe::interpDelete $i}
    set res {}
    proc testDelHook {args} {
	global res;
	# the interp still exists at that point
	interp eval a {set delete 1}
	# mark that we've been here (successfully)
	set res $args;
    }
    safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
    list [interp eval $i exit] $res
} {{} {arg1 arg2 a}}

test safe-9.2 {safe interps' error in deleteHook} {
    set i "a";
    catch {safe::interpDelete $i}
    set res {}
    proc testDelHook {args} {
	global res;
	# the interp still exists at that point
	interp eval a {set delete 1}
	# mark that we've been here (successfully)
	set res $args;
	# create an exception
	error "being catched";
    }
    set log {};
    proc safe-test-log {str} {global log; lappend log $str}
    safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
    set prevlog [safe::setLogCmd];
    safe::setLogCmd safe-test-log;
    list  [safe::interpDelete $i] $res \
	    $log \
	    [safe::setLogCmd $prevlog; unset log];
} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}


test safe-9.3 {dual specification of statics} {
    list [catch {safe::interpCreate -stat true -nostat} msg] $msg
} {1 {conflicting values given for -statics and -noStatics}}

test safe-9.4 {dual specification of statics} {
    # no error shall occur
    safe::interpDelete [safe::interpCreate -stat false -nostat]
} {}

test safe-9.5 {dual specification of nested} {
    list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
} {1 {conflicting values given for -nested and -nestedLoadOk}}

test safe-9.6 {interpConfigure widget like behaviour} {
   # this test shall work, don't try to "fix it" unless
   # you *really* know what you are doing (ie you are me :p) -- dl
   list [set i [safe::interpCreate \
	                           -noStatics \
                                   -nestedLoadOk \
	                           -deleteHook {foo bar}];
         safe::interpConfigure $i -accessPath /foo/bar ;
         safe::interpConfigure $i]\
	[safe::interpConfigure $i -aCCess]\
	[safe::interpConfigure $i -nested]\
	[safe::interpConfigure $i -statics]\
	[safe::interpConfigure $i -DEL]\
	[safe::interpConfigure $i -accessPath /blah -statics 1;
	 safe::interpConfigure $i]\
	[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
	 safe::interpConfigure $i]
} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}}


# testing that nested and statics do what is advertised
# (we use a static package : Tcltest)

if {[catch {package require Tcltest} msg]} {
    puts "This application hasn't been compiled with Tcltest"
    puts "skipping remining safe test that relies on it."
} else {

    # we use the Tcltest package , which has no Safe_Init

test safe-10.1 {testing statics loading} {
    set i [safe::interpCreate]
    list \
	    [catch {interp eval $i {load {} Tcltest}} msg] \
	    $msg \
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}

test safe-10.2 {testing statics loading / -nostatics} {
    set i [safe::interpCreate -nostatics]
    list \
	    [catch {interp eval $i {load {} Tcltest}} msg] \
	    $msg \
            [safe::interpDelete $i];
} {1 {permission denied (static package)} {}}



test safe-10.3 {testing nested statics loading / no nested by default} {
    set i [safe::interpCreate]
    list \
	    [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
	    $msg \
            [safe::interpDelete $i];
} {1 {permission denied (nested load)} {}}


test safe-10.4 {testing nested statics loading / -nestedloadok} {
    set i [safe::interpCreate -nestedloadok]
    list \
	    [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
	    $msg \
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}


}