Bwidget Source Code
Check-in [510027c421]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:mainframe.tcl: Reverted Patch [1977644] (checkin [58357c462f])(-casesensitive for accellerators). It has issues with shift-lock.
Timelines: family | ancestors | descendants | both | bwidget
Files: files | file ages | folders
SHA1: 510027c42148c8e898eee3b2bd495c0044c14e68
User & Date: oehhar 2013-06-26 08:03:52
References
2013-06-26
08:08 Closed ticket [83ce3e84e7]: Implement Shift, Cmd and ShiftCmd menu accelerators for MainFrame plus 6 other changes artifact: c8878a50b3 user: oehhar
Context
2013-06-28
07:45
Curing shift-lock interferences of Shift-Accelerators of Mainframe widget on the MAC. Ticket [83ce3e84e7], Patch [9f67a66609] check-in: fdb38ca6f0 user: oehhar tags: bwidget
2013-06-26
08:03
mainframe.tcl: Reverted Patch [1977644] (checkin [58357c462f])(-casesensitive for accellerators). It has issues with shift-lock. check-in: 510027c421 user: oehhar tags: bwidget
07:17
Commiting patch [d58b61392d] from ticket [83ce3e84e7] check-in: bb507704b1 user: oehhar tags: bwidget
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to BWman/MainFrame.html.

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
</TR>
</TABLE></DD>
</DL>
<DL>
<DT><I><A HREF="#wso">WIDGET-SPECIFIC OPTIONS</A></I></DT>
<DD><TABLE CELLSPACING=0 CELLSPACING=0 BORDER=0>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-casesensitive">-casesensitive</A></TD></TR>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-height">-height</A></TD></TR>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-menu">-menu</A></TD>
</TR>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-separator">-separator</A></TD></TR>
<TR>
................................................................................
<LI>one or more toolbars that user can hide,</LI>
<LI>a status bar, displaying a user message or a menu description, and optionally a
<A HREF="ProgressBar.html">ProgressBar</A>.</LI>
</UL>
</P>
<BR><HR WIDTH="50%"><BR>
<B><A NAME="wso">WIDGET-SPECIFIC OPTIONS</A></B><BR>

<DL><DT><A NAME="-casesensitive"><B>-casesensitive</B></A></DT>
<DD>
Controlls the interpretation of <I>accelerator</I> definition by the <B>-menu</B>
option. If this option is <B>false</B> or not given, the accelerator binding is done
for lowercase letters (no Shift Key pressed) and the accelerator text of the menu entry
is shown in uppercase letters. If it is set to <B>true</B> the accelerator binding
and the menu entry is done as given.
<P>
Example:<BR>
Both accelerators are identically if <B>-casesensitive</B> is specified as false. See
<A HREF="#-menu">-menu</A> for the syntax of the menu discription list.
</P>
<PRE>
...
{command "&Save" {} {Save the document} {<B>Ctrl s</B>} -command Menu::save}
{command "&Save As" {} {Save with different name} {<B>Ctrl S</B>} -command Menu::saveAs}
...
</PRE>
</DD>
</DL>

<DL><DT><A NAME="-height"><B>-height</B></A></DT>
<DD>

Specifies the desired height for the user frame in any of the forms acceptable to
Tk_GetPixels. If this option is less than or equal to zero (the default) then the window
will not request any size at all.
</DD>






<
<







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







25
26
27
28
29
30
31


32
33
34
35
36
37
38
..
90
91
92
93
94
95
96






















97
98
99
100
101
102
103
</TR>
</TABLE></DD>
</DL>
<DL>
<DT><I><A HREF="#wso">WIDGET-SPECIFIC OPTIONS</A></I></DT>
<DD><TABLE CELLSPACING=0 CELLSPACING=0 BORDER=0>
<TR>


<TD>&nbsp;&nbsp;<A HREF="#-height">-height</A></TD></TR>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-menu">-menu</A></TD>
</TR>
<TR>
<TD>&nbsp;&nbsp;<A HREF="#-separator">-separator</A></TD></TR>
<TR>
................................................................................
<LI>one or more toolbars that user can hide,</LI>
<LI>a status bar, displaying a user message or a menu description, and optionally a
<A HREF="ProgressBar.html">ProgressBar</A>.</LI>
</UL>
</P>
<BR><HR WIDTH="50%"><BR>
<B><A NAME="wso">WIDGET-SPECIFIC OPTIONS</A></B><BR>






















<DL><DT><A NAME="-height"><B>-height</B></A></DT>
<DD>

Specifies the desired height for the user frame in any of the forms acceptable to
Tk_GetPixels. If this option is less than or equal to zero (the default) then the window
will not request any size at all.
</DD>

Changes to ChangeLog.







