mingw/lib/tk8.5/ttk/ttk.tcl

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