scripts/theme.itk

   1 # vim: foldmarker=<<<,>>>
   2
   3 # Fires signals:
   4 #       onchange                - Fired when icon set has changed
   5
   6 class tlc::Theme {
   7         inherit tlc::Handlers tlc::Baselog
   8
   9         constructor {args} {}
  10         destructor {}
  11
  12         public {
  13                 variable icondir                                ""              need_rebuild_icons
  14                 variable formats                                {gif}   need_rebuild_icons
  15                 variable create_image_command   "image create photo -file"
  16
  17                 method need_rebuild_icons {}
  18                 method get_icon {name}
  19                 method setting {tag}
  20                 method adjusthexcolor {color multr {multg -1} {multb -1}}
  21         }
  22
  23         protected {
  24                 method normalize_tag {tag}
  25                 method min {args}
  26         }
  27
  28         private {
  29                 variable default_icondir
  30                 variable icons
  31                 variable afterid                        ""
  32                 variable names {
  33                         error
  34                         exclamation
  35                         info
  36                         no_entry_sign
  37                         passwd
  38                         question_sign
  39                         cal_icon
  40                         cal_icon_small
  41                         default_panelbar_icon
  42                 }
  43                 variable system
  44
  45                 method rebuild_icons {}
  46                 method destroy_icons {}
  47         }
  48 }
  49
  50
  51 body tlc::Theme::constructor {args} { #<<<1
  52         array set icons         {}
  53         array set system        {}
  54         set default_icondir             [file join $::tlc::library scripts images]
  55
  56         set button      [button ._tlc_tmp]
  57         set entry       [entry ._tlc_tmp2]
  58
  59         if {$::tcl_platform(platform) == "windows"} {
  60                 set system(foreground)                  systemButtonText
  61                 set system(background)                  systemButtonFace
  62                 set system(disabledbackground)  systemInactiveBorder
  63                 set system(disabledforeground)  systemButtonText
  64                 set system(readonlybackground)  systemInactiveBorder
  65                 set system(selectbackground)    systemHighlight
  66                 set system(selectforeground)    systemHighlightText
  67                 set system(tinyfont)                    {"MS Sans Serif" -6}
  68                 set system(smallfont)                   {"MS Sans Serif" -6}
  69                 set system(font)                                {"MS Sans Serif" -8}
  70                 set system(boldfont)                    {"MS Sans Serif" -8 bold}
  71                 set system(hugefont)                    {"MS Sans Serif" -24 bold}
  72                 set system(textbackground)              systemWindow
  73         } else {
  74                 set system(foreground)                  [$button cget -foreground]
  75                 set system(background)                  [$button cget -background]
  76                 set system(disabledbackground)  [$entry cget -disabledbackground]
  77                 set system(disabledforeground)  [$entry cget -disabledforeground]
  78                 set system(readonlybackground)  [$entry cget -readonlybackground]
  79                 set system(selectforeground)    [$entry cget -selectforeground]
  80                 set system(selectbackground)    [$entry cget -selectbackground]
  81                 set system(tinyfont)                    {Helvetica -8 {}}
  82                 set system(smallfont)                   {Helvetica -10 {}}
  83                 set system(font)                                [lrange [$button cget -font] 0 1]
  84                 if {[llength $system(font)] < 2} {
  85                         lappend system(font)    -12
  86                 }
  87                 set system(boldfont)                    [concat [lrange $system(font) 0 1] {bold}]
  88                 set system(hugefont)                    {Arial -24 bold}
  89                 set system(textbackground)              "#ffffff"
  90         }
  91         set system(fixedfont)                   {Courier -12 {}}
  92         set system(borderwidth)                 [$button cget -borderwidth]
  93         set system(highlightbackground) [$button cget -highlightbackground]
  94         set system(highlightthickness)  [$button cget -highlightthickness]
  95         set system(highlightcolor)              [$button cget -highlightcolor]
  96         set system(selectborderwidth)   [$entry cget -selectborderwidth]
  97         set system(entryrelief)                 [$entry cget -relief]
  98         set system(entryborderwidth)    [$entry cget -borderwidth]
  99         set system(formpadding)                 1
 100
 101         # Derivative values <<<
 102         set system(alt_textbackground) \
 103                         [adjusthexcolor $system(textbackground) 0.9 0.9 0.95]
 104         # Derivative values >>>
 105
 106         destroy $button
 107         destroy $entry
 108
 109         eval configure $args
 110
 111         need_rebuild_icons
 112 }
 113
 114
 115 body tlc::Theme::destructor {} { #<<<1
 116         after cancel $afterid; set afterid      ""
 117         destroy_icons
 118 }
 119
 120
 121 body tlc::Theme::need_rebuild_icons {} { #<<<1
 122         if {$afterid != ""} return
 123         set afterid                     [after idle [code $this rebuild_icons]]
 124 }
 125
 126
 127 body tlc::Theme::rebuild_icons {} { #<<<1
 128         after cancel $afterid;  set afterid             ""
 129         destroy_icons
 130
 131         foreach name $names {
 132                 set filename_base       [file join $icondir $name]
 133                 set filename            ""
 134                 foreach ext $formats {
 135                         if {[file exists ${filename_base}.$ext]} {
 136                                 set filename    ${filename_base}.$ext
 137                                 break
 138                         }
 139                 }
 140                 if {$filename == ""} {
 141                         set filename    [file join $default_icondir ${name}.gif]
 142                         set icons($name)        [image create photo -file $filename]
 143                 } else {
 144                         set icons($name)        [uplevel #0 $create_image_command [list $filename]]
 145                 }
 146         }
 147
 148         invoke_handlers onchange
 149 }
 150
 151
 152 body tlc::Theme::destroy_icons {} { #<<<1
 153         foreach {name image} [array get icons] {
 154                 image delete $image
 155                 array unset icons $name
 156         }
 157 }
 158
 159
 160 body tlc::Theme::get_icon {name} { #<<<1
 161         if {$afterid != ""} rebuild_icons
 162
 163         if {![info exists icons($name)]} {
 164                 error "Requested icon does not exist!"
 165         }
 166
 167         return $icons($name)
 168 }
 169
 170
 171 body tlc::Theme::setting {tag} { #<<<1
 172         set tag [normalize_tag $tag]
 173
 174         switch -- $tag {
 175                 selectborderwidth               {return 0}
 176                 texthighlightbackground {return "#d9d9d9"}
 177                 hidebg                                  {return "#d9d9d9"}
 178                 framerelief                             {return "sunken"}
 179                 frameborderwidth                {return 0}
 180                 button_pady                             {return [expr {$::tcl_platform(platform) == "windows" ? 1 : 2}]}
 181         }
 182
 183         if {![info exists system($tag)]} {
 184                 return -code error -errorcode [list invalid_setting $tag] \
 185                                 "No such theme setting: ($tag)"
 186         }
 187
 188         return $system($tag)
 189 }
 190
 191
 192 body tlc::Theme::normalize_tag {tag} { #<<<1
 193         switch -- $tag {
 194                 fg                                      {return "foreground"}
 195                 bg                                      {return "background"}
 196                 bd                                      {return "borderwidth"}
 197                 enabledforeground       {return "foreground"}
 198                 texthighlightbackground {return "highlightbackground"}
 199
 200                 default         {return $tag}
 201         }
 202 }
 203
 204
 205 body tlc::Theme::min {args} { #<<<1
 206         set min         [lindex $args 0]
 207         foreach a [lrange $args 1 end] {
 208                 if {$a < $min} {set min $a}
 209         }
 210
 211         return $min
 212 }
 213
 214
 215 body tlc::Theme::adjusthexcolor {color multr {multg -1} {multb -1}} { #<<<1
 216         # this proc to adjust a hex triplet color by a percentage and output as a
 217         # color.
 218         # the outputs sometimes seem a little long and odd, but they work fine
 219         # mult should be a fractional value like 0.8 or 1.25
 220         if {$multg == -1} {set multg $multr}
 221         if {$multb == -1} {set multb $multr}
 222
 223         set maxrgb [winfo rgb . #ffffff]
 224         set maxval [lindex $maxrgb 0]
 225
 226         set rbg [winfo rgb . $color]
 227         set ret [format "#%02x%02x%02x" \
 228                 [min [expr {round([lindex $rbg 0] * $multr * 255/$maxval)}] 255] \
 229                 [min [expr {round([lindex $rbg 1] * $multg * 255/$maxval)}] 255] \
 230                 [min [expr {round([lindex $rbg 2] * $multb * 255/$maxval)}] 255]]
 231
 232         return $ret
 233 }
 234
 235