Posted to tcl by patthoyts at Mon Oct 27 21:47:17 GMT 2008view raw

  1. package require Tk
  2.  
  3. proc Main {args} {
  4. array set opts [linsert $args 0 -safe 1 -frame 0]
  5.  
  6. wm withdraw .
  7. set container 1
  8. if {$opts(-frame)} { set container 0 }
  9. set dlg [toplevel .test -container $container]
  10. #wm withdraw $dlg
  11.  
  12. if {$opts(-frame)} {
  13. wm title $dlg "Embedding Safe-Tk in Frame"
  14. pack [frame $dlg.f -container 1] -fill both -expand 1
  15. set slave [::safe::interpCreate slave]
  16. bind $dlg <Destroy> [list interp delete $slave]
  17. ::safe::loadTk $slave -use $dlg.f
  18. $slave eval {
  19. pack [text .t] -fill both -expand 1
  20. .t insert end "Tcl $tcl_patchLevel Tk $tk_patchLevel\n" {}
  21. update
  22. }
  23. } elseif {$opts(-safe)} {
  24. wm title $dlg "Embedding Safe-Tk"
  25. set slave [::safe::interpCreate slave]
  26. bind $dlg <Destroy> [list interp delete $slave]
  27. ::safe::loadTk $slave -use $dlg
  28. $slave eval {
  29. pack [text .t] -fill both -expand 1
  30. .t insert end "Tcl $tcl_patchLevel Tk $tk_patchLevel\n" {}
  31. update
  32. }
  33. } else {
  34. wm title $dlg "Embedding Tk"
  35. set slave [interp create slave]
  36. bind $dlg <Destroy> [list interp delete $slave]
  37. $slave eval [string map [list %W [winfo id $dlg]] {
  38. set argv [list -use %W]
  39. load {} Tk
  40. pack [text .t] -fill both -expand 1
  41. .t insert end "Tcl $tcl_patchLevel Tk $tk_patchLevel\n" {}
  42. update
  43. }]
  44. }
  45.  
  46.  
  47. bind $dlg <Control-F2> {console show}
  48. #wm deiconify $dlg
  49. tkwait window $dlg
  50. }
  51.  
  52. if {!$tcl_interactive} {
  53. set r [catch [linsert $argv 0 Main] err]
  54. if {$r} {
  55. tk_messageBox -icon error -title "Script error" \
  56. -message $err -detail $errorInfo
  57. }
  58. exit
  59. }