开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
safe.test
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：7k
源码类别：

通讯编程

开发平台：

Visual C++

safe.test：源码内容
  1. # This file is a Tcl script to test the Safe Tk facility. It is organized
  2. # in the standard fashion for Tk tests.
  3. #
  4. # Copyright (c) 1994 The Regents of the University of California.
  5. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  6. # Copyright (c) 1998-1999 by Scriptics Corporation.
  7. # All rights reserved.
  8. #
  9. # RCS: @(#) $Id: safe.test,v 1.10.2.2 2005/06/06 22:46:51 dgp Exp $
  11. package require tcltest 2.1
  12. namespace import -force tcltest::configure
  13. namespace import -force tcltest::testsDirectory
  14. configure -testdir [file join [pwd] [file dirname [info script]]]
  15. configure -loadfile [file join [testsDirectory] constraints.tcl]
  16. tcltest::loadTestedCommands
  18. ## NOTE: Any time tests fail here with an error like:
  20. # Can't find a usable tk.tcl in the following directories:
  21. #     {$p(:26:)}
  22. # 
  23. # $p(:26:)/tk.tcl: script error
  24. # script error
  25. #     invoked from within
  26. # "source {$p(:26:)/tk.tcl}"
  27. #     ("uplevel" body line 1)
  28. #     invoked from within
  29. # "uplevel #0 [list source $file]"
  30. # 
  31. # 
  32. # This probably means that tk wasn't installed properly.
  34. ## it indicates that something went wrong sourcing tk.tcl.
  35. ## Ensure that any changes that occured to tk.tcl will work or
  36. ## are properly prevented in a safe interpreter.  -- hobbs
  38. # The set of hidden commands is platform dependent:
  40. if {"$tcl_platform(platform)" == "macintosh"} {
  41.     set hidden_cmds {beep bell cd clipboard echo encoding exit fconfigure file glob grab load ls menu open pwd selection send socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile toplevel wm}
  42. } elseif {"$tcl_platform(platform)" == "windows"} {
  43.     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 wm}
  44. } else {
  45.     set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel wm}
  46. }
  48. set saveAutoPath $::auto_path
  49. set ::auto_path [list [info library] $::tk_library]
  51. test safe-1.1 {Safe Tk loading into an interpreter} {
  52.     catch {safe::interpDelete a}
  53.     safe::loadTk [safe::interpCreate a]
  54.     safe::interpDelete a
  55.     set x {}
  56.     set x
  57. } ""
  58. test safe-1.2 {Safe Tk loading into an interpreter} {
  59.     catch {safe::interpDelete a}
  60.     safe::interpCreate a
  61.     safe::loadTk a
  62.     set l [lsort [interp hidden a]]
  63.     safe::interpDelete a
  64.     set l
  65. } $hidden_cmds
  66. test safe-1.3 {Safe Tk loading into an interpreter} -body {
  67.     catch {safe::interpDelete a}
  68.     safe::interpCreate a
  69.     safe::loadTk a
  70.     set l [lsort [interp aliases a]]
  71.     safe::interpDelete a
  72.     set l
  73. } -match glob -result {*encoding*exit*file*load*source*}
  75. test safe-2.1 {Unsafe commands not available} {
  76.     catch {safe::interpDelete a}
  77.     safe::interpCreate a
  78.     safe::loadTk a
  79.     set status broken
  80.     if {[catch {interp eval a {toplevel .t}} msg]} {
  81. set status ok
  82.     }
  83.     safe::interpDelete a
  84.     set status
  85. } ok
  86. test safe-2.2 {Unsafe commands not available} {
  87.     catch {safe::interpDelete a}
  88.     safe::interpCreate a
  89.     safe::loadTk a
  90.     set status broken
  91.     if {[catch {interp eval a {menu .m}} msg]} {
  92. set status ok
  93.     }
  94.     safe::interpDelete a
  95.     set status
  96. } ok
  97. test safe-2.3 {Unsafe subcommands not available} {
  98.     catch {safe::interpDelete a}
  99.     safe::interpCreate a
  100.     safe::loadTk a
  101.     set status broken
  102.     if {[catch {interp eval a {tk appname}} msg]} {
  103. set status ok
  104.     }
  105.     safe::interpDelete a
  106.     list $status $msg
  107. } {ok {appname not accessible in a safe interpreter}}
  108. test safe-2.4 {Unsafe subcommands not available} {
  109.     catch {safe::interpDelete a}
  110.     safe::interpCreate a
  111.     safe::loadTk a
  112.     set status broken
  113.     if {[catch {interp eval a {tk scaling}} msg]} {
  114. set status ok
  115.     }
  116.     safe::interpDelete a
  117.     list $status $msg
  118. } {ok {scaling not accessible in a safe interpreter}}
  120. test safe-3.1 {Unsafe commands are available hidden} {
  121.     catch {safe::interpDelete a}
  122.     safe::interpCreate a
  123.     safe::loadTk a
  124.     set status ok
  125.     if {[catch {interp invokehidden a toplevel .t} msg]} {
  126. set status broken
  127.     }
  128.     safe::interpDelete a
  129.     set status
  130. } ok
  131. test safe-3.2 {Unsafe commands are available hidden} {
  132.     catch {safe::interpDelete a}
  133.     safe::interpCreate a
  134.     safe::loadTk a
  135.     set status ok
  136.     if {[catch {interp invokehidden a menu .m} msg]} {
  137. set status broken
  138.     }
  139.     safe::interpDelete a
  140.     set status
  141. } ok
  143. test safe-4.1 {testing loadTk} {
  144.     # no error shall occur, the user will
  145.     # eventually see a new toplevel
  146.     set i [safe::loadTk [safe::interpCreate]]
  147.     interp eval $i {button .b -text "hello world!"; pack .b}
  148.     # lets don't update because it might imply that the user has
  149.     # to position the window (if the wm does not do it automatically)
  150.     # and thus make the test suite not runable non interactively
  151.     safe::interpDelete $i
  152. } {}
  154. test safe-4.2 {testing loadTk -use} {
  155.     set w .safeTkFrame
  156.     catch {destroy $w}
  157.     frame $w -container 1;
  158.     pack .safeTkFrame
  159.     set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
  160.     interp eval $i {button .b -text "hello world!"; pack .b}
  161.     safe::interpDelete $i
  162.     destroy $w
  163. } {}
  165. test safe-5.1 {loading Tk in safe interps without master's clearance} {
  166.     set i [safe::interpCreate]
  167.     catch {interp eval $i {load {} Tk}} msg
  168.     safe::interpDelete $i
  169.     set msg
  170. } {not allowed to start Tk by master's safe::TkInit}
  172. test safe-5.2 {multi-level Tk loading with clearance} {
  173.     # No error shall occur in that test and no window
  174.     # shall remain at the end.
  175.     set i [safe::interpCreate]
  176.     set j [list $i x]
  177.     set j [safe::interpCreate $j]
  178.     safe::loadTk $j
  179.     interp eval $j {
  180. button .b -text Ok -command {destroy .}
  181. pack .b
  182. # tkwait window . ; # for interactive testing/debugging
  183.     }
  184.     safe::interpDelete $j
  185.     safe::interpDelete $i
  186. } {}
  188. test safe-6.1 {loadTk -use windowPath} {
  189.     set w .safeTkFrame
  190.     catch {destroy $w}
  191.     frame $w -container 1;
  192.     pack .safeTkFrame
  193.     set i [safe::loadTk [safe::interpCreate] -use $w]
  194.     interp eval $i {button .b -text "hello world!"; pack .b}
  195.     safe::interpDelete $i
  196.     destroy $w
  197. } {}
  199. test safe-6.2 {loadTk -use windowPath, conflicting -display} {
  200.     set w .safeTkFrame
  201.     catch {destroy $w}
  202.     frame $w -container 1;
  203.     pack .safeTkFrame
  204.     set i     [safe::interpCreate]
  205.     catch {safe::loadTk $i -use $w -display :23.56} msg
  206.     safe::interpDelete $i
  207.     destroy $w
  208.     string range $msg 0 36
  209. } {conflicting -display :23.56 and -use }
  212. test safe-7.1 {canvas printing} {
  213.     set i [safe::loadTk [safe::interpCreate]]
  214.     set r [catch {interp eval $i {canvas .c; .c postscript}}]
  215.     safe::interpDelete $i
  216.     set r
  217. } 0
  219. # cleanup
  220. set ::auto_path $saveAutoPath
  221. unset hidden_cmds
  222. ::tcltest::cleanupTests
  223. return