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