1# ------------------------------------------------------------------------------ 2# entry.tcl 3# This file is part of Unifix BWidget Toolkit 4# $Id: entry.tcl,v 1.23 2009/09/06 21:13:55 oberdorfer Exp $ 5# ------------------------------------------------------------------------------ 6# Index of commands: 7# - Entry::create 8# - Entry::configure 9# - Entry::cget 10# - Entry::_destroy 11# - Entry::_init_drag_cmd 12# - Entry::_end_drag_cmd 13# - Entry::_drop_cmd 14# - Entry::_over_cmd 15# - Entry::_auto_scroll 16# - Entry::_scroll 17# ------------------------------------------------------------------------------ 18 19namespace eval Entry { 20 Widget::define Entry entry DragSite DropSite DynamicHelp 21 22 # Note: -textvariable is pulled off of the tk entry and put onto the 23 # BW Entry so that we avoid the TkResource test for it, which screws up 24 # the existance/non-existance bits of the -textvariable. 25 Widget::tkinclude Entry entry :cmd \ 26 remove { -state -background -foreground -textvariable 27 -disabledforeground -disabledbackground } 28 29 set declare [list \ 30 [list -background Color "SystemWindow" 0] \ 31 [list -foreground Color "SystemWindowText" 0] \ 32 [list -disabledbackground Color "SystemButtonFace" 0] \ 33 [list -disabledforeground Color "SystemDisabledText" 0] \ 34 [list -highlightcolor Color "SystemHighlight" 0] \ 35 [list -state Enum normal 0 [list normal disabled]] \ 36 [list -text String "" 0] \ 37 [list -textvariable String "" 0] \ 38 [list -editable Boolean 1 0] \ 39 [list -command String "" 0] \ 40 [list -relief TkResource "" 0 entry] \ 41 [list -borderwidth TkResource "" 0 entry] \ 42 [list -fg Synonym -foreground] \ 43 [list -bg Synonym -background] \ 44 [list -bd Synonym -borderwidth] \ 45 ] 46 47 Widget::declare Entry $declare 48 Widget::addmap Entry "" :cmd { -textvariable {} } 49 50 DynamicHelp::include Entry balloon 51 DragSite::include Entry "" 3 52 DropSite::include Entry { 53 TEXT {move {}} 54 FGCOLOR {move {}} 55 BGCOLOR {move {}} 56 COLOR {move {}} 57 } 58 59 foreach event [bind Entry] { 60 bind BwEntry $event [bind Entry $event] 61 } 62 63 # Copy is kind of a special event. It should be enabled when the 64 # widget is editable but not disabled, and not when the widget is disabled. 65 # To make this a bit easier to manage, we will handle it separately. 66 67 bind BwEntry <<Copy>> {} 68 bind BwEditableEntry <<Copy>> [bind Entry <<Copy>>] 69 70 bind BwEntry <Return> [list Entry::invoke %W] 71 bind BwEntry <Destroy> [list Entry::_destroy %W] 72 bind BwDisabledEntry <Destroy> [list Entry::_destroy %W] 73 74 if {[lsearch [bindtags .] EntryThemeChanged] < 0} { 75 bindtags . [linsert [bindtags .] 1 EntryThemeChanged] 76 } 77} 78 79 80# ------------------------------------------------------------------------------ 81# Command Entry::create 82# ------------------------------------------------------------------------------ 83proc Entry::create { path args } { 84 variable $path 85 upvar 0 $path data 86 87 array set maps [list Entry {} :cmd {}] 88 array set maps [Widget::parseArgs Entry $args] 89 90 set data(afterid) "" 91 eval [list entry $path] $maps(:cmd) 92 Widget::initFromODB Entry $path $maps(Entry) 93 set state [Widget::getMegawidgetOption $path -state] 94 set editable [Widget::getMegawidgetOption $path -editable] 95 set text [Widget::getMegawidgetOption $path -text] 96 if { $editable && [string equal $state "normal"] } { 97 bindtags $path [list $path BwEntry [winfo toplevel $path] all] 98 $path configure -takefocus 1 -insertontime 600 99 } else { 100 bindtags $path [list $path BwDisabledEntry [winfo toplevel $path] all] 101 $path configure -takefocus 0 -insertontime 0 102 } 103 if { $editable == 0 } { 104 $path configure -cursor left_ptr 105 } 106 if { [string equal $state "disabled"] } { 107 $path configure \ 108 -foreground [Widget::getMegawidgetOption $path -disabledforeground] \ 109 -background [Widget::getMegawidgetOption $path -disabledbackground] 110 } else { 111 $path configure \ 112 -foreground [Widget::getMegawidgetOption $path -foreground] \ 113 -background [Widget::getMegawidgetOption $path -background] 114 bindtags $path [linsert [bindtags $path] 2 BwEditableEntry] 115 } 116 if { [string length $text] } { 117 set varName [$path cget -textvariable] 118 if { ![string equal $varName ""] } { 119 uplevel \#0 [list set $varName [Widget::cget $path -text]] 120 } else { 121 set validateState [$path cget -validate] 122 $path configure -validate none 123 $path delete 0 end 124 $path configure -validate $validateState 125 $path insert 0 [Widget::getMegawidgetOption $path -text] 126 } 127 } 128 129 DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd 1 130 DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd 1 131 DynamicHelp::sethelp $path $path 1 132 133 bind EntryThemeChanged <<ThemeChanged>> \ 134 "+ [namespace current]::_themechanged $path" 135 136 Widget::create Entry $path 137 proc ::$path { cmd args } \ 138 "return \[Entry::_path_command [list $path] \$cmd \$args\]" 139 return $path 140} 141 142 143# ------------------------------------------------------------------------------ 144# Command Entry::configure 145# ------------------------------------------------------------------------------ 146proc Entry::configure { path args } { 147 # Cheat by setting the -text value to the current contents of the entry 148 # This might be better hidden behind a function in ::Widget. 149 set Widget::Entry::${path}:opt(-text) [$path:cmd get] 150 151 set res [Widget::configure $path $args] 152 153 # Extract the modified bits that we are interested in. 154 set vars [list chstate cheditable chfg chdfg chbg chdbg chtext] 155 set opts [list -state -editable -foreground -disabledforeground \ 156 -background -disabledbackground -text] 157 foreach $vars [eval [linsert $opts 0 Widget::hasChangedX $path]] { break } 158 159 if { $chstate || $cheditable } { 160 set state [Widget::getMegawidgetOption $path -state] 161 set editable [Widget::getMegawidgetOption $path -editable] 162 set btags [bindtags $path] 163 if { $editable && [string equal $state "normal"] } { 164 set idx [lsearch $btags BwDisabledEntry] 165 if { $idx != -1 } { 166 bindtags $path [lreplace $btags $idx $idx BwEntry] 167 } 168 $path:cmd configure -takefocus 1 -insertontime 600 169 } else { 170 set idx [lsearch $btags BwEntry] 171 if { $idx != -1 } { 172 bindtags $path [lreplace $btags $idx $idx BwDisabledEntry] 173 } 174 $path:cmd configure -takefocus 0 -insertontime 0 175 if { [string equal [focus] $path] } { 176 focus . 177 } 178 } 179 } 180 181 if { $chstate || $chfg || $chdfg || $chbg || $chdbg } { 182 set state [Widget::getMegawidgetOption $path -state] 183 if { [string equal $state "disabled"] } { 184 $path:cmd configure \ 185 -fg [Widget::cget $path -disabledforeground] \ 186 -bg [Widget::cget $path -disabledbackground] 187 } else { 188 $path:cmd configure \ 189 -fg [Widget::cget $path -foreground] \ 190 -bg [Widget::cget $path -background] 191 } 192 } 193 if { $chstate } { 194 if { [string equal $state "disabled"] } { 195 set idx [lsearch -exact [bindtags $path] BwEditableEntry] 196 if { $idx != -1 } { 197 bindtags $path [lreplace [bindtags $path] $idx $idx] 198 } 199 } else { 200 set idx [expr {[lsearch [bindtags $path] Bw*Entry] + 1}] 201 bindtags $path [linsert [bindtags $path] $idx BwEditableEntry] 202 } 203 } 204 205 if { $cheditable } { 206 if { $editable } { 207 $path:cmd configure -cursor xterm 208 } else { 209 $path:cmd configure -cursor left_ptr 210 } 211 } 212 213 if { $chtext } { 214 # Oh my lordee-ba-goordee 215 # Do some magic to prevent multiple validation command firings. 216 # If there is a textvariable, set that to the right value; if not, 217 # disable validation, delete the old text, enable, then set the text. 218 set varName [$path:cmd cget -textvariable] 219 if { ![string equal $varName ""] } { 220 uplevel \#0 [list set $varName \ 221 [Widget::getMegawidgetOption $path -text]] 222 } else { 223 set validateState [$path:cmd cget -validate] 224 $path:cmd configure -validate none 225 $path:cmd delete 0 end 226 $path:cmd configure -validate $validateState 227 $path:cmd insert 0 [Widget::getMegawidgetOption $path -text] 228 } 229 } 230 231 DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd 232 DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd 233 DynamicHelp::sethelp $path $path 234 235 return $res 236} 237 238 239# ------------------------------------------------------------------------------ 240# Command Entry::cget 241# ------------------------------------------------------------------------------ 242proc Entry::cget { path option } { 243 if { [string equal "-text" $option] } { 244 return [$path:cmd get] 245 } 246 Widget::cget $path $option 247} 248 249 250# ------------------------------------------------------------------------------ 251# Command Entry::invoke 252# ------------------------------------------------------------------------------ 253proc Entry::invoke { path } { 254 if {[llength [set cmd [Widget::getMegawidgetOption $path -command]]]} { 255 uplevel \#0 $cmd 256 } 257} 258 259 260# ------------------------------------------------------------------------------ 261# Command Entry::_path_command 262# ------------------------------------------------------------------------------ 263proc Entry::_path_command { path cmd larg } { 264 switch -exact -- $cmd { 265 configure - cget - invoke { 266 return [eval [linsert $larg 0 Entry::$cmd $path]] 267 } 268 default { 269 return [eval [linsert $larg 0 $path:cmd $cmd]] 270 } 271 } 272} 273 274 275# ------------------------------------------------------------------------------ 276# Command Entry::_init_drag_cmd 277# ------------------------------------------------------------------------------ 278proc Entry::_init_drag_cmd { path X Y top } { 279 variable $path 280 upvar 0 $path data 281 282 if {[llength [set cmd [Widget::getoption $path -draginitcmd]]]} { 283 return [uplevel \#0 $cmd [list $path $X $Y $top]] 284 } 285 set type [Widget::getoption $path -dragtype] 286 if { $type == "" } { 287 set type "TEXT" 288 } 289 if { [set drag [$path get]] != "" } { 290 if { [$path:cmd selection present] } { 291 set idx [$path:cmd index @[expr {$X-[winfo rootx $path]}]] 292 set sel0 [$path:cmd index sel.first] 293 set sel1 [expr {[$path:cmd index sel.last]-1}] 294 if { $idx >= $sel0 && $idx <= $sel1 } { 295 set drag [string range $drag $sel0 $sel1] 296 set data(dragstart) $sel0 297 set data(dragend) [expr {$sel1+1}] 298 if { ![Widget::getoption $path -editable] || 299 [Widget::getoption $path -state] == "disabled" } { 300 return [list $type {copy} $drag] 301 } else { 302 return [list $type {copy move} $drag] 303 } 304 } 305 } else { 306 set data(dragstart) 0 307 set data(dragend) end 308 if { ![Widget::getoption $path -editable] || 309 [Widget::getoption $path -state] == "disabled" } { 310 return [list $type {copy} $drag] 311 } else { 312 return [list $type {copy move} $drag] 313 } 314 } 315 } 316} 317 318 319# ------------------------------------------------------------------------------ 320# Command Entry::_end_drag_cmd 321# ------------------------------------------------------------------------------ 322proc Entry::_end_drag_cmd { path target op type dnddata result } { 323 variable $path 324 upvar 0 $path data 325 326 if {[llength [set cmd [Widget::getoption $path -dragendcmd]]]} { 327 return [uplevel \#0 $cmd [list $path $target $op $type $dnddata $result]] 328 } 329 if { $result && $op == "move" && $path != $target } { 330 $path:cmd delete $data(dragstart) $data(dragend) 331 } 332} 333 334 335# ------------------------------------------------------------------------------ 336# Command Entry::_drop_cmd 337# ------------------------------------------------------------------------------ 338proc Entry::_drop_cmd { path source X Y op type dnddata } { 339 variable $path 340 upvar 0 $path data 341 342 if { $data(afterid) != "" } { 343 after cancel $data(afterid) 344 set data(afterid) "" 345 } 346 if {[llength [set cmd [Widget::getoption $path -dropcmd]]]} { 347 set idx [$path:cmd index @[expr {$X-[winfo rootx $path]}]] 348 return [uplevel \#0 $cmd [list $path $source $idx $op $type $dnddata]] 349 } 350 if { $type == "COLOR" || $type == "FGCOLOR" } { 351 configure $path -foreground $dnddata 352 } elseif { $type == "BGCOLOR" } { 353 configure $path -background $dnddata 354 } else { 355 $path:cmd icursor @[expr {$X-[winfo rootx $path]}] 356 if { $op == "move" && $path == $source } { 357 $path:cmd delete $data(dragstart) $data(dragend) 358 } 359 set sel0 [$path index insert] 360 $path:cmd insert insert $dnddata 361 set sel1 [$path index insert] 362 $path:cmd selection range $sel0 $sel1 363 } 364 return 1 365} 366 367 368# ------------------------------------------------------------------------------ 369# Command Entry::_over_cmd 370# ------------------------------------------------------------------------------ 371proc Entry::_over_cmd { path source event X Y op type dnddata } { 372 variable $path 373 upvar 0 $path data 374 375 set x [expr {$X-[winfo rootx $path]}] 376 if { [string equal $event "leave"] } { 377 if { [string length $data(afterid)] } { 378 after cancel $data(afterid) 379 set data(afterid) "" 380 } 381 } elseif { [_auto_scroll $path $x] } { 382 return 2 383 } 384 385 if {[llength [set cmd [Widget::getoption $path -dropovercmd]]]} { 386 set x [expr {$X-[winfo rootx $path]}] 387 set idx [$path:cmd index @$x] 388 set res [uplevel \#0 $cmd [list $path $source $event $idx $op $type $dnddata]] 389 return $res 390 } 391 392 if { [string equal $type "COLOR"] || 393 [string equal $type "FGCOLOR"] || 394 [string equal $type "BGCOLOR"] } { 395 DropSite::setcursor based_arrow_down 396 return 1 397 } 398 if { [Widget::getoption $path -editable] 399 && [string equal [Widget::getoption $path -state] "normal"] } { 400 if { ![string equal $event "leave"] } { 401 $path:cmd selection clear 402 $path:cmd icursor @$x 403 DropSite::setcursor based_arrow_down 404 return 3 405 } 406 } 407 DropSite::setcursor dot 408 return 0 409} 410 411 412# ------------------------------------------------------------------------------ 413# Command Entry::_auto_scroll 414# ------------------------------------------------------------------------------ 415proc Entry::_auto_scroll { path x } { 416 variable $path 417 upvar 0 $path data 418 419 set xmax [winfo width $path] 420 if { $x <= 10 && [$path:cmd index @0] > 0 } { 421 if { $data(afterid) == "" } { 422 set data(afterid) [after 100 [list Entry::_scroll $path -1 $x $xmax]] 423 DropSite::setcursor sb_left_arrow 424 } 425 return 1 426 } else { 427 if { $x >= $xmax-10 && [$path:cmd index @$xmax] < [$path:cmd index end] } { 428 if { $data(afterid) == "" } { 429 set data(afterid) [after 100 [list Entry::_scroll $path 1 $x $xmax]] 430 DropSite::setcursor sb_right_arrow 431 } 432 return 1 433 } else { 434 if { $data(afterid) != "" } { 435 after cancel $data(afterid) 436 set data(afterid) "" 437 } 438 } 439 } 440 return 0 441} 442 443 444# ------------------------------------------------------------------------------ 445# Command Entry::_scroll 446# ------------------------------------------------------------------------------ 447proc Entry::_scroll { path dir x xmax } { 448 variable $path 449 upvar 0 $path data 450 451 $path:cmd xview scroll $dir units 452 $path:cmd icursor @$x 453 if { ($dir == -1 && [$path:cmd index @0] > 0) || 454 ($dir == 1 && [$path:cmd index @$xmax] < [$path:cmd index end]) } { 455 set data(afterid) [after 100 [list Entry::_scroll $path $dir $x $xmax]] 456 } else { 457 set data(afterid) "" 458 DropSite::setcursor dot 459 } 460} 461 462 463# ------------------------------------------------------------------------------ 464# Command Entry::_destroy 465# ------------------------------------------------------------------------------ 466proc Entry::_destroy { path } { 467 variable $path 468 upvar 0 $path data 469 Widget::destroy $path 470 unset data 471} 472 473# ---------------------------------------------------------------------------- 474# Command ListBox::_themechanged 475# ---------------------------------------------------------------------------- 476proc Entry::_themechanged { path } { 477 478 if { ![winfo exists $path] } { return } 479 BWidget::set_themedefaults 480 $path configure \ 481 -foreground $BWidget::colors(SystemWindowText) \ 482 -background $BWidget::colors(SystemWindow) \ 483 -selectforeground $BWidget::colors(SystemHighlightText) \ 484 -selectbackground $BWidget::colors(SystemHighlight) \ 485 -disabledbackground $BWidget::colors(SystemButtonFace) \ 486 -disabledforeground $BWidget::colors(SystemDisabledText) \ 487 -highlightcolor $BWidget::colors(SystemHighlight) 488} 489