1
2
3
4
5
6
7
.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25





2013-08-21 Harald Oehlmann <[email protected]>

	* labelentry.tcl: Bug fixed:
	Methods from Tk entry widget restored [Bug 1002844].
	
	* mainframe.tcl: Allow case sensitive accelerators
	by new option -casesensitive.
................................................................................
	Patch by cmard [Patch 1977644]
	
	* mainframe.tcl: Allow new modifiers Shift, Cmd and ShiftCmd
	for accelerators. Patch by K.J.Nash [Patch-83ce3e84e7]

	* mainframe.tcl: When changing MainFrame -background, do
	not change menu colors on Aqua.
	Fix by K.J.Nash [Bug-a81b7afc1e]
	
	* init.tcl: Make loadable in save interpreter.
	Fix by K.J.Nash [Bug-4365a23bd3]

	* combobox.tcl: Add method getentry to return entry
	widget path for bind purposes.
	Patch by Michael [Patch-2340355]
	
2013-01-09 Harald Oehlmann <[email protected]>

>
>
>
>
>
>







 







|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
..
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
2013-08-26 Harald Oehlmann <[email protected]>

	* mainframe.tcl: Reverted Patch [1977644]
	(-casesensitive for accellerators). It has
	issues with shift-lock.

2013-08-21 Harald Oehlmann <[email protected]>

	* labelentry.tcl: Bug fixed:
	Methods from Tk entry widget restored [Bug 1002844].
	
	* mainframe.tcl: Allow case sensitive accelerators
	by new option -casesensitive.
................................................................................
	Patch by cmard [Patch 1977644]
	
	* mainframe.tcl: Allow new modifiers Shift, Cmd and ShiftCmd
	for accelerators. Patch by K.J.Nash [Patch-83ce3e84e7]

	* mainframe.tcl: When changing MainFrame -background, do
	not change menu colors on Aqua.
	Fix by Keith J.Nash [Bug-a81b7afc1e]
	
	* init.tcl: Make loadable in save interpreter.
	Fix by Keith J.Nash [Bug-4365a23bd3]

	* combobox.tcl: Add method getentry to return entry
	widget path for bind purposes.
	Patch by Michael [Patch-2340355]
	
2013-01-09 Harald Oehlmann <[email protected]>

Changes to mainframe.tcl.

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
...
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
...
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
...
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741

742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
    }

    Widget::declare MainFrame {
	{-width         TkResource 0      0 frame}
	{-height        TkResource 0      0 frame}
	{-background    TkResource ""     0 frame}
	{-textvariable  String     ""     0}
	{-casesensitive Boolean    0      0}
	{-menu          String     {}     1}
	{-separator     Enum       both   1 {none top bottom both}}
	{-bg            Synonym    -background}

	{-menubarfont   String     ""  0}
	{-menuentryfont String     ""  0}
	{-statusbarfont String     ""  0}
................................................................................

    set _widget($path,top)      $top
    set _widget($path,ntoolbar) 0
    set _widget($path,nindic)   0

    set menu [Widget::getoption $path -menu]
    if { [llength $menu] } {
        _create_menubar $path $menu [Widget::getoption $path -casesensitive]
    }

    bind $path <Destroy> [list MainFrame::_destroy %W]

    return [Widget::create MainFrame $path]
}

................................................................................
    }
}


# ----------------------------------------------------------------------------
#  Command MainFrame::_create_menubar
# ----------------------------------------------------------------------------
proc MainFrame::_create_menubar { path descmenu casesensitive } {
    variable _widget
    global    tcl_platform

    set top $_widget($path,top)

    foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} {
	if {[string length [Widget::getoption $path $x]]} {
................................................................................
	# [email protected]:  Add mapping from menu items to tags
	set _widget($path,menutags,[list $menubar $count]) $tags

        if { [string length $menuid] } {
            # menu has identifier
            set _widget($path,menuid,$menuid) $menu
        }
        _create_entries $path $menu $menuopts $entries $casesensitive
        incr count
    }
}


# ----------------------------------------------------------------------------
#  Command MainFrame::_create_entries
# ----------------------------------------------------------------------------
proc MainFrame::_create_entries { path menu menuopts entries casesensitive } {
    variable _widget

    set count      [$menu cget -tearoff]
    set registered 0
    foreach entry $entries {
        set len  [llength $entry]
        set type [lindex $entry 0]
................................................................................
            set submenu $menu.menu$count
            eval [list $menu add cascade] $opt [list -menu $submenu]
            eval [list menu $submenu -tearoff $tearoff] $menuopts
            if { [string length $menuid] } {
                # menu has identifier
                set _widget($path,menuid,$menuid) $submenu
            }
            _create_entries $path $submenu $menuopts [lindex $entry 5] $casesensitive
            incr count
            continue
        }

        # entry help description
        set desc [lindex $entry 3]
        if { [string length $desc] } {
................................................................................
                DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
                set registered 1
            }
            DynamicHelp::register $menu menuentry $count $desc
        }

        # entry accelerator
        set accel [_parse_accelerator [lindex $entry 4] $casesensitive]
        if { [llength $accel] } {
            lappend opt -accelerator [lindex $accel 0]
            bind $_widget($path,top) [lindex $accel 1] [list $menu invoke $count]
        }

        # user options
        set useropt [lrange $entry 5 end]
