1# $Id$ 2 3########################################################################## 4auto_load Button 5rename Button::create Button::create_old 6 7proc Button::create {path args} { 8 9 set new_args {} 10 foreach {attr val} $args { 11 switch -- $attr { 12 -background { } 13 default { lappend new_args $attr $val } 14 } 15 } 16 17 eval [list Button::create_old $path] $new_args 18} 19 20########################################################################## 21rename menu menu_old 22 23proc menu {path args} { 24 25 set new_args {} 26 foreach {attr val} $args { 27 switch -- $attr { 28 -background { } 29 default { lappend new_args $attr $val } 30 } 31 } 32 33 eval [list menu_old $path] $new_args 34} 35 36########################################################################## 37if {[info tclversion] >= 8.4} { 38 39 rename frame frame_old 40 41 proc frame {path args} { 42 43 set new_args {} 44 foreach {attr val} $args { 45 switch -- $attr { 46 -class { 47 lappend new_args $attr $val 48 if {$val == "Tree"} { 49 lappend new_args -padx 0 50 } 51 } 52 default { lappend new_args $attr $val } 53 } 54 } 55 56 eval [list frame_old $path] $new_args 57 } 58} 59 60########################################################################## 61auto_load Tree 62 63proc Tree::_see {path idn {side "none"}} { 64 set bbox [$path.c bbox $idn] 65 set scrl [$path.c cget -scrollregion] 66 67 set ymax [lindex $scrl 3] 68 set dy [$path.c cget -yscrollincrement] 69 set yv [$path yview] 70 set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}] 71 set yv1 [expr {int([lindex $yv 1]*$ymax/$dy + 0.1)}] 72 set y [expr {int([lindex [$path.c coords $idn] 1]/$dy)}] 73 if { $y < $yv0 } { 74 $path.c yview scroll [expr {$y-$yv0}] units 75 } elseif { $y >= $yv1 } { 76 $path.c yview scroll [expr {$y-$yv1+1}] units 77 } 78 79 set xmax [lindex $scrl 2] 80 set dx [$path.c cget -xscrollincrement] 81 set xv [$path xview] 82 if { ![string compare $side "none"] } { 83 set x0 [expr {int([lindex $bbox 0]/$dx)}] 84 set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}] 85 set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}] 86 if { $x0 >= $xv1 || $x0 < $xv0 } { 87 $path.c xview scroll [expr {$x0-$xv0}] units 88 } 89 } elseif { ![string compare $side "right"] } { 90 set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}] 91 set x1 [expr {int([lindex $bbox 2]/$dx)}] 92 if { $x1 >= $xv1 } { 93 $path.c xview scroll [expr {$x1-$xv1+1}] units 94 } 95 } else { 96 set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}] 97 set x0 [expr {int([lindex $bbox 0]/$dx)}] 98 if { $x0 < $xv0 } { 99 $path.c xview scroll [expr {$x0-$xv0}] units 100 } 101 } 102} 103 104rename Tree::create Tree::create:old 105 106proc Tree::create {path args} { 107 eval [list Tree::create:old $path] $args 108 109 set deltax 0 110 set deltay 0 111 foreach {key val} $args { 112 switch -- $key { 113 -deltax { set deltax 1 } 114 -deltay { set deltay 1 } 115 } 116 } 117 118 if {!$deltax} { 119 $path configure -deltax [font measure $::ChatFont M] 120 } 121 122 if {!$deltay} { 123 $path configure -deltay [font metrics $::ChatFont -linespace] 124 } 125 126 Tree::bindText $path <Control-Button-1> [list $path selection set] 127 Tree::bindImage $path <Control-Button-1> [list $path selection set] 128 129 return $path 130} 131 132########################################################################## 133if {0 && [info tclversion] >= 8.5} { 134 135 proc PanedWin {path args} { 136 set newargs [list -showhandle 0] 137 set pad 0 138 foreach {key val} $args { 139 switch -- $key { 140 -side { 141 switch -- $val { 142 left - 143 right { 144 lappend newargs -orient vertical 145 } 146 top - 147 bottom { 148 lappend newargs -orient horizontal 149 } 150 } 151 } 152 -pad { 153 set pad [expr {$pad + $val}] 154 } 155 -width { 156 set pad [expr {$pad + ($val >> 2)}] 157 } 158 } 159 } 160 161 if {$pad > 0} { 162 lappend newargs -sashpad $pad 163 } 164 165 return [eval [list panedwindow $path] $newargs] 166 } 167 168 proc PanedWinAdd {path args} { 169 set newargs {} 170 foreach {key val} $args { 171 switch -- $key { 172 -minsize { 173 lappend newargs -minsize $val 174 } 175 -weight { 176 if {$val == 0} { 177 lappend newargs -stretch never 178 } else { 179 lappend newargs -stretch always 180 } 181 } 182 } 183 } 184 set idx [llength [$path panes]] 185 set f [frame $path.frame$idx] 186 eval [list $path add $f] $newargs 187 return $f 188 } 189 190 proc PanedWinConf {path index args} { 191 lassign $args key val 192 set f [lindex [$path panes] $index] 193 switch -- [llength $args] { 194 1 { 195 switch -- $key { 196 -width { 197 return [$path panecget $f -width] 198 } 199 default { 200 return -code error "PanedWinConf: Unknown option $key" 201 } 202 } 203 } 204 2 { 205 switch -- $key { 206 -width { 207 puts "$index $f $val" 208 $path paneconfigure $f -width $val 209 } 210 default { 211 return -code error "PanedWinConf: Unknown option $key" 212 } 213 } 214 } 215 default { 216 return -code error "PanedWinConf: Illegal number of arguments" 217 } 218 } 219 } 220 221} else { 222 223 proc PanedWin {path args} { 224 if {[catch { 225 eval [list PanedWindow $path] $args -activator line 226 } res]} { 227 return [eval [list PanedWindow $path] $args] 228 } else { 229 return $res 230 } 231 } 232 233 proc PanedWinAdd {path args} { 234 set res [eval [list $path add] $args] 235 catch { 236 set activator [Widget::getoption $path -activator] 237 if {$activator == ""} { 238 if { $::tcl_platform(platform) != "windows" } { 239 set activator button 240 } else { 241 set activator line 242 } 243 } 244 245 if {$activator == "line"} { 246 set side [Widget::getoption $path -side] 247 set num $PanedWindow::_panedw($path,nbpanes) 248 incr num -1 249 if {$num > 0} { 250 $path.sash$num.sep configure -relief flat 251 if {$side == "top" || $side == "bottom"} { 252 place configure $path.sash$num.sep -width 4 253 } else { 254 place configure $path.sash$num.sep -height 4 255 } 256 } 257 } 258 } 259 return $res 260 } 261 262 proc PanedWinConf {path index args} { 263 lassign $args key val 264 set f [winfo parent [$path getframe $index]] 265 switch -- [llength $args] { 266 1 { 267 switch -- $key { 268 -width { 269 return [$f cget -width] 270 } 271 default { 272 return -code error "PanedWinConf: Unknown option $key" 273 } 274 } 275 } 276 2 { 277 switch -- $key { 278 -width { 279 $f configure -width $val 280 } 281 default { 282 return -code error "PanedWinConf: Unknown option $key" 283 } 284 } 285 } 286 default { 287 return -code error "PanedWinConf: Illegal number of arguments" 288 } 289 } 290 } 291 292} 293 294########################################################################## 295auto_load ComboBox 296 297option add *ComboBox.listRelief ridge widgetDefault 298option add *ComboBox.listBorder 2 widgetDefault 299 300rename ComboBox::_create_popup ComboBox::_create_popup_old 301 302proc ComboBox::_create_popup {path args} { 303 304 eval [list ComboBox::_create_popup_old $path] $args 305 $path.shell configure \ 306 -relief [option get $path listRelief ComboBox] \ 307 -border [option get $path listBorder ComboBox] 308} 309 310rename ComboBox::create ComboBox::create_old 311 312proc ComboBox::create {path args} { 313 set hlthick $::tk_highlightthickness 314 foreach {opt arg} $args { 315 if {[cequal $opt "-highlightthickness"]} { 316 set hlthick $arg 317 } 318 } 319 eval [list ComboBox::create_old $path] $args -highlightthickness 0 320 $path:cmd configure -highlightthickness $hlthick 321 322 return $path 323} 324 325########################################################################## 326auto_load NoteBook 327 328if {![catch { rename NoteBook::_get_page_name NoteBook::_get_page_name:old }]} { 329 proc NoteBook::_get_page_name { path {item current} {tagindex end-1} } { 330 set pagename [NoteBook::_get_page_name:old $path $item $tagindex] 331 if {[catch { NoteBook::_test_page $path $pagename }]} { 332 return [string range [lindex [$path.c gettags $item] 1] 2 end] 333 } else { 334 return $pagename 335 } 336 } 337} 338 339########################################################################## 340if {($::tcl_platform(platform) != "unix") || ($::aquaP)} { 341 auto_load SelectFont 342 343 rename SelectFont::create SelectFont::create:old 344 345 proc SelectFont::create {path args} { 346 eval [list SelectFont::create:old $path] $args 347 348 foreach style {bold italic underline overstrike} { 349 if {![catch { set bd [option get $path.$style \ 350 borderWidth Button] }]} { 351 if {$bd != ""} { 352 $path.$style configure -bd $bd 353 } 354 } 355 } 356 return $path 357 } 358} 359 360########################################################################## 361proc BWidget::bindMouseWheel {widget} {} 362 363########################################################################## 364auto_load Dialog 365 366rename Dialog::create Dialog::create:old 367 368proc Dialog::create {path args} { 369 toplevel $path 370 wm withdraw $path 371 set parent [winfo parent $path] 372 destroy $path 373 set transient 1 374 set newargs {} 375 foreach {key val} $args { 376 switch -- $key { 377 -parent { set parent $val ; lappend newargs -parent $val } 378 -transient { set transient $val } 379 default { lappend newargs $key $val } 380 } 381 } 382 # Do not make a dialog window transient if its parent isn't vewable. 383 # Otherwise it leads to hang of a whole application. 384 if {$parent == ""} { 385 set parent . 386 } 387 if {![winfo viewable [winfo toplevel $parent]] } { 388 set transient 0 389 } 390 eval {Dialog::create:old $path -transient $transient} $newargs 391} 392 393########################################################################## 394 395