1# UI.tcl --- 2# 3# This file is part of The Coccinella application. It implements user 4# interface elements. 5# 6# Copyright (c) 2002-2008 Mats Bengtsson 7# 8# This program is free software: you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation, either version 3 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. If not, see <http://www.gnu.org/licenses/>. 20# 21# $Id: UI.tcl,v 1.200 2008-08-14 10:52:34 matben Exp $ 22 23package require ui::dialog 24package require ui::entryex 25 26package provide UI 1.0 27 28namespace eval ::UI { 29 global this 30 31 # Add all event hooks. 32 ::hooks::register firstLaunchHook ::UI::FirstLaunchHook 33 ::hooks::register jabberBuildMain ::UI::JabberBuildMainHook 34 35 # Icons 36# option add *buttonOKImage buttonok widgetDefault 37# option add *buttonCancelImage buttoncancel widgetDefault 38 option add *buttonOKImage dialog-ok widgetDefault 39 option add *buttonCancelImage dialog-cancel widgetDefault 40 41 option add *info64Image info64 widgetDefault 42 option add *error64Image error64 widgetDefault 43 option add *warning64Image warning64 widgetDefault 44 option add *question64Image question64 widgetDefault 45 option add *internet64Image internet64 widgetDefault 46 47 option add *info64Image dialog-information widgetDefault 48 option add *error64Image dialog-error widgetDefault 49 option add *warning64Image dialog-warning widgetDefault 50 option add *question64Image dialog-question widgetDefault 51 option add *worldmap64Image world-map widgetDefault 52 53 option add *badge32Image coccinella widgetDefault 54 option add *badge64Image coccinella widgetDefault 55 56 # components stuff. 57 variable menuSpecPublic 58 set menuSpecPublic(wpaths) [list] 59 60 variable regAccelerators [list] 61 62 variable icons 63 64 # The mac look-alike triangles. 65 set icons(mactriangleopen) [image create photo -data { 66 R0lGODlhCwALAPMAAP///97e3s7O/729vZyc/4yMjGNjzgAAAAAAAAAAAAAA 67 AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAALAAsAAAQgMMhJq7316M1P 68 OEIoEkchHURKGOUwoWubsYVryZiNVREAOw== 69 }] 70 set icons(mactriangleclosed) [image create photo -data { 71 R0lGODlhCwALAPMAAP///97e3s7O/729vZyc/4yMjGNjzgAAAAAAAAAAAAAA 72 AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAALAAsAAAQiMMgjqw2H3nqE 73 3h3xWaEICgRhjBi6FgMpvDEpwuCBg3sVAQA7 74 }] 75 76 # Aqua gray arrows. PNG 77 set icons(openAqua) [image create photo -data { 78 iVBORw0KGgoAAAANSUhEUgAAAAsAAAALCAYAAACprHcmAAAAkklEQVR42pXP 79 IQ4CQQyF4X+HE+HInAAJx0BXIZGI5xB7ATQrucEgkRxh5QrE4DAdQjbsZHmq 80 Tb62KfyRxsxWQJphtw2AmV2ATQXeJS2DN3sgV/AOIABIegDtBOwk3T7YcwSG 81 Ecx+FYBFKVJKzxjjC1h/4ZOkc2nCaFML9F4Pfo2fWFIuzwAHSf0k9oEOuFYe 82 npc3YZcnhZloj+wAAAAASUVORK5CYII= 83 }] 84 set icons(closeAqua) [image create photo -data { 85 iVBORw0KGgoAAAANSUhEUgAAAAsAAAALCAYAAACprHcmAAAAh0lEQVR42o2R 86 IQ6DQBREXwkH4Ap1lUiuUEeP0oyqrKyYYLnFcovK2h4BicS1hjVkw+4zP5k8 87 MZMPgKSeAqrtBkkfSV2JDNACb0lB0iUln7Yav12+AiPwsj3n5MgCPIHR9lpl 88 NjXAAIR95xQzcLN9PZIX4A6cbU8xrEuGpeQJeNj+HhbLPSPyB7B0KtfTwC8y 89 AAAAAElFTkSuQmCC 90 }] 91 92 # WinXP lool-alikes +- signs. 93 set icons(openPM) [image create photo -data { 94 R0lGODdhCQAJAKIAAP//////wsLCwsLCibS0tFOJwgAAAAAAACwAAAAACQAJ 95 AAADHUi1XAowgiUjrYKavXOBQSh4YzkuAkEMrKI0C5EAADs= 96 }] 97 set icons(closePM) [image create photo -data { 98 R0lGODdhCQAJAKIAAP//////wsLCwsLCibS0tFOJwgAAAAAAACwAAAAACQAJ 99 AAADIEi1XAowghVNpNACQY33XAEFRiCEp2Cki0AQQ6wozUIkADs= 100 }] 101 102 # Have a blank 1x1 image just for spacer. 103 set icons(blank-1x1) [image create photo -data { 104 iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAABmJLR0QA/wD/ 105 AP+gvaeTAAAADUlEQVQI12NgYGBgAAAABQABXvMqOgAAAABJRU5ErkJggg== 106 }] 107 108 switch -- [tk windowingsystem] { 109 aqua { 110 set imstate [list $icons(openAqua) open $icons(closeAqua) {}] 111 option add *TreeCtrl.buttonImage $imstate widgetDefault 112 } 113 x11 { 114 set imstate [list $icons(openPM) open $icons(closePM) {}] 115 option add *TreeCtrl.buttonImage $imstate widgetDefault 116 } 117 } 118 119 # System colors. 120 # @@@ This wont be right in a themed environment! 121 set wtmp [listbox ._tmp_listbox] 122 set this(sysHighlight) [$wtmp cget -selectbackground] 123 set this(sysHighlightText) [$wtmp cget -selectforeground] 124 destroy $wtmp 125 126 # Hardcoded configurations. 127 set ::config(ui,pruneMenus) {} 128} 129 130proc ::UI::FirstLaunchHook {} { 131 SetupAss 132} 133 134# UI::Init -- 135# 136# Various initializations for the UI stuff. 137 138proc ::UI::Init {} { 139 global this prefs 140 141 ::Debug 2 "::UI::Init" 142 143 # Standard button icons. 144 # Special solution to be able to set image via the option database. 145 ::Theme::Create16IconWithName . buttonOKImage 146 ::Theme::Create16IconWithName . buttonCancelImage 147 148 InitDialogs 149 150 switch -- [tk windowingsystem] { 151 aqua { 152 InitMac 153 } 154 x11 { 155 InitX11 156 } 157 } 158} 159 160proc ::UI::InitX11 {} { 161 162 # button icons for ok and cancel buttons 163 # 164 option add *btok.image dialog-ok 165 option add *btok.compound left 166 option add *btcancel.image dialog-cancel 167 option add *btcancel.compound left 168 169 option add *Dialog*ok.image dialog-ok 170 option add *Dialog*ok.compound left 171 option add *Dialog*cancel.image dialog-cancel 172 option add *Dialog*cancel.compound left 173} 174 175# @@@ This is only temporary until We've got the chasingarrowselem. 176 177proc ::UI::ChaseArrows {w} { 178 179 # Use ttk::progressbar win -style TChasingArrows if possible. 180 181 if {([tk windowingsystem] eq "aqua") && \ 182 ![catch {package require chasingarrowselem 0.2}]} { 183 ttk::progressbar $w -style TChasingArrows -length 16 -maximum 10000 -takefocus 0 184 } else { 185 ::chasearrows::chasearrows $w -size 16 186 } 187 return $w 188} 189 190proc ::UI::FindFirstClassChild {win class} { 191 foreach w [winfo children $win] { 192 if {[winfo class $w] eq $class} { 193 return $w 194 } 195 } 196 return 197} 198 199proc ::UI::InitDialogs {} { 200 201 # Dialog images. 202 foreach name {info error warning question worldmap} { 203 set im [::Theme::Find64Icon . ${name}64Image] 204 ui::dialog::setimage $name $im 205 } 206 ui::dialog::setbadge [::Theme::Find32Icon . badge32Image] 207 ui::dialog::setimage coccinella [::Theme::Find64Icon . badge64Image] 208 ui::dialog layoutpolicy stack 209 210 # For ui::openimage 211 option add *Dialog*image.style Sunken.TLabel widgetDefault 212} 213 214proc ::UI::JabberBuildMainHook {} { 215 ui::dialog defaultmenu [::JUI::GetMainMenu] 216} 217 218proc ::UI::InitMac {} { 219 220 proc ::tk::mac::OpenDocument {args} { 221 Debug 2 "::tk::mac::OpenDocument args=$args" 222 # args will be a list of all the documents dropped on your app, 223 # or double-clicked 224 eval {::hooks::run macOpenDocument} $args 225 } 226} 227 228proc ::UI::InitCommonBinds {} { 229 global this 230 231 set mod $this(modkey) 232 bind Text <$mod-a> { 233 %W tag add sel 1.0 end 234 } 235 bind Entry <$mod-a> { 236 %W selection range 0 end 237 } 238 bind TEntry <$mod-a> { 239 %W selection range 0 end 240 } 241 if {[tk windowingsystem] eq "aqua"} { 242 243 # Entry 244 bind Entry <Command-Left> { 245 %W icursor 0 246 %W selection clear 247 } 248 bind Entry <Command-Right> { 249 %W icursor end 250 %W selection clear 251 } 252 bind Entry <Control-Left> { 253 %W icursor 0 254 %W selection clear 255 } 256 bind Entry <Control-Right> { 257 %W icursor end 258 %W selection clear 259 } 260 261 # TEntry 262 bind TEntry <Command-Left> { 263 %W icursor 0 264 %W selection clear 265 } 266 bind TEntry <Command-Right> { 267 %W icursor end 268 %W selection clear 269 } 270 bind TEntry <Control-Left> { 271 %W icursor 0 272 %W selection clear 273 } 274 bind TEntry <Control-Right> { 275 %W icursor end 276 %W selection clear 277 } 278 } 279 280 # Read only text widget bindings. 281 # Usage: bindtags $w [linsert [bindtags $w] 0 ReadOnlyText] 282 bind ReadOnlyText <Button-1> { focus %W } 283 bind ReadOnlyText <Tab> { 284 focus [tk_focusNext %W] 285 break 286 } 287 bind ReadOnlyText <Shift-Tab> { 288 focus [tk_focusPrev %W] 289 break 290 } 291 292 # Undo/redo text bindings. 293 # <<Undo>> and <<Redo>> already standard for text widget. 294 foreach sep {space Tab Return BackSpace comma period} { 295 bind UndoText <$sep> { 296 %W edit separator 297 } 298 } 299 300 SetMoseWheelFor Canvas 301 SetMoseWheelFor Html 302 303 # Linux has a strange binding by default. Handled by <<Paste>>. 304 if {[string equal $this(platform) "unix"]} { 305 bind Text <Control-Key-v> {} 306 } 307} 308 309proc ::UI::SetMoseWheelFor {bindTarget} { 310 311 if {[string equal "x11" [tk windowingsystem]]} { 312 # Support for mousewheels on Linux/Unix commonly comes through mapping 313 # the wheel to the extended buttons. If you have a mousewheel, find 314 # Linux configuration info at: 315 # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ 316 bind $bindTarget <4> { 317 if {!$::tk_strictMotif} { 318 if {![string equal [%W yview] "0 1"]} { 319 %W yview scroll -5 units 320 } 321 } 322 } 323 bind $bindTarget <5> { 324 if {!$::tk_strictMotif} { 325 if {![string equal [%W yview] "0 1"]} { 326 %W yview scroll 5 units 327 } 328 } 329 } 330 } elseif {[string equal [tk windowingsystem] "aqua"]} { 331 bind $bindTarget <MouseWheel> { 332 if {![string equal [%W yview] "0 1"]} { 333 %W yview scroll [expr {- (%D)}] units 334 } 335 } 336 bind $bindTarget <Shift-MouseWheel> { 337 if {![string equal [%W xview] "0 1"]} { 338 %W xview scroll [expr {- (%D)}] units 339 } 340 } 341 } else { 342 bind $bindTarget <MouseWheel> { 343 if {![string equal [%W yview] "0 1"]} { 344 %W yview scroll [expr {- (%D / 120) * 4}] units 345 } 346 } 347 bind $bindTarget <Shift-MouseWheel> { 348 if {![string equal [%W xview] "0 1"]} { 349 %W xview scroll [expr {- (%D / 120) * 4}] units 350 } 351 } 352 } 353} 354 355proc ::UI::InitVirtualEvents {} { 356 global this 357 358 # Virtual events. 359 event add <<CloseWindow>> <$this(modkey)-Key-w> 360 event add <<ReturnEnter>> <Return> <KP_Enter> 361 event add <<Find>> <$this(modkey)-Key-f> 362 event add <<FindAgain>> <$this(modkey)-Key-g> 363 event add <<FindPrevious>> <$this(modkey)-Shift-Key-g> 364 365 switch -- $this(platform) { 366 macintosh { 367 event add <<ButtonPopup>> <Button-2> <Control-Button-1> 368 } 369 macosx { 370 event add <<ButtonPopup>> <Button-2> <Control-Button-1> 371 } 372 unix { 373 event add <<ButtonPopup>> <Button-3> 374 } 375 windows { 376 event add <<CloseWindow>> <Key-F4> 377 event add <<ButtonPopup>> <Button-3> 378 } 379 } 380} 381 382proc ::UI::InitDlgs {} { 383 global wDlgs 384 385 # Define the toplevel windows here so they don't collide. 386 # Toplevel dialogs. 387 array set wDlgs { 388 comp .comp 389 editFonts .edfnt 390 editShorts .tshcts 391 fileAssoc .fass 392 infoClient .infocli 393 infoServ .infoserv 394 iteminsp .iteminsp 395 netSetup .netsetup 396 openConn .opc 397 openMulti .opqtmulti 398 prefs .prefs 399 print .prt 400 prog .prog 401 plugs .plugs 402 setupass .setupass 403 wb .wb 404 mainwb .wb0 405 } 406 407 # Toplevel dialogs for the jabber part. 408 array set wDlgs { 409 jmain .jmain 410 jreg .jreg 411 jlogin .jlogin 412 jrost .jrost 413 jrostnewedit .jrostnewedit 414 jrostadduser .jrostadduser 415 jrostedituser .jrostedituser 416 jsubsc .jsubsc 417 jsubsced .jsubsced 418 jsendmsg .jsendmsg 419 jgotmsg .jgotmsg 420 jstartchat .jstartchat 421 jchat .jchat 422 jbrowse .jbrowse 423 jenterroom .jenterroom 424 jcreateroom .jcreateroom 425 jinbox .jinbox 426 jpresmsg .jpresmsg 427 joutst .joutst 428 jpasswd .jpasswd 429 jsearch .jsearch 430 jvcard .jvcard 431 jgcenter .jgcenter 432 jgc .jgc 433 jmucenter .jmucenter 434 jmucinvite .jmucinvite 435 jmucinfo .jmucinfo 436 jmucedit .jmucedit 437 jmuccfg .jmuccfg 438 jmucdestroy .jmucdestroy 439 jchist .jchist 440 jhist .jhist 441 jprofiles .jprofiles 442 jftrans .jftrans 443 jerrdlg .jerrdlg 444 jwbinbox .jwbinbox 445 jprivacy .jprivacy 446 jdirpres .jdirpres 447 jdisaddserv .jdisaddserv 448 juserinfo .juserinfo 449 jgcbmark .jgcbmark 450 jpopupdisco .jpopupdi 451 jpopuproster .jpopupro 452 jpopupgroupchat .jpopupgc 453 jadhoc .jadhoc 454 } 455} 456 457# @@@ TODO 458proc ::UI::RegisterDlgName {nameDlgFlatA} { 459 global wDlgs 460 461 foreach {name w} $nameDlgFlatA { 462 if {[info exists $wDlgs($name)]} { 463 return -code error "name \"$name\" already exists in wDlgs" 464 } 465 466 } 467} 468 469# UI::InitMenuDefs -- 470# 471# The menu organization. Only least common parts here, 472# that is, the Apple menu. 473 474proc ::UI::InitMenuDefs {} { 475 global prefs this 476 variable menuDefs 477 478 if {([tk windowingsystem] eq "aqua") && $prefs(haveMenus)} { 479 set haveAppleMenu 1 480 } else { 481 set haveAppleMenu 0 482 } 483 484 # All menu definitions for the main (whiteboard) windows as: 485 # {{type name cmd accelerator opts} {{...} {...} ...}} 486 487 set menuDefs(main,info,aboutwhiteboard) \ 488 {command mAboutCoccinella {[mc "About %s" $prefs(appName)]} {::Splash::SplashScreen} {}} 489 set menuDefs(main,info,aboutquicktimetcl) \ 490 {command mAboutQuickTimeTcl {[mc "About %s" QuickTimeTcl]} {::Dialogs::AboutQuickTimeTcl} {}} 491 492 # Mac only. 493 set menuDefs(main,apple) [list $menuDefs(main,info,aboutwhiteboard)] 494 495 # Make platform specific things. 496 set haveQuickTimeTcl [expr {![catch {package require QuickTimeTcl}]}] 497 if {$haveAppleMenu && $haveQuickTimeTcl} { 498 lappend menuDefs(main,apple) $menuDefs(main,info,aboutquicktimetcl) 499 } 500} 501 502# UI::SetupAss -- 503# 504# Setup assistant. Must be called after initing the jabber stuff. 505 506proc ::UI::SetupAss {} { 507 global wDlgs 508 509 package require SetupAss 510 511 catch {destroy $wDlgs(splash)} 512 update 513 ::SetupAss::SetupAss 514 ::UI::CenterWindow $wDlgs(setupass) 515 raise $wDlgs(setupass) 516 tkwait window $wDlgs(setupass) 517} 518 519proc ::UI::GetMainMenu {} { 520 return [::JUI::GetMainMenu] 521} 522 523proc ::UI::GetMenuFromWindow {w} { 524 525 return $w.menu 526} 527 528proc ::UI::GetIcon {name} { 529 variable icons 530 531 if {[info exists icons($name)]} { 532 return $icons($name) 533 } else { 534 return -code error "icon named \"$name\" does not exist" 535 } 536} 537 538proc ::UI::GetScreenSize {} { 539 540 return [list [winfo vrootwidth .] [winfo vrootheight .]] 541} 542 543# UI::IsAppInFront -- 544# 545# Tells if application is frontmost (active). 546# [focus] is not reliable so it is better called after idle. 547 548proc ::UI::IsAppInFront {} { 549 global this 550 551 if {[tk windowingsystem] eq "aqua" \ 552 && [info exists this(package,carbon)] \ 553 && $this(package,carbon)} { 554 return [expr {[carbon::process current] == [carbon::process front]}] 555 } else { 556 557 # The 'wm stackorder' is not reliable in sorting windows! 558 # How about message boxes in front? We never get called since they block. 559 set isfront 0 560 set wfocus [focus] 561 foreach w [wm stackorder .] { 562 if {[string equal [wm state $w] "normal"]} { 563 if {($wfocus ne "") && [string equal [winfo toplevel $wfocus] $w]} { 564 set isfront 1 565 break 566 } 567 } 568 } 569 } 570 return $isfront 571} 572 573proc ::UI::IsToplevelActive {w} { 574 set front 0 575 set wfocus [focus] 576 if {[string equal [wm state $w] "normal"]} { 577 if {($wfocus ne "") && [string equal [winfo toplevel $wfocus] $w]} { 578 set front 1 579 } 580 } 581 return $front 582} 583 584# UI::MessageBox -- 585# 586# Wrapper for the tk_messageBox. 587 588proc ::UI::MessageBox {args} { 589 590 eval {::hooks::run newMessageBox} $args 591 592 array set argsA $args 593 if {[info exists argsA(-message)]} { 594 set argsA(-message) [FormatTextForMessageBox $argsA(-message)] 595 } 596 set ans [eval {tk_messageBox} [array get argsA]] 597 return $ans 598} 599 600# UI::FormatTextForMessageBox -- 601# 602# The tk_messageBox needs explicit newlines to format the message text. 603 604proc ::UI::FormatTextForMessageBox {txt {width ""}} { 605 global prefs 606 607 if {[tk windowingsystem] eq "windows"} { 608 609 # Insert newlines to force line breaks. 610 if {[string length $width] == 0} { 611 set width $prefs(msgWrapLength) 612 } 613 set len [string length $txt] 614 set start $width 615 set first 0 616 set newtxt {} 617 while {([set ind [tcl_wordBreakBefore $txt $start]] > 0) && \ 618 ($start < $len)} { 619 append newtxt [string trim [string range $txt $first [expr {$ind-1}]]] 620 append newtxt "\n" 621 set start [expr {$ind + $width}] 622 set first $ind 623 } 624 append newtxt [string trim [string range $txt $first end]] 625 return $newtxt 626 } elseif {[tk windowingsystem] eq "x11"} { 627 if {[string length $txt] < 32} { 628 append txt " " 629 } 630 return $txt 631 } else { 632 return $txt 633 } 634} 635 636# UI::Text -- 637# 638# Faking Aqua text widget. Note that the container frame is returned. 639# From comp.lang.tcl Thank You! 640 641proc ::UI::Text {w args} { 642 643 if {[tk windowingsystem] eq "aqua"} { 644 set wcont [string range $w 0 [string last "." $w]]_cont 645 ttk::frame $wcont -style TEntry 646 eval {text $w -borderwidth 0 -highlightthickness 0} $args 647 648 bind $w <FocusIn> [list $wcont state focus] 649 bind $w <FocusOut> [list $wcont state {!focus}] 650 651 pack $w -in $wcont -padx 5 -pady 5 -fill both -expand 1 652 return $wcont 653 } else { 654 eval $w $args 655 return $w 656 } 657} 658 659# Experiment! 660 661namespace eval ::UI { 662 variable slide 663 #set slide(mode) linear 664 set slide(mode) sinus 665 set slide(step) 20 666 667 # On slower OS/machines we should decrease this value. 668 if {[tk windowingsystem] eq "aqua"} { 669 set slide(ms) 20 670 } else { 671 set slide(ms) 30 672 } 673} 674 675proc ::UI::SlideUp {win args} { 676 variable slide 677 678 set optsD [dict create] 679 dict set optsD -y 0 680 dict set optsD -mode $slide(mode) 681 foreach {key value} $args { 682 dict set optsD $key $value 683 } 684 set y [dict get $optsD -y] 685 update idletasks 686 set h [winfo reqheight $win] 687 dict set optsD h $h 688 689 place $win -x 0 -y $y -rely 1 -relwidth 1 690 after $slide(ms) [list ::UI::SlideUpMove $win $y $optsD] 691} 692 693proc ::UI::SlideUpMove {win y optsD} { 694 variable slide 695 696 if {![winfo exists $win]} { return } 697 set h [dict get $optsD h] 698 set mode [dict get $optsD -mode] 699 if {$mode eq "linear"} { 700 incr y -$slide(step) 701 } elseif {$mode eq "sinus"} { 702 set yabs [expr {abs($y)}] 703 set ystart [expr {abs([dict get $optsD -y])}] 704 set delta [expr {$h - $ystart}] 705 if {$delta > 1} { 706 set ypos [expr {$yabs - $ystart}] 707 set ysin [expr {sin( 3.14159*$ypos/$delta )}] 708 709 # Extra factor of two here to compensate for sin < 1. 710 set dy [expr {2*max(int($slide(step)*$ysin), 1)}] 711 } else { 712 set dy 1 713 } 714 incr y -$dy 715 } 716 717 if {[expr {abs($y) < $h}]} { 718 place $win -x 0 -y $y -rely 1 -relwidth 1 719 after $slide(ms) [list ::UI::SlideUpMove $win $y $optsD] 720 } else { 721 place $win -x 0 -y -$h -rely 1 -relwidth 1 722 if {[dict exists $optsD -command]} { 723 uplevel #0 [dict get $optsD -command] 724 } 725 } 726} 727 728# -y is actually the y to stop sliding. 729 730proc ::UI::SlideDown {win args} { 731 variable slide 732 733 set optsD [dict create] 734 dict set optsD -y 0 735 dict set optsD -mode $slide(mode) 736 foreach {key value} $args { 737 dict set optsD $key $value 738 } 739 update idletasks 740 set h [winfo reqheight $win] 741 dict set optsD h $h 742 place $win -x 0 -y -$h -rely 1 -relwidth 1 743 after $slide(ms) [list ::UI::SlideDownMove $win -$h $optsD] 744} 745 746proc ::UI::SlideDownMove {win y optsD} { 747 variable slide 748 749 if {![winfo exists $win]} { return } 750 set h [dict get $optsD h] 751 set hstop [dict get $optsD -y] 752 set mode [dict get $optsD -mode] 753 if {$mode eq "linear"} { 754 incr y $slide(step) 755 } elseif {$mode eq "sinus"} { 756 set yabs [expr {abs($y)}] 757 set ystop [expr {abs([dict get $optsD -y])}] 758 set delta [expr {$h - $ystop}] 759 if {$delta > 1} { 760 set ypos [expr {$yabs - $ystop}] 761 set ysin [expr {sin( 3.14159*$ypos/$delta )}] 762 763 # Extra factor of two here to compensate for sin < 1. 764 set dy [expr {2*max(int($slide(step)*$ysin), 1)}] 765 } else { 766 set dy 1 767 } 768 incr y $dy 769 } 770 771 if {[expr {abs($y) > $hstop}]} { 772 place $win -x 0 -y $y -rely 1 -relwidth 1 773 after $slide(ms) [list ::UI::SlideDownMove $win $y $optsD] 774 } else { 775 place $win -x 0 -y -$hstop -rely 1 -relwidth 1 776 if {[dict exists $optsD -command]} { 777 uplevel #0 [dict get $optsD -command] 778 } 779 } 780} 781 782# Administrative code to handle toplevels: 783# create, close, hide, show 784 785namespace eval ::UI { 786 787 variable topcache 788 set topcache(state) show 789# set topcache(.,w) . 790# set topcache(.,prevstate) "normal" 791} 792 793# UI::Toplevel -- 794# 795# Wrapper for making a toplevel window. 796# 797# Arguments: 798# w 799# args: 800# -allowclose 0|1 801# -class 802# -closecommand 803# -macstyle: 804# macintosh (classic) and macosx 805# documentProc, dBoxProc, plainDBox, altDBoxProc, movableDBoxProc, 806# zoomDocProc, rDocProc, floatProc, floatZoomProc, floatSideProc, 807# or floatSideZoomProc 808# -macclass 809# macosx only; {class attributesList} 810# class = alert moveableAlert modal moveableModal floating document 811# help toolbar 812# attributes = closeBox noActivates horizontalZoom verticalZoom 813# collapseBox resizable sideTitlebar noUpdates noActivates 814# -usemacmainmenu 815 816proc ::UI::Toplevel {w args} { 817 global this prefs 818 variable topcache 819 820 array set argsA { 821 -allowclose 1 822 -usemacmainmenu 0 823 } 824 array set argsA $args 825 set opts [list] 826 if {[info exists argsA(-class)]} { 827 lappend opts -class $argsA(-class) 828 } 829 if {[info exists argsA(-closecommand)]} { 830 set topcache($w,-closecommand) $argsA(-closecommand) 831 } 832 if {[tk windowingsystem] eq "aqua"} { 833 if {$argsA(-usemacmainmenu)} { 834 lappend opts -menu [GetMainMenu] 835 } 836 } 837 set topcache($w,prevstate) "normal" 838 set topcache($w,w) $w 839 eval {toplevel $w} $opts 840 841 # We direct all close events through DoCloseWindow so things can 842 # be handled from there. 843 wm protocol $w WM_DELETE_WINDOW [list ::UI::DoCloseWindow $w "wm"] 844 if {$argsA(-allowclose)} { 845 bind $w <Escape> [list ::UI::DoCloseWindow $w "command"] 846 } 847 if {[tk windowingsystem] eq "aqua"} { 848 if {[info exists argsA(-macclass)]} { 849 eval {::tk::unsupported::MacWindowStyle style $w} $argsA(-macclass) 850 } elseif {[info exists argsA(-macstyle)]} { 851 ::tk::unsupported::MacWindowStyle style $w $argsA(-macstyle) 852 } 853 # Unreliable!!! 854 # ::UI::SetAquaProxyIcon $w 855 } 856 if {$argsA(-allowclose)} { 857 bind $w <<CloseWindow>> [list ::UI::DoCloseWindow $w "command"] 858 } 859 if {$argsA(-usemacmainmenu)} { 860 SetMenubarAcceleratorBinds $w [GetMainMenu] 861 } 862 if {$prefs(opacity) != 100} { 863 array set attr [wm attributes $w] 864 if {[info exists attr(-alpha)]} { 865 after idle [list \ 866 wm attributes $w -alpha [expr {$prefs(opacity)/100.0}]] 867 } 868 } 869 870 # This is binding for the apple menu which is created automatically. 871 if {[tk windowingsystem] eq "aqua"} { 872 bind $w <$this(modkey)-Key-q> { ::UserActions::DoQuit -warning 1 } 873 } 874 875 # We only want to bind to the actual toplevel window. Check in handlers. 876 # @@@ This is not the most reliable way to get application activate events. 877 bind $w <FocusIn> +[list ::UI::OnFocusIn %W $w] 878 bind $w <FocusOut> +[list ::UI::OnFocusOut %W $w] 879 bind $w <Destroy> +[list ::UI::OnDestroy %W $w] 880 881 # These get duplicated since Text widget binds them directly. 882 bind $w <$this(modkey)-Key-z> {} 883 bind $w <$this(modkey)-Key-Z> {} 884 885 ::hooks::run newToplevelWindowHook $w 886 887 return $w 888} 889 890namespace eval ::UI { 891 892 variable appInFront 1 893 variable closeType - 894} 895 896proc ::UI::OnFocusIn {win w} { 897 variable appInFront 898 899 if {$win eq $w} { 900 if {!$appInFront} { 901 set appInFront 1 902 ::hooks::run appInFrontHook 903 } 904 } 905} 906 907proc ::UI::OnFocusOut {win w} { 908 variable appInFront 909 910 # We must check focus after idle. 911 if {$win eq $w} { 912 after idle { 913 if {[focus] eq ""} { 914 set ::UI::appInFront 0 915 ::hooks::run appInBackgroundHook 916 } 917 } 918 } 919} 920 921proc ::UI::OnDestroy {win w} { 922 variable topcache 923 924 if {$win eq $w} { 925 array unset topcache $w,* 926 } 927} 928 929# @@@ Unreliable!!! 930proc ::UI::SetAquaProxyIcon {w} { 931 932 set f [info nameofexecutable] 933 if {$f ne ""} { 934 set path [eval file join [lrange [file split $f] 0 end-3]] 935 wm attributes $w -titlepath $path -modified 0 936 } 937} 938 939# UI::DoCloseWindow -- 940# 941# Take special actions before a window is closed. 942# 943# Notes: There are four ways to close a window: 944# 1) from the menus Close Window command 945# 2) using the menu keyboard shortcut command/control-w 946# 3) using the <<CloseWindow>> virtual event 947# 4) clicking the windows close button 948# 949# If any cleanup etc. is necessary all three must execute the same code. 950# In case where window must not be destroyed a hook must be registered 951# that returns stop. 952# 953# Default behaviour when no hook registered is to destroy window. 954# 955# Arguments: 956# wevent 957# type: 958# command: menu action or accelerator keys 959# wm: window manager; user pressed windows close button. 960 961proc ::UI::DoCloseWindow {{wevent ""} {type "command"}} { 962 variable topcache 963 variable closeType $type 964 965 set w "" 966 if {$wevent eq ""} { 967 if {[winfo exists [focus]]} { 968 set w [winfo toplevel [focus]] 969 } 970 } else { 971 set w $wevent 972 } 973 if {$w ne ""} { 974 975 Debug 2 "::UI::DoCloseWindow winfo class $w=[winfo class $w], type=$type" 976 977 # Give components a chance to intersect destruction. (Win taskbar) 978 set result [::hooks::run preCloseWindowHook $w] 979 if {[string equal $result "stop"]} { 980 return 981 } 982 983 if {[info exists topcache($w,-closecommand)]} { 984 set result [uplevel #0 $topcache($w,-closecommand) $w] 985 if {[string equal $result "stop"]} { 986 return 987 } 988 destroy $w 989 } 990 991 # Run hooks. Only the one corresponding to the $w needs to act! 992 set result [::hooks::run closeWindowHook $w] 993 if {![string equal $result "stop"]} { 994 destroy $w 995 } 996 } 997} 998 999# UI::GetCloseWindowType -- 1000# 1001# There are situations where we want to know why a window is getting closed: 1002# command: menu action or accelerator keys 1003# wm: window manager; user pressed windows close button. 1004 1005proc ::UI::GetCloseWindowType {} { 1006 variable closeType 1007 return $closeType 1008} 1009 1010# UI::GetAllToplevels -- 1011# 1012# Returns a list of all existing toplevel windows created using Toplevel. 1013 1014proc ::UI::GetAllToplevels {} { 1015 variable topcache 1016 1017 set tmp [list] 1018 foreach {key w} [array get topcache *,w] { 1019 if {[winfo exists $w]} { 1020 lappend tmp $w 1021 } 1022 } 1023 return $tmp 1024} 1025 1026proc ::UI::WithdrawAllToplevels {} { 1027 variable topcache 1028 1029 foreach w [GetAllToplevels] { 1030 set topcache($w,prevstate) [wm state $w] 1031 wm withdraw $w 1032 } 1033 set topcache(state) hide 1034} 1035 1036proc ::UI::ShowAllToplevels {} { 1037 variable topcache 1038 1039 foreach w [GetAllToplevels] { 1040 set topcache($w,prevstate) [wm state $w] 1041 wm deiconify $w 1042 } 1043 set topcache(state) show 1044} 1045 1046proc ::UI::GetToplevelState {} { 1047 variable topcache 1048 1049 return $topcache(state) 1050} 1051 1052# UI::GetToplevelFromPath -- 1053# 1054# As 'winfo toplevel' but window need not exist. 1055 1056proc ::UI::GetToplevelFromPath {w} { 1057 1058 if {[string equal $w "."]} { 1059 return $w 1060 } else { 1061 regexp {^(\.[^.]+)} $w match wpath 1062 return $wpath 1063 } 1064} 1065 1066# UI::ScrollFrame -- 1067# 1068# A few functions to make scrollable frames. 1069 1070proc ::UI::ScrollFrame {w args} { 1071 1072 array set opts { 1073 -bd 0 1074 -padding {0} 1075 -propagate 1 1076 -relief flat 1077 -width 0 1078 } 1079 array set opts $args 1080 1081 if {0} { 1082 frame $w -class Scrollframe -bd $opts(-bd) -relief $opts(-relief) 1083 } else { 1084 ttk::frame $w -class Scrollframe 1085 } 1086 ttk::scrollbar $w.ysc -command [list $w.can yview] 1087 if {$opts(-width)} { 1088 set cwidth [expr {$opts(-width) - $opts(-bd) - [winfo reqwidth $w.ysc]}] 1089 canvas $w.can -yscrollcommand [list $w.ysc set] -highlightthickness 0 \ 1090 -width $cwidth 1091 } else { 1092 canvas $w.can -yscrollcommand [list $w.ysc set] -highlightthickness 0 1093 } 1094 pack $w.ysc -side right -fill y 1095 pack $w.can -side left -fill both -expand 1 1096 1097 if {1 || !$opts(-propagate)} { 1098 ttk::frame $w.can.bg 1099 $w.can create window 0 0 -anchor nw -window $w.can.bg -tags twin 1100 } 1101 ttk::frame $w.can.f -padding $opts(-padding) 1102 $w.can create window 0 0 -anchor nw -window $w.can.f -tags twin 1103 1104 if {$opts(-propagate)} { 1105 bind $w.can.f <Configure> [list ::UI::ScrollFrameResize $w] 1106 bind $w.can <Configure> [list ::UI::ScrollFrameResizeBg $w] 1107 } else { 1108 bind $w.can.f <Configure> [list ::UI::ScrollFrameResizeScroll $w] 1109 bind $w.can <Configure> [list ::UI::ScrollFrameResizeBg $w] 1110 } 1111 return $w 1112} 1113 1114proc ::UI::ScrollFrameResize {w} { 1115 update idletasks 1116 set bbox [$w.can bbox twin] 1117 set width [winfo width $w.can.f] 1118 $w.can configure -width $width -scrollregion $bbox 1119} 1120 1121proc ::UI::ScrollFrameResizeScroll {w} { 1122 set bbox [$w.can bbox all] 1123 $w.can configure -scrollregion $bbox 1124} 1125 1126proc ::UI::ScrollFrameResizeBg {w} { 1127 update idletasks 1128 set bbox [$w.can bbox all] 1129 set width [winfo width $w.can] 1130 set height [winfo height $w.can] 1131 $w.can.bg configure -width $width -height $height 1132} 1133 1134proc ::UI::ScrollFrameInterior {w} { 1135 return $w.can.f 1136} 1137 1138# UI::QuirkSize -- 1139# 1140# This is a trick to trigger an extra Expose event which sometimes (Aqua) 1141# is missing. 1142 1143proc ::UI::QuirkSize {w} { 1144 set geo [wm geometry $w] 1145 regexp {([0-9]+)x([0-9]+)} $geo - width height 1146 incr width 1147 wm geometry $w ${width}x${height} 1148 incr width -1 1149 wm geometry $w ${width}x${height} 1150} 1151 1152# UI::ScrollSet -- 1153# 1154# Command for auto hide/show scrollbars. 1155 1156proc ::UI::ScrollSet {wscrollbar geocmd offset size} { 1157 # get the geometry manager 1158 set manager [lindex $geocmd 0] 1159 # Create the name for the focus 1160 set wfocus $wscrollbar.focus 1161 # that name must survive 1162 global $wfocus 1163 if {($offset != 0.0) || ($size != 1.0)} { 1164 # If the scrollbar hasn't a geomanager, 1165 # it means that this time it will appear (and get a geomanager) 1166 # then i record the name of the current focused object 1167 if {[string equal $manager "grid"] && [string equal [$manager info $wscrollbar] ""]} { 1168 set $wfocus [focus] 1169 } 1170 eval $geocmd 1171 $wscrollbar set $offset $size 1172 } else { 1173 $manager forget $wscrollbar 1174 } 1175 1176 # Whatever would happen, i always will set the focus 1177 # on the "current focused object" recorded in the lines above. 1178 if {[info exists $wfocus]} { 1179 focus [set $wfocus] 1180 } 1181} 1182 1183# UI::ScrollSetStdGrid -- 1184# 1185# As 'ScrollSet' but with workaround for the grid display bug. 1186 1187proc ::UI::ScrollSetStdGrid {wscrollbar geocmd offset size} { 1188 1189 if {($offset != 0.0) || ($size != 1.0)} { 1190 eval $geocmd 1191 $wscrollbar set $offset $size 1192 } else { 1193 set manager [lindex $geocmd 0] 1194 $manager forget $wscrollbar 1195 1196 # This helps as a workaround for one of horiz/vert blank areas. 1197 set wmaster [winfo parent $wscrollbar] 1198 array set opts [lrange $geocmd 2 end] 1199 after idle [list grid rowconfigure $wmaster 1 -minsize 0] 1200 } 1201} 1202 1203proc ::UI::GetPaddingWidth {padding} { 1204 1205 switch -- [llength $padding] { 1206 1 { 1207 return [expr {2*$padding}] 1208 } 1209 2 { 1210 return [expr {2*[lindex $padding 0]}] 1211 } 1212 4 { 1213 return [expr {[lindex $padding 0] + [lindex $padding 2]}] 1214 } 1215 } 1216} 1217 1218proc ::UI::GetPaddingHeight {padding} { 1219 1220 switch -- [llength $padding] { 1221 1 { 1222 return [expr {2*$padding}] 1223 } 1224 2 { 1225 return [expr {2*[lindex $padding 1]}] 1226 } 1227 4 { 1228 return [expr {[lindex $padding 1] + [lindex $padding 3]}] 1229 } 1230 } 1231} 1232 1233# UI::SaveWinGeom, SaveWinPrefixGeom -- 1234# 1235# Call this when closing window to store its geometry if exists. 1236# 1237# Arguments: 1238# key toplevel or entry in storage array. 1239# w (D="") if set then 'key' is only entry in array, while 'w' 1240# is the actual toplevel window. 1241# 1242 1243proc ::UI::SaveWinGeom {key {w ""}} { 1244 global prefs 1245 1246 if {$w eq ""} { 1247 set w $key 1248 } 1249 if {[winfo exists $w]} { 1250 1251 # If a bug somewhere we may get 1x1+563+158 which shall never be saved! 1252 set geom [wm geometry $w] 1253 lassign [ParseWMGeometry $geom] width height x y 1254 if {$width > 1 && $height > 1} { 1255 set prefs(winGeom,$key) $geom 1256 } 1257 } 1258} 1259 1260proc ::UI::SaveWinPrefixGeom {wprefix {key ""}} { 1261 1262 if {$key eq ""} { 1263 set key $wprefix 1264 } 1265 set win [GetFirstPrefixedToplevel $wprefix] 1266 if {$win ne ""} { 1267 SaveWinGeom $key $win 1268 } 1269} 1270 1271proc ::UI::SaveWinGeomUseSize {key geom} { 1272 global prefs 1273 1274 set prefs(winGeom,$key) $geom 1275} 1276 1277proc ::UI::SetWindowPosition {w {key ""}} { 1278 global prefs 1279 1280 if {$key eq ""} { 1281 set key $w 1282 } 1283 if {[info exists prefs(winGeom,$key)]} { 1284 1285 # We shall verify that the window is not put offscreen. 1286 lassign [ParseWMGeometry $prefs(winGeom,$key)] width height x y 1287 1288 # Protect for corrupted prefs. 1289 if {$width < 20} {set width 20} 1290 if {$height < 20} {set height 20} 1291 1292 KeepOnScreen $w x y $width $height 1293 wm geometry $w +${x}+${y} 1294 } 1295} 1296 1297proc ::UI::SetWindowGeometry {w {key ""}} { 1298 global prefs 1299 1300 if {$key eq ""} { 1301 set key $w 1302 } 1303 if {[info exists prefs(winGeom,$key)]} { 1304 1305 # We shall verify that the window is not put offscreen. 1306 lassign [ParseWMGeometry $prefs(winGeom,$key)] width height x y 1307 1308 # Protect for corrupted prefs. 1309 if {$width < 20} {set width 20} 1310 if {$height < 20} {set height 20} 1311 1312 KeepOnScreen $w x y $width $height 1313 wm geometry $w ${width}x${height}+${x}+${y} 1314 } 1315} 1316 1317proc ::UI::SaveSashPos {key w} { 1318 global prefs 1319 1320 if {[winfo exists $w]} { 1321 update 1322 set prefs(sashPos,$key) [$w sashpos 0] 1323 } 1324} 1325 1326proc ::UI::SetSashPos {key w} { 1327 global prefs 1328 1329 # @@@ Not working! 1330 if {0} { 1331 if {[info exists prefs(sashPos,$key)]} { 1332 update idletasks 1333 $w sashpos 0 $prefs(sashPos,$key) 1334 } 1335 } 1336} 1337 1338proc ::UI::KeepOnScreen {w xVar yVar width height} { 1339 global this 1340 upvar $xVar x 1341 upvar $yVar y 1342 1343 set margin 10 1344 set topmargin 0 1345 set botmargin 40 1346 if {[string match mac* $this(platform)]} { 1347 set topmargin 20 1348 } 1349 set screenwidth [winfo vrootwidth $w] 1350 set screenheight [winfo vrootheight $w] 1351 set x2 [expr {$x + $width}] 1352 set y2 [expr {$y + $height}] 1353 if {$x < 0} { 1354 set x $margin 1355 } 1356 if {$x > [expr {$screenwidth - $margin}]} { 1357 set x [expr {$screenwidth - $width - $margin}] 1358 } 1359 if {$y < $topmargin} { 1360 set y $topmargin 1361 } 1362 if {$y > [expr {$screenheight - $botmargin}]} { 1363 set y [expr {$screenheight - $height - $botmargin}] 1364 } 1365} 1366 1367proc ::UI::GetFirstPrefixedToplevel {wprefix} { 1368 1369 set win "" 1370 set wins [lsearch -all -inline -glob [winfo children .] ${wprefix}*] 1371 if {[llength $wins]} { 1372 1373 # 1st priority, pick if on top. 1374 set wfocus [focus] 1375 if {$wfocus ne ""} { 1376 set win [winfo toplevel $wfocus] 1377 } 1378 set win [lsearch -inline $wins $wfocus] 1379 if {$win eq ""} { 1380 1381 # 2nd priority, just get first in list. 1382 set win [lindex $wins 0] 1383 } 1384 } 1385 return $win 1386} 1387 1388proc ::UI::GetPrefixedToplevels {wprefix} { 1389 1390 return [lsort -dictionary \ 1391 [lsearch -all -inline -glob [winfo children .] ${wprefix}*]] 1392} 1393 1394# @@@ All this menu code is a total mess!!! Perhaps a snidget? 1395 1396# UI::NewMenu -- 1397# 1398# Creates a new menu from a previously defined menu definition list. 1399# 1400# Arguments: 1401# w toplevel window 1402# wmenu the menus widget path name (".menu.file" etc.). 1403# label its label. 1404# menuSpec a hierarchical list that defines the menu content. 1405# {{type name cmd accelerator opts} {{...} {...} ...}} 1406# args form ?-varName value? list that defines local variables to set. 1407# 1408# Results: 1409# $wmenu 1410 1411proc ::UI::NewMenu {w wmenu label lname menuSpec args} { 1412 variable mapWmenuToWtop 1413 variable cachedMenuSpec 1414 1415 # Need to cache the complete menuSpec's since needed in MenuMethod. 1416 set cachedMenuSpec($w,$wmenu) $menuSpec 1417 set mapWmenuToWtop($wmenu) $w 1418 1419 eval {BuildMenu $w $wmenu $label $lname $menuSpec} $args 1420} 1421 1422# UI::BuildMenu -- 1423# 1424# Make menus recursively from a hierarchical menu definition list. 1425# Only called from ::UI::NewMenu! 1426# 1427# Arguments: 1428# w toplevel window 1429# wmenu the menus widget path name (".menu.file" etc.). 1430# mLabel its mLabel. 1431# menuDef a hierarchical list that defines the menu content. 1432# {{type name cmd accelerator opts} {{...} {...} ...}} 1433# args form ?-varName value? list that defines local variables to set. 1434# 1435# Results: 1436# $wmenu 1437 1438proc ::UI::BuildMenu {w wmenu mLabel lname menuDef args} { 1439 global this wDlgs prefs 1440 1441 variable menuKeyToIndex 1442 variable menuNameToWmenu 1443 variable mapWmenuToWtop 1444 variable cachedMenuSpec 1445 1446 # This is also used to rebuild an existing menu. 1447 if {[winfo exists $wmenu]} { 1448 1449 # The toplevel cascades must not be deleted since this changes 1450 # their relative order. 1451 # Also must be sure to delete any child cascades so they are added 1452 # back properly below. 1453 $wmenu delete 0 end 1454 foreach mchild [winfo children $wmenu] { 1455 destroy $mchild 1456 } 1457 set m $wmenu 1458 array unset menuKeyToIndex $wmenu,* 1459 set exists 1 1460 } else { 1461 set m [menu $wmenu -tearoff 0] 1462 set exists 0 1463 } 1464 set wparent [winfo parent $wmenu] 1465 1466 foreach {optName value} $args { 1467 set varName [string trimleft $optName "-"] 1468 set $varName $value 1469 } 1470 1471 # A trick to make this work for popup menus, which do not have a Menu parent. 1472 if {!$exists && [string equal [winfo class $wparent] "Menu"]} { 1473 set lname [eval concat $lname] 1474 set ampersand [string first & $lname] 1475 set mopts [list] 1476 if {$ampersand != -1} { 1477 regsub -all & $lname "" lname 1478 lappend mopts -underline $ampersand 1479 } 1480 eval {$wparent add cascade -label $lname -menu $m} $mopts 1481 } 1482 1483 # If we don't have a menubar, for instance, if embedded toplevel. 1484 # Only for the toplevel menubar. 1485 if {[string equal $wparent ".menu"] && \ 1486 [string equal [winfo class $wparent] "Frame"]} { 1487 # label ${wmenu}la -text $locname 1488 label ${wmenu}la -text $lname 1489 pack ${wmenu}la -side left -padx 4 1490 bind ${wmenu}la <Button-1> [list ::UI::DoTopMenuPopup %W $wmenu] 1491 } 1492 1493 set mod [string map {Control Ctrl} $this(modkey)] 1494 set i 0 1495 foreach line $menuDef { 1496 foreach {type name lname cmd accel mopts subdef} $line { 1497 1498 set lname [eval concat $lname] 1499 1500 set menuKeyToIndex($wmenu,$name) $i 1501 set menuNameToWmenu($w,$mLabel,$name) $wmenu 1502 set ampersand [string first & $lname] 1503 if {$ampersand != -1} { 1504 regsub -all & $lname "" lname 1505 lappend mopts -underline $ampersand 1506 } 1507 if {[string match "sep*" $type]} { 1508 $m add separator 1509 } elseif {[string equal $type "cascade"]} { 1510 1511 # Make cascade menu recursively. 1512 regsub -all -- " " [string tolower $name] "" mt 1513 regsub -all -- {\.} $mt "" mt 1514 1515 set wsubmenu $wmenu.$mt 1516 set cachedMenuSpec($w,$wsubmenu) $subdef 1517 set mapWmenuToWtop($wsubmenu) $w 1518 eval {BuildMenu $w $wsubmenu $name $lname $subdef} $args 1519 1520 # Explicitly set any disabled state of cascade. 1521 MenuMethod $m entryconfigure $name 1522 } else { 1523 1524 # All variables (and commands) in menuDef's cmd shall be 1525 # substituted! Be sure they are all in here. 1526 1527 # BUG: [ 1340712 ] Ex90 Error when trying to start New whiteboard 1528 # FIX: protect menuDefs [string map {$ \\$} $f] 1529 # @@@ No spaces allowed in variables! 1530 set cmd [subst -nocommands $cmd] 1531 if {[string length $accel]} { 1532 lappend mopts -accelerator $mod+$accel 1533 } 1534 eval {$m add $type -label $lname -command $cmd} $mopts 1535 } 1536 } 1537 incr i 1538 } 1539 return $wmenu 1540} 1541 1542proc ::UI::GetMenu {w label1 {label2 ""}} { 1543 variable menuNameToWmenu 1544 1545 return $menuNameToWmenu($w,$label1,$label2) 1546} 1547 1548proc ::UI::GetMenuKeyToIndex {wmenu key} { 1549 variable menuKeyToIndex 1550 1551 return $menuKeyToIndex($wmenu,$key) 1552} 1553 1554proc ::UI::HaveMenuEntry {wmenu mLabel} { 1555 variable menuKeyToIndex 1556 1557 return [info exists menuKeyToIndex($wmenu,$mLabel)] 1558} 1559 1560proc ::UI::FreeMenu {w} { 1561 variable mapWmenuToWtop 1562 variable cachedMenuSpec 1563 variable menuKeyToIndex 1564 variable menuNameToWmenu 1565 1566 foreach key [array names cachedMenuSpec $w,*] { 1567 set wmenu [string map [list "$w," ""] $key] 1568 unset mapWmenuToWtop($wmenu) 1569 array unset menuKeyToIndex $wmenu,* 1570 } 1571 array unset cachedMenuSpec $w,* 1572 array unset menuNameToWmenu $w,* 1573} 1574 1575# UI::MenuMethod -- 1576# 1577# Utility to use instead of 'menuPath cmd index args' since it 1578# handles menu accelerators as well. 1579# 1580# Arguments: 1581# wmenu menu's widget path 1582# cmd valid menu command 1583# key key to menus index (mOpen etc.) 1584# args 1585# 1586# Results: 1587# binds to toplevel changed 1588 1589proc ::UI::MenuMethod {wmenu cmd key args} { 1590 variable menuKeyToIndex 1591 1592 # Be silent about nonexistent entries? 1593 if {[info exists menuKeyToIndex($wmenu,$key)]} { 1594 set mind $menuKeyToIndex($wmenu,$key) 1595 if {[string match "entrycon*" $cmd]} { 1596 if {[expr {[llength $args] % 2 == 0}]} { 1597 array set argsA $args 1598 if {[info exists argsA(-label)]} { 1599 set name $argsA(-label) 1600 set lname [mc $name] 1601 set ampersand [string first & $lname] 1602 if {$ampersand != -1} { 1603 regsub -all & $lname "" lname 1604 set argsA(-underline) $ampersand 1605 } 1606 set argsA(-label) $lname 1607 set args [array get argsA] 1608 } 1609 } 1610 } 1611 eval {$wmenu $cmd $mind} $args 1612 } 1613} 1614 1615# UI::SetMenubarAcceleratorBinds -- 1616# 1617# Binds all main menu accelerator keys to window. 1618# 1619# Arguments: 1620# w 1621# wmenu 1622# 1623# Results: 1624# none 1625 1626proc ::UI::SetMenubarAcceleratorBinds {w wmenubar} { 1627 global this 1628 1629 variable menuKeyToIndex 1630 variable mapWmenuToWtop 1631 variable cachedMenuSpec 1632 variable regAccelerators 1633 1634 foreach {wmenu wtop} [array get mapWmenuToWtop $wmenubar.*] { 1635 foreach line $cachedMenuSpec($wtop,$wmenu) { 1636 1637 # {type name cmd accel mopts subdef} $line 1638 # Cut, Copy & Paste handled by widgets internally! 1639 set accel [lindex $line 4] 1640 if {[string length $accel] && ![regexp {(X|C|V)} $accel]} { 1641 set name [lindex $line 1] 1642 set mind $menuKeyToIndex($wmenu,$name) 1643 set key [string tolower [string range $accel end end]] 1644 set key [string map {< less > greater} $key] 1645 set prefix [string range $accel 0 end-1] 1646 if {$prefix eq "Shift-"} { 1647 set key [string toupper $key] 1648 } 1649 bind $w <$this(modkey)-$prefix$key> [lindex $line 3] 1650 } 1651 } 1652 } 1653 1654 foreach spec $regAccelerators { 1655 lassign $spec key cmd 1656 bind $w <$this(modkey)-$key> $cmd 1657 } 1658} 1659 1660# UI::SetMenuAcceleratorBinds -- 1661# 1662# Sets the accelerator key binds to toplevel for specific menu. 1663 1664proc ::UI::SetMenuAcceleratorBinds {w wmenu} { 1665 global this 1666 1667 variable cachedMenuSpec 1668 variable menuKeyToIndex 1669 1670 foreach line $cachedMenuSpec($w,$wmenu) { 1671 set accel [lindex $line 4] 1672 if {[string length $accel]} { 1673 set name [lindex $line 1] 1674 set mind $menuKeyToIndex($wmenu,$name) 1675 set key [string tolower [string range $accel end end]] 1676 set key [string map {< less > greater} $key] 1677 set prefix [string range $accel 0 end-1] 1678 if {$prefix eq "Shift-"} { 1679 set key [string toupper $key] 1680 } 1681 bind $w <$this(modkey)-$prefix$key> [lindex $line 3] 1682 } 1683 } 1684} 1685 1686# UI::RegisterAccelerator -- 1687# 1688# This is a way to register an accelerator key which is not handled 1689# with the other Menu code. 1690 1691proc ::UI::RegisterAccelerator {key cmd} { 1692 global this 1693 variable regAccelerators 1694 1695 set key [string tolower $key] 1696 lappend regAccelerators [list $key $cmd] 1697} 1698 1699proc ::UI::BuildAppleMenu {w wmenuapple state} { 1700 variable menuDefs 1701 1702 NewMenu $w $wmenuapple {} $state $menuDefs(main,apple) 1703 1704 if {[tk windowingsystem] eq "aqua"} { 1705 proc ::tk::mac::ShowPreferences {} { 1706 ::Preferences::Build 1707 } 1708 } 1709} 1710 1711proc ::UI::MenubarDisableBut {mbar name} { 1712 1713 # Accelerators must be handled from OnMenu* commands. 1714 set iend [$mbar index end] 1715 for {set ind 0} {$ind <= $iend} {incr ind} { 1716 set m [$mbar entrycget $ind -menu] 1717 if {$name ne [winfo name $m]} { 1718 $mbar entryconfigure $ind -state disabled 1719 } 1720 } 1721} 1722 1723proc ::UI::MenubarEnableAll {mbar} { 1724 1725 # Accelerators must be handled from OnMenu* commands. 1726 set iend [$mbar index end] 1727 for {set ind 0} {$ind <= $iend} {incr ind} { 1728 $mbar entryconfigure $ind -state normal 1729 } 1730} 1731 1732proc ::UI::MenuEnableAll {mw} { 1733 1734 set iend [$mw index end] 1735 for {set i 0} {$i <= $iend} {incr i} { 1736 if {[$mw type $i] ne "separator"} { 1737 $mw entryconfigure $i -state normal 1738 } 1739 } 1740} 1741 1742proc ::UI::MenuDisableAll {mw} { 1743 MenuDisableAllBut $mw {} 1744} 1745 1746proc ::UI::MenuDisableAllBut {mw normalL} { 1747 1748 set iend [$mw index end] 1749 for {set i 0} {$i <= $iend} {incr i} { 1750 if {[$mw type $i] ne "separator"} { 1751 $mw entryconfigure $i -state disabled 1752 } 1753 } 1754 foreach name $normalL { 1755 ::UI::MenuMethod $mw entryconfigure $name -state normal 1756 } 1757} 1758 1759proc ::UI::DoTopMenuPopup {w wmenu} { 1760 1761 if {[winfo exists $wmenu]} { 1762 set x [winfo rootx $w] 1763 set y [expr {[winfo rooty $w] + [winfo height $w]}] 1764 tk_popup $wmenu $x $y 1765 } 1766} 1767 1768# These Grab/GrabRelease handle menus as well. 1769 1770proc ::UI::Grab {w} { 1771 1772 # Disable menubar except Edit menu. 1773 set mb [$w cget -menu] 1774 if {$mb ne ""} { 1775 MenubarDisableBut $mb edit 1776 } 1777 ui::grabWindow $w 1778} 1779 1780proc ::UI::GrabRelease {w} { 1781 ui::releaseGrab $w 1782 1783 # Enable menubar. 1784 set mb [$w cget -menu] 1785 if {$mb ne ""} { 1786 MenubarEnableAll $mb 1787 } 1788} 1789 1790# UI::PruneMenusFromConfig -- 1791# 1792# A method to remove specific menu entries from 'menuDefs' and 1793# 'menuDefsInsertInd' using an entry in the 'config' array: 1794# config(ui,pruneMenus): mInfo {mDebug mCoccinellaHome...} 1795# 1796# Arguments: 1797# name the menus key label, mJabber, mEdit etc. 1798# menuDefVar *name* if the menuDef variable. 1799# 1800# Results: 1801# None 1802 1803proc ::UI::PruneMenusFromConfig {name menuDefVar} { 1804 global config 1805 upvar $menuDefVar menuDef 1806 1807 array set pruneArr $config(ui,pruneMenus) 1808 if {[info exists pruneArr($name)]} { 1809 1810 # Take each in turn and find any matching index. 1811 foreach mLabel $pruneArr($name) { 1812 set idx [lsearch -glob $menuDef *${mLabel}*] 1813 if {$idx >= 0} { 1814 set menuDef [lreplace $menuDef $idx $idx] 1815 } 1816 } 1817 } 1818} 1819 1820# UI::LabelButton -- 1821# 1822# A html link type button from a label widget. 1823 1824proc ::UI::LabelButton {w args} { 1825 1826 array set eopts { 1827 -command {} 1828 } 1829 array set lopts { 1830 -foreground blue 1831 -activeforeground red 1832 } 1833 foreach {key value} $args { 1834 switch -- $key { 1835 -command { 1836 set eopts($key) $value 1837 } 1838 default { 1839 set lopts($key) $value 1840 } 1841 } 1842 } 1843 eval {label $w} [array get lopts] 1844 set cursor [$w cget -cursor] 1845 array set fontArr [font actual [$w cget -font]] 1846 set fontArr(-underline) 1 1847 $w configure -font [array get fontArr] 1848 bind $w <Button-1> $eopts(-command) 1849 bind $w <Enter> [list $w configure -fg $lopts(-activeforeground) -cursor hand2] 1850 bind $w <Leave> [list $w configure -fg $lopts(-foreground) -cursor $cursor] 1851 return $w 1852} 1853 1854# UI::OkCancelButtons -- 1855# 1856# 1857 1858proc ::UI::OkCancelButtons {args} { 1859 1860 set padx [option get . buttonPadX {}] 1861 if {[option get . okcancelButtonOrder {}] eq "cancelok"} { 1862 set i 0 1863 foreach spec $args { 1864 set wbt [eval {ttk::button} $spec] 1865 pack $wbt -side right 1866 if {[expr {$i & 2}] == 1} { 1867 pack $wbt -padx $padx 1868 } 1869 incr i 1870 } 1871 } else { 1872 for {set i [expr {[llength $args] - 1}]} {$i >= 0} {incr i -1} { 1873 set wbt [eval {ttk::button} [lindex $args $i]] 1874 pack $wbt -side right 1875 if {[expr {$i & 2}] == 1} { 1876 pack $wbt -padx $padx 1877 } 1878 } 1879 } 1880} 1881 1882# UI::CutEvent, CopyEvent, PasteEvent -- 1883# 1884# Used in menu commands to generate <<Cut>>, <<Copy>>, and <<Paste>> 1885# virtual events for _any_ widget. 1886 1887proc ::UI::CutEvent {} { 1888 if {[winfo exists [focus]]} { 1889 event generate [focus] <<Cut>> 1890 } 1891} 1892 1893proc ::UI::CopyEvent {} { 1894 if {[winfo exists [focus]]} { 1895 event generate [focus] <<Copy>> 1896 } 1897} 1898 1899proc ::UI::PasteEvent {} { 1900 if {[winfo exists [focus]]} { 1901 event generate [focus] <<Paste>> 1902 } 1903} 1904 1905proc ::UI::CloseWindowEvent {} { 1906 if {[winfo exists [focus]]} { 1907 event generate [focus] <<CloseWindow>> 1908 } 1909} 1910 1911proc ::UI::FindEvent {} { 1912 if {[winfo exists [focus]]} { 1913 event generate [focus] <<Find>> 1914 } 1915} 1916 1917proc ::UI::FindAgainEvent {} { 1918 if {[winfo exists [focus]]} { 1919 event generate [focus] <<FindAgain>> 1920 } 1921} 1922 1923proc ::UI::FindPreviousEvent {} { 1924 if {[winfo exists [focus]]} { 1925 event generate [focus] <<FindPrevious>> 1926 } 1927} 1928 1929proc ::UI::UndoEvent {} { 1930 if {[winfo exists [focus]]} { 1931 event generate [focus] <<Undo>> 1932 } 1933} 1934 1935proc ::UI::RedoEvent {} { 1936 if {[winfo exists [focus]]} { 1937 event generate [focus] <<Redo>> 1938 } 1939} 1940 1941# For menu commands. 1942# Note that we must allow CloseWindowEvent on grabbed window. 1943 1944proc ::UI::OnMenuAll {} { 1945 if {[winfo exists [focus]]} { 1946 set w [focus] 1947 switch -- [winfo class [focus]] { 1948 Text { 1949 $w tag add sel 1.0 end 1950 } 1951 Entry - TEntry { 1952 $w selection range 0 end 1953 } 1954 } 1955 } 1956} 1957 1958proc ::UI::OnMenuFind {} { 1959 if {[llength [grab current]]} { return } 1960 FindEvent 1961} 1962 1963proc ::UI::OnMenuFindAgain {} { 1964 if {[llength [grab current]]} { return } 1965 FindAgainEvent 1966} 1967 1968proc ::UI::OnMenuFindPrevious {} { 1969 if {[llength [grab current]]} { return } 1970 FindPreviousEvent 1971} 1972 1973# UI::GenericCCPMenuStates -- 1974# 1975# Retuns a flat array with cut, copy, and paste menu entry states when 1976# any of the standard widgets TEntry, Entry, and Text have focus. 1977# 1978# Edits are typically different from other commands in that they operate 1979# on a specific widget. 1980 1981proc ::UI::GenericCCPMenuStates {} { 1982 1983 # @@@ The situation with a ttk::entry in readonly state is not understood. 1984 # @@@ Not sure focus is needed for selections. 1985 set w [focus] 1986 set haveFocus 1 1987 set haveSelection 0 1988 set editable 1 1989 1990 array set ccpStateA { 1991 mCut disabled 1992 mCopy disabled 1993 mPaste disabled 1994 } 1995 1996 if {[winfo exists $w]} { 1997 1998 switch -- [winfo class $w] { 1999 TEntry - TCombobox { 2000 set haveSelection [$w selection present] 2001 set state [$w state] 2002 if {[lsearch $state disabled] >= 0} { 2003 set editable 0 2004 } elseif {[lsearch $state readonly] >= 0} { 2005 set editable 0 2006 } 2007 } 2008 Entry { 2009 set haveSelection [$w selection present] 2010 if {[$w cget -state] eq "disabled"} { 2011 set editable 0 2012 } 2013 } 2014 Text { 2015 if {![catch {$w get sel.first sel.last} data]} { 2016 if {$data ne ""} { 2017 set haveSelection 1 2018 } 2019 } 2020 if {[$w cget -state] eq "disabled"} { 2021 set editable 0 2022 } 2023 } 2024 default { 2025 set haveFocus 0 2026 } 2027 } 2028 } 2029 2030 # Cut, copy and paste menu entries. 2031 if {$haveSelection} { 2032 if {$editable} { 2033 set ccpStateA(mCut) normal 2034 } 2035 set ccpStateA(mCopy) normal 2036 } 2037 if {![catch {selection get -sel CLIPBOARD} str]} { 2038 if {$editable && $haveFocus && ($str ne "")} { 2039 set ccpStateA(mPaste) normal 2040 } 2041 } 2042 return [array get ccpStateA] 2043} 2044 2045# ::UI::ParseWMGeometry -- 2046# 2047# Parses 'wm geometry' result into a list. 2048# 2049# Arguments: 2050# wmgeom output from 'wm geometry' 2051# 2052# Results: 2053# list {width height x y} 2054 2055proc ::UI::ParseWMGeometry {wmgeom} { 2056 regexp {([0-9]+)x([0-9]+)\+(\-?[0-9]+)\+(\-?[0-9]+)} $wmgeom - w h x y 2057 return [list $w $h $x $y] 2058} 2059 2060proc ::UI::CenterWindow {win} { 2061 2062 if {[winfo toplevel $win] != $win} { 2063 error "::UI::CenterWindow: $win is not a toplevel window" 2064 } 2065 after idle [format { 2066 2067 # @@@ This is potentially dangerous! 2068 update idletasks 2069 set win %s 2070 set sw [winfo screenwidth $win] 2071 set sh [winfo screenheight $win] 2072 set x [expr {($sw - [winfo reqwidth $win])/2}] 2073 set y [expr {($sh - [winfo reqheight $win])/2}] 2074 wm geometry $win "+$x+$y" 2075 } $win] 2076} 2077 2078# ::UI::StartStopAnimatedWave, AnimateWave -- 2079# 2080# Utility routines for animating the wave in the status message frame. 2081# 2082# Arguments: 2083# w canvas widget path (not the whiteboard) 2084# 2085# Results: 2086# none 2087 2088proc ::UI::StartStopAnimatedWave {w theimage start} { 2089 variable icons 2090 variable animateWave 2091 2092 # Define speed and update frequency. Pix per sec and times per sec. 2093 set speed 150 2094 set freq 16 2095 set animateWave(pix) [expr {int($speed/$freq)}] 2096 set animateWave(wait) [expr {int(1000.0/$freq)}] 2097 2098 if {$start} { 2099 2100 # Check if not already started. 2101 if {[info exists animateWave($w,id)]} { 2102 return 2103 } 2104 set id [$w create image 0 0 -anchor nw -image $theimage] 2105 set animateWave($w,id) $id 2106 $w lower $id 2107 set animateWave($w,x) 0 2108 set animateWave($w,dir) 1 2109 set animateWave($w,killId) \ 2110 [after $animateWave(wait) [list ::UI::AnimateWave $w]] 2111 } elseif {[info exists animateWave($w,killId)]} { 2112 after cancel $animateWave($w,killId) 2113 $w delete $animateWave($w,id) 2114 array unset animateWave $w,* 2115 } 2116} 2117 2118proc ::UI::AnimateWave {w} { 2119 variable animateWave 2120 2121 set deltax [expr {$animateWave($w,dir) * $animateWave(pix)}] 2122 incr animateWave($w,x) $deltax 2123 if {$animateWave($w,x) > [expr {[winfo width $w] - 80}]} { 2124 set animateWave($w,dir) -1 2125 } elseif {$animateWave($w,x) <= -60} { 2126 set animateWave($w,dir) 1 2127 } 2128 $w move $animateWave($w,id) $deltax 0 2129 set animateWave($w,killId) \ 2130 [after $animateWave(wait) [list ::UI::AnimateWave $w]] 2131} 2132 2133#------------------------------------------------------------------------------- 2134 2135