................................................................................
# MainFrame::_parse_accelerator --
#
#	Given a key combo description, construct an appropriate human readable
#	string (for display on as a menu accelerator) and the corresponding
#	bind event.
#
# Arguments:
#	desc		a list with the following format:
#				?sequence? key
#			sequence may be None, Ctrl, Alt, CtrlAlt, Shift, Cmd or
#			ShiftCmd
#			key may be any key
#	casesensitive	Boolean if accelerator is case sensitive
#
# Results:
#	{accel event}	a list containing the accelerator string and the event

proc MainFrame::_parse_accelerator { desc casesensitive} {
    set fKey 0
    if { [llength $desc] == 1 } {
	set seq None
	set key [lindex $desc 0]
	# If the key is an F key (ie, F1, F2, etc), it has to be capitalized
	if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} [string tolower $key]]} {
	    set key [string toupper $key]
	    set fKey 1
	}
    } elseif { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [lindex $desc 1]
	# If the key is an F key (ie, F1, F2, etc), it has to be capitalized
	if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} [string tolower $key]]} {
	    set key [string toupper $key]
	    set fKey 1
	}
    } else {
	return {}
    }

    # Plain "Shift" can be used only with F keys, but "ShiftCmd" is allowed.
    if {$seq eq "Shift" && (!$fkey)} {
        return -code error {Shift accelerator can be used only with F keys}
    }

    if {! $casesensitive} {
 	set akey [string toupper $key]
 	set ekey [string tolower $key]
    } else {
	set akey $key
	set ekey $key
    }
    switch -- $seq {
	None {
	    set accel $akey
	    set event "<Key-$ekey>"
	}
	Shift {
	# Used only with Function keys.
	    set accel "Shift+$akey"
	    set event "<Shift-Key-$ekey>"
	}
	Cmd {
	    set accel "Cmd+$akey"
	    set event "<Command-Key-$ekey>"
	}
	ShiftCmd {
	    if {    ([tk windowingsystem] eq "aqua")
		 && ([string first AppKit [winfo server .]] == -1)
	    } {
		# Carbon
		set accel "Shift+Cmd+$akey"
		set event "<Shift-Command-Key-$akey>"
	    } else {
		# Cocoa and anything else that uses Cmd
		set accel "Shift+Cmd+$akey"
		set event "<Shift-Command-Key-$ekey>"
	    }

	}	Ctrl {
	    set accel "Ctrl+$akey"
	    set event "<Control-Key-$ekey>"
	}
	Alt {
	    set accel "Alt+$akey"
	    set event "<Alt-Key-$ekey>"
	}
	CtrlAlt {
	    set accel "Ctrl+Alt+$akey"
	    set event "<Control-Alt-Key-$ekey>"
	}
	default {
	    return -code error "invalid accelerator code $seq"
	}
    }
    return [list $accel $event]
}






<







 







|







 







|







 







|








|







 







|







 







|







 







|
|
|

|
<




|



|

|





|

|








|



<
<
<
<
<
<
<


|
|


|
|
|


|
|


|
|


|
|


|
|

>
|
|
|


|
|


|
|







38
39
40
41
42
43
44

45
46
47
48
49
50
51
...
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
...
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
...
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
...
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
...
664
665
666
667
668
669
670
671
672
673
674
675

676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706







707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
    }

    Widget::declare MainFrame {
	{-width         TkResource 0      0 frame}
	{-height        TkResource 0      0 frame}
	{-background    TkResource ""     0 frame}
	{-textvariable  String     ""     0}

	{-menu          String     {}     1}
	{-separator     Enum       both   1 {none top bottom both}}
	{-bg            Synonym    -background}

	{-menubarfont   String     ""  0}
	{-menuentryfont String     ""  0}
	{-statusbarfont String     ""  0}
................................................................................

    set _widget($path,top)      $top
    set _widget($path,ntoolbar) 0
    set _widget($path,nindic)   0

    set menu [Widget::getoption $path -menu]
    if { [llength $menu] } {
        _create_menubar $path $menu
    }

    bind $path <Destroy> [list MainFrame::_destroy %W]

    return [Widget::create MainFrame $path]
}

