ttk.tcl 4.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176
  1. #
  2. # Ttk widget set initialization script.
  3. #
  4. ### Source library scripts.
  5. #
  6. namespace eval ::ttk {
  7. variable library
  8. if {![info exists library]} {
  9. set library [file dirname [info script]]
  10. }
  11. }
  12. source -encoding utf-8 [file join $::ttk::library fonts.tcl]
  13. source -encoding utf-8 [file join $::ttk::library cursors.tcl]
  14. source -encoding utf-8 [file join $::ttk::library utils.tcl]
  15. ## ttk::deprecated $old $new --
  16. # Define $old command as a deprecated alias for $new command
  17. # $old and $new must be fully namespace-qualified.
  18. #
  19. proc ttk::deprecated {old new} {
  20. interp alias {} $old {} ttk::do'deprecate $old $new
  21. }
  22. ## do'deprecate --
  23. # Implementation procedure for deprecated commands --
  24. # issue a warning (once), then re-alias old to new.
  25. #
  26. proc ttk::do'deprecate {old new args} {
  27. deprecated'warning $old $new
  28. interp alias {} $old {} $new
  29. uplevel 1 [linsert $args 0 $new]
  30. }
  31. ## deprecated'warning --
  32. # Gripe about use of deprecated commands.
  33. #
  34. proc ttk::deprecated'warning {old new} {
  35. puts stderr "$old deprecated -- use $new instead"
  36. }
  37. ### Backward-compatibility.
  38. #
  39. #
  40. # Make [package require tile] an effective no-op;
  41. # see SF#3016598 for discussion.
  42. #
  43. package ifneeded tile 0.8.6 { package provide tile 0.8.6 }
  44. # ttk::panedwindow used to be named ttk::paned. Keep the alias for now.
  45. #
  46. ::ttk::deprecated ::ttk::paned ::ttk::panedwindow
  47. ### ::ttk::ThemeChanged --
  48. # Called from [::ttk::style theme use].
  49. # Sends a <<ThemeChanged>> virtual event to all widgets.
  50. #
  51. proc ::ttk::ThemeChanged {} {
  52. set Q .
  53. while {[llength $Q]} {
  54. set QN [list]
  55. foreach w $Q {
  56. event generate $w <<ThemeChanged>>
  57. foreach child [winfo children $w] {
  58. lappend QN $child
  59. }
  60. }
  61. set Q $QN
  62. }
  63. }
  64. ### Public API.
  65. #
  66. proc ::ttk::themes {{ptn *}} {
  67. set themes [list]
  68. foreach pkg [lsearch -inline -all -glob [package names] ttk::theme::$ptn] {
  69. lappend themes [namespace tail $pkg]
  70. }
  71. return $themes
  72. }
  73. ## ttk::setTheme $theme --
  74. # Set the current theme to $theme, loading it if necessary.
  75. #
  76. proc ::ttk::setTheme {theme} {
  77. variable currentTheme ;# @@@ Temp -- [::ttk::style theme use] doesn't work
  78. if {$theme ni [::ttk::style theme names]} {
  79. package require ttk::theme::$theme
  80. }
  81. ::ttk::style theme use $theme
  82. set currentTheme $theme
  83. }
  84. ### Load widget bindings.
  85. #
  86. source -encoding utf-8 [file join $::ttk::library button.tcl]
  87. source -encoding utf-8 [file join $::ttk::library menubutton.tcl]
  88. source -encoding utf-8 [file join $::ttk::library scrollbar.tcl]
  89. source -encoding utf-8 [file join $::ttk::library scale.tcl]
  90. source -encoding utf-8 [file join $::ttk::library progress.tcl]
  91. source -encoding utf-8 [file join $::ttk::library notebook.tcl]
  92. source -encoding utf-8 [file join $::ttk::library panedwindow.tcl]
  93. source -encoding utf-8 [file join $::ttk::library entry.tcl]
  94. source -encoding utf-8 [file join $::ttk::library combobox.tcl] ;# dependency: entry.tcl
  95. source -encoding utf-8 [file join $::ttk::library spinbox.tcl] ;# dependency: entry.tcl
  96. source -encoding utf-8 [file join $::ttk::library treeview.tcl]
  97. source -encoding utf-8 [file join $::ttk::library sizegrip.tcl]
  98. ## Label and Labelframe bindings:
  99. # (not enough to justify their own file...)
  100. #
  101. bind TLabelframe <<Invoke>> { tk::TabToWindow [tk_focusNext %W] }
  102. bind TLabel <<Invoke>> { tk::TabToWindow [tk_focusNext %W] }
  103. ### Load settings for built-in themes:
  104. #
  105. proc ttk::LoadThemes {} {
  106. variable library
  107. # "default" always present:
  108. uplevel #0 [list source -encoding utf-8 [file join $library defaults.tcl]]
  109. set builtinThemes [style theme names]
  110. foreach {theme scripts} {
  111. classic classicTheme.tcl
  112. alt altTheme.tcl
  113. clam clamTheme.tcl
  114. winnative winTheme.tcl
  115. xpnative {xpTheme.tcl vistaTheme.tcl}
  116. aqua aquaTheme.tcl
  117. } {
  118. if {[lsearch -exact $builtinThemes $theme] >= 0} {
  119. foreach script $scripts {
  120. uplevel #0 [list source -encoding utf-8 [file join $library $script]]
  121. }
  122. }
  123. }
  124. }
  125. ttk::LoadThemes; rename ::ttk::LoadThemes {}
  126. ### Select platform-specific default theme:
  127. #
  128. # Notes:
  129. # + On OSX, aqua theme is the default
  130. # + On Windows, xpnative takes precedence over winnative if available.
  131. # + On X11, users can use the X resource database to
  132. # specify a preferred theme (*TkTheme: themeName);
  133. # otherwise "default" is used.
  134. #
  135. proc ttk::DefaultTheme {} {
  136. set preferred [list aqua vista xpnative winnative]
  137. set userTheme [option get . tkTheme TkTheme]
  138. if {$userTheme ne {} && ![catch {
  139. uplevel #0 [list package require ttk::theme::$userTheme]
  140. }]} {
  141. return $userTheme
  142. }
  143. foreach theme $preferred {
  144. if {[package provide ttk::theme::$theme] ne ""} {
  145. return $theme
  146. }
  147. }
  148. return "default"
  149. }
  150. ttk::setTheme [ttk::DefaultTheme] ; rename ttk::DefaultTheme {}
  151. #*EOF*