................................................................................
    }
}


# ----------------------------------------------------------------------------
#  Command MainFrame::_create_menubar
# ----------------------------------------------------------------------------
proc MainFrame::_create_menubar { path descmenu } {
    variable _widget
    global    tcl_platform

    set top $_widget($path,top)

    foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} {
	if {[string length [Widget::getoption $path $x]]} {
................................................................................
	# [email protected]:  Add mapping from menu items to tags
	set _widget($path,menutags,[list $menubar $count]) $tags

        if { [string length $menuid] } {
            # menu has identifier
            set _widget($path,menuid,$menuid) $menu
        }
        _create_entries $path $menu $menuopts $entries
        incr count
    }
}


# ----------------------------------------------------------------------------
#  Command MainFrame::_create_entries
# ----------------------------------------------------------------------------
proc MainFrame::_create_entries { path menu menuopts entries } {
    variable _widget

    set count      [$menu cget -tearoff]
    set registered 0
    foreach entry $entries {
        set len  [llength $entry]
        set type [lindex $entry 0]
................................................................................
            set submenu $menu.menu$count
            eval [list $menu add cascade] $opt [list -menu $submenu]
            eval [list menu $submenu -tearoff $tearoff] $menuopts
            if { [string length $menuid] } {
                # menu has identifier
                set _widget($path,menuid,$menuid) $submenu
            }
            _create_entries $path $submenu $menuopts [lindex $entry 5]
            incr count
            continue
        }

        # entry help description
        set desc [lindex $entry 3]
        if { [string length $desc] } {
................................................................................
                DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
                set registered 1
            }
            DynamicHelp::register $menu menuentry $count $desc
        }

        # entry accelerator
        set accel [_parse_accelerator [lindex $entry 4]]
        if { [llength $accel] } {
            lappend opt -accelerator [lindex $accel 0]
            bind $_widget($path,top) [lindex $accel 1] [list $menu invoke $count]
        }

        # user options
        set useropt [lrange $entry 5 end]
................................................................................
# MainFrame::_parse_accelerator --
#
#	Given a key combo description, construct an appropriate human readable
#	string (for display on as a menu accelerator) and the corresponding
#	bind event.
#
# Arguments:
#	desc	a list with the following format:
#			?sequence? key
#		sequence may be None, Ctrl, Alt, CtrlAlt, Shift, Cmd or
#			ShiftCmd
#		key may be any key

#
# Results:
#	{accel event}	a list containing the accelerator string and the event

proc MainFrame::_parse_accelerator { desc } {
    set fKey 0
    if { [llength $desc] == 1 } {
	set seq None
	set key [string tolower [lindex $desc 0]]
	# If the key is an F key (ie, F1, F2, etc), it has to be capitalized
	if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} {
	    set key [string toupper $key]
	    set fKey 1
	}
    } elseif { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [string tolower [lindex $desc 1]]
	# If the key is an F key (ie, F1, F2, etc), it has to be capitalized
	if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} {
	    set key [string toupper $key]
	    set fKey 1
	}
    } else {
	return {}
    }

    # Plain "Shift" can be used only with F keys, but "ShiftCmd" is allowed.
    if {[string equal $seq "Shift"] && !$fKey} {
        return -code error {Shift accelerator can be used only with F keys}
    }








    switch -- $seq {
	None {
	    set accel "[string toupper $key]"
	    set event "<Key-$key>"
	}
	Shift {
	    # Used only with Function keys.
	    set accel "Shift+[string toupper $key]"
	    set event "<Shift-Key-$key>"
	}
	Cmd {
	    set accel "Cmd+[string toupper $key]"
	    set event "<Command-Key-$key>"
	}
	ShiftCmd {
	    if {    [string equal [tk windowingsystem] "aqua"] &&
		    [string first AppKit [winfo server .]] == -1
	    } {
		# Carbon
		set accel "Shift+Cmd+[string toupper $key]"
		set event "<Shift-Command-Key-[string toupper $key]>"
	    } else {
		# Cocoa and anything else that uses Cmd
		set accel "Shift+Cmd+[string toupper $key]"
		set event "<Shift-Command-Key-$key>"
	    }
	}
	Ctrl {
	    set accel "Ctrl+[string toupper $key]"
	    set event "<Control-Key-$key>"
	}
	Alt {
	    set accel "Alt+[string toupper $key]"
	    set event "<Alt-Key-$key>"
	}
	CtrlAlt {
	    set accel "Ctrl+Alt+[string toupper $key]"
	    set event "<Control-Alt-Key-$key>"
	}
	default {
	    return -code error "invalid accelerator code $seq"
	}
    }
    return [list $accel $event]
}