You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
857 lines
28 KiB
857 lines
28 KiB
# ---------------------------------------------------------------------------- |
|
# mainframe.tcl |
|
# This file is part of Unifix BWidget Toolkit |
|
# $Id: mainframe.tcl,v 1.24.2.3 2011/05/25 15:10:07 oehhar Exp $ |
|
# ------------------------------------------------------------------------------ |
|
# Index of commands: |
|
# - MainFrame::create |
|
# - MainFrame::configure |
|
# - MainFrame::cget |
|
# - MainFrame::getframe |
|
# - MainFrame::addtoolbar |
|
# - MainFrame::gettoolbar |
|
# - MainFrame::addindicator |
|
# - MainFrame::getindicator |
|
# - MainFrame::getmenu |
|
# - MainFrame::menuonly |
|
# - MainFrame::showtoolbar |
|
# - MainFrame::showstatusbar |
|
# - MainFrame::_create_menubar |
|
# - MainFrame::_create_entries |
|
# - MainFrame::_parse_name |
|
# - MainFrame::_parse_accelerator |
|
# ---------------------------------------------------------------------------- |
|
|
|
namespace eval MainFrame { |
|
Widget::define MainFrame mainframe ProgressBar |
|
|
|
Widget::bwinclude MainFrame ProgressBar .status.prg \ |
|
remove { |
|
-fg -bg -bd -troughcolor -background -borderwidth |
|
-relief -orient -width -height |
|
} \ |
|
rename { |
|
-maximum -progressmax |
|
-variable -progressvar |
|
-type -progresstype |
|
-foreground -progressfg |
|
} |
|
|
|
if {[Widget::theme]} { |
|
# No option -background for themed MainFrame |
|
Widget::declare MainFrame { |
|
{-width TkResource 0 0 frame} |
|
{-height TkResource 0 0 frame} |
|
{-textvariable String "" 0} |
|
{-menu String {} 1} |
|
{-separator Enum both 1 {none top bottom both}} |
|
|
|
{-menubarfont String "" 0} |
|
{-menuentryfont String "" 0} |
|
{-statusbarfont String "" 0} |
|
{-sizegrip Boolean 0 1} |
|
} |
|
|
|
Widget::addmap MainFrame "" .frame {-width {} -height {}} |
|
} else { |
|
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} |
|
{-sizegrip Boolean 0 1} |
|
} |
|
|
|
Widget::addmap MainFrame "" .frame {-width {} -height {} -background {}} |
|
Widget::addmap MainFrame "" .topf {-background {}} |
|
Widget::addmap MainFrame "" .botf {-background {}} |
|
Widget::addmap MainFrame "" .status {-background {}} |
|
Widget::addmap MainFrame "" .status.label {-background {}} |
|
Widget::addmap MainFrame "" .status.indf {-background {}} |
|
Widget::addmap MainFrame "" .status.prgf {-background {}} |
|
Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor} |
|
} |
|
|
|
variable _widget |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::create |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::create { path args } { |
|
global tcl_platform |
|
variable _widget |
|
|
|
if {[Widget::theme]} { |
|
set path [ttk::frame $path] |
|
} else { |
|
set path [frame $path -takefocus 0 -highlightthickness 0] |
|
} |
|
set top [winfo parent $path] |
|
if { ![string equal [winfo toplevel $path] $top] } { |
|
destroy $path |
|
return -code error "parent must be a toplevel" |
|
} |
|
Widget::init MainFrame $path $args |
|
|
|
if { $tcl_platform(platform) == "unix" } { |
|
set relief raised |
|
set bd 1 |
|
} else { |
|
set relief flat |
|
set bd 0 |
|
} |
|
if {[Widget::theme]} { |
|
set userframe [eval [list ttk::frame $path.frame] \ |
|
[Widget::subcget $path .frame]] |
|
set topframe [ttk::frame $path.topf] |
|
set botframe [ttk::frame $path.botf] |
|
} else { |
|
set userframe [eval [list frame $path.frame] \ |
|
[Widget::subcget $path .frame] \ |
|
-relief $relief -borderwidth $bd] |
|
set topframe [eval [list frame $path.topf] \ |
|
[Widget::subcget $path .topf]] |
|
set botframe [eval [list frame $path.botf] \ |
|
-relief $relief -borderwidth $bd \ |
|
[Widget::subcget $path .botf]] |
|
} |
|
|
|
pack $topframe -fill x |
|
grid columnconfigure $topframe 0 -weight 1 |
|
|
|
if {![Widget::theme]} { |
|
set bg [Widget::cget $path -background] |
|
$path configure -background $bg |
|
} |
|
if { $tcl_platform(platform) != "unix" } { |
|
set sepopt [Widget::getoption $path -separator] |
|
if { $sepopt == "both" || $sepopt == "top" } { |
|
if {[Widget::theme]} { |
|
set sep [ttk::separator $path.sep -orient horizontal] |
|
} else { |
|
set sep [Separator::create $path.sep -orient horizontal -background $bg] |
|
} |
|
pack $sep -fill x |
|
} |
|
if { $sepopt == "both" || $sepopt == "bottom" } { |
|
if {[Widget::theme]} { |
|
set sep [ttk::separator $botframe.sep -orient horizontal] |
|
} else { |
|
set sep [Separator::create $botframe.sep -orient horizontal -background $bg] |
|
} |
|
pack $sep -fill x |
|
} |
|
} |
|
|
|
# --- status bar --------------------------------------------------------- |
|
if {[string length [Widget::getoption $path -statusbarfont]]} { |
|
set sbfnt [list -font [Widget::getoption $path -statusbarfont]] |
|
} else { |
|
set sbfnt "" |
|
} |
|
|
|
if {[Widget::theme]} { |
|
set status [ttk::frame $path.status] |
|
set label [eval [list ttk::label $status.label \ |
|
-textvariable [Widget::getoption $path -textvariable]] $sbfnt] |
|
set indframe [ttk::frame $status.indf] |
|
set prgframe [ttk::frame $status.prgf] |
|
} else { |
|
set status [frame $path.status -background $bg] |
|
set label [eval [list label $status.label \ |
|
-textvariable [Widget::getoption $path -textvariable] \ |
|
-background $bg] $sbfnt] |
|
set indframe [frame $status.indf -background $bg] |
|
set prgframe [frame $status.prgf -background $bg] |
|
} |
|
|
|
place $label -anchor w -x 0 -rely 0.5 |
|
place $indframe -anchor ne -relx 1 -y 0 -relheight 1 |
|
pack $prgframe -in $indframe -side left -padx 2 |
|
$status configure -height [winfo reqheight $label] |
|
|
|
set progress [eval [list ProgressBar::create $status.prg] \ |
|
[Widget::subcget $path .status.prg] \ |
|
-width 50 \ |
|
-height [expr {[winfo reqheight $label]-2}] \ |
|
-borderwidth 1 \ |
|
-relief sunken] |
|
if {[Widget::theme] && [Widget::getoption $path -sizegrip]} { |
|
pack [ttk::sizegrip $botframe.sg] -side right -anchor se |
|
} |
|
pack $status -in $botframe -fill x -pady 2 |
|
pack $botframe -side bottom -fill x |
|
pack $userframe -fill both -expand yes |
|
|
|
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] |
|
bind $path <<TkWorldChanged>> [list MainFrame::_world_changed %W %d] |
|
|
|
return [Widget::create MainFrame $path] |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::configure |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::configure { path args } { |
|
variable _widget |
|
|
|
set res [Widget::configure $path $args] |
|
|
|
if { [Widget::hasChanged $path -textvariable newv] } { |
|
uplevel \#0 $path.status.label configure -textvariable [list $newv] |
|
} |
|
|
|
# The ttk frame has no -background |
|
if {![Widget::theme] && [Widget::hasChanged $path -background bg] } { |
|
if {($::tcl_platform(platform) == "unix") |
|
&& (0 != [string compare [tk windowingsystem] "aqua"])} { |
|
set listmenu [$_widget($path,top) cget -menu] |
|
while { [llength $listmenu] } { |
|
set newlist {} |
|
foreach menu $listmenu { |
|
$menu configure -background $bg |
|
set newlist [concat $newlist [winfo children $menu]] |
|
} |
|
set listmenu $newlist |
|
} |
|
} |
|
foreach sep {.sep .botf.sep} { |
|
if {[winfo exists $path.$sep]} { |
|
Separator::configure $path.$sep -background $bg |
|
} |
|
} |
|
foreach w [winfo children $path.topf] { |
|
$w configure -background $bg |
|
} |
|
} |
|
|
|
if { [Widget::hasChanged $path -menubarfont newmbfnt] } { |
|
if {[string length $newmbfnt]} { |
|
set mbfnt [list -font $newmbfnt] |
|
} else { |
|
set mbfnt "" |
|
} |
|
set top $_widget($path,top) |
|
if {[string equal $top .]} { |
|
eval [list .menubar configure] $mbfnt |
|
} else { |
|
eval [list $top.menubar configure] $mbfnt |
|
} |
|
} |
|
if { [Widget::hasChanged $path -menuentryfont newmefnt] } { |
|
if {[string length $newmefnt]} { |
|
set mefnt [list -font $newmefnt] |
|
} else { |
|
set mefnt "" |
|
} |
|
set top $_widget($path,top) |
|
if {[string equal $top .]} { |
|
set mb .menubar |
|
} else { |
|
set mb $top.menubar |
|
} |
|
set l [winfo children $mb] |
|
while {[llength $l]} { |
|
set e [lindex $l 0] |
|
set l [lrange $l 1 end] |
|
if {[string length $e] == 0} {continue} |
|
lappend l [winfo children $e] |
|
eval [list $e configure] $mefnt |
|
} |
|
} |
|
|
|
|
|
if { [Widget::hasChanged $path -statusbarfont newsbfnt] } { |
|
if {[string length $newsbfnt]} { |
|
set sbfnt [list -font $newsbfnt] |
|
} else { |
|
set sbfnt "" |
|
} |
|
for {set index 0} {$index<$_widget($path,nindic)} {incr index} { |
|
set indic $path.status.indf.f$index |
|
eval [list $indic configure] $sbfnt |
|
} |
|
eval [list $path.status.label configure] $sbfnt |
|
_evaluate_status_height $path |
|
} |
|
|
|
return $res |
|
} |
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::cget |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::cget { path option } { |
|
return [Widget::cget $path $option] |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::getframe |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::getframe { path } { |
|
return $path.frame |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::addtoolbar |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::addtoolbar { path } { |
|
global tcl_platform |
|
variable _widget |
|
|
|
set index $_widget($path,ntoolbar) |
|
set toolframe $path.topf.f$index |
|
set toolbar $path.topf.tb$index |
|
if { $tcl_platform(platform) == "unix" } { |
|
if {[Widget::theme]} { |
|
ttk::frame $toolframe -padding 1 |
|
} else { |
|
set bg [Widget::getoption $path -background] |
|
frame $toolframe -relief raised -borderwidth 1 \ |
|
-takefocus 0 -highlightthickness 0 -background $bg |
|
} |
|
} else { |
|
if {[Widget::theme]} { |
|
ttk::frame $toolframe |
|
set sep [ttk::separator $toolframe.sep -orient horizontal] |
|
} else { |
|
set bg [Widget::getoption $path -background] |
|
frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \ |
|
-highlightthickness 0 -background $bg |
|
set sep [Separator::create $toolframe.sep -orient horizontal -background $bg] |
|
} |
|
pack $sep -fill x |
|
} |
|
if {[Widget::theme]} { |
|
set toolbar [ttk::frame $toolbar -padding 2] |
|
} else { |
|
set toolbar [frame $toolbar -relief flat -borderwidth 2 \ |
|
-takefocus 0 -highlightthickness 0 -background $bg] |
|
} |
|
pack $toolbar -in $toolframe -anchor w -expand yes -fill x |
|
incr _widget($path,ntoolbar) |
|
grid $toolframe -column 0 -row $index -sticky ew |
|
return $toolbar |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::gettoolbar |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::gettoolbar { path index } { |
|
return $path.topf.tb$index |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::addindicator |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::addindicator { path args } { |
|
variable _widget |
|
|
|
if {[string length [Widget::getoption $path -statusbarfont]]} { |
|
set sbfnt [list -font [Widget::getoption $path -statusbarfont]] |
|
} else { |
|
set sbfnt "" |
|
} |
|
|
|
set index $_widget($path,nindic) |
|
set indic $path.status.indf.f$index |
|
eval [list label $indic] $args -relief sunken -borderwidth 1 \ |
|
-takefocus 0 -highlightthickness 0 $sbfnt |
|
|
|
pack $indic -side left -anchor w -padx 2 -fill y -expand 1 |
|
|
|
incr _widget($path,nindic) |
|
|
|
return $indic |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::getindicator |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::getindicator { path index } { |
|
return $path.status.indf.f$index |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::getmenu |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::getmenu { path menuid } { |
|
variable _widget |
|
|
|
if { [info exists _widget($path,menuid,$menuid)] } { |
|
return $_widget($path,menuid,$menuid) |
|
} |
|
return "" |
|
} |
|
|
|
|
|
# ----------------------------------------------------------------------------- |
|
# Command MainFrame::setmenustate |
|
# ----------------------------------------------------------------------------- |
|
proc MainFrame::setmenustate { path tag state } { |
|
variable _widget |
|
|
|
# Set menustate to enabled when ALL of its tags are enabled. |
|
|
|
# First see if this is a real tag |
|
if { [info exists _widget($path,tagstate,$tag)] } { |
|
if { ![string equal $state "disabled"] } { |
|
set _widget($path,tagstate,$tag) 1 |
|
} else { |
|
set _widget($path,tagstate,$tag) 0 |
|
} |
|
foreach {menu entry} $_widget($path,tags,$tag) { |
|
set expression "1" |
|
foreach menutag $_widget($path,menutags,[list $menu $entry]) { |
|
append expression " && $_widget($path,tagstate,$menutag)" |
|
} |
|
if { [expr $expression] } { |
|
set state normal |
|
} else { |
|
set state disabled |
|
} |
|
$menu entryconfigure $entry -state $state |
|
} |
|
} |
|
return |
|
} |
|
|
|
# ----------------------------------------------------------------------------- |
|
# Command MainFrame::getmenustate |
|
# ----------------------------------------------------------------------------- |
|
proc MainFrame::getmenustate { path tag } { |
|
variable _widget |
|
|
|
if {$_widget($path,tagstate,$tag)} { |
|
return normal |
|
} else { |
|
return disabled |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------------------------- |
|
# Command MainFrame::menuonly |
|
# ----------------------d------------------------------------------------------ |
|
proc MainFrame::menuonly { path } { |
|
variable _widget |
|
|
|
catch {pack forget $path.sep} |
|
catch {pack forget $path.botf.sep} |
|
catch {pack forget $path.frame} |
|
} |
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::showtoolbar |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::showtoolbar { path index bool } { |
|
variable _widget |
|
|
|
set toolframe $path.topf.f$index |
|
if { [winfo exists $toolframe] } { |
|
if { !$bool && [llength [grid info $toolframe]] } { |
|
grid forget $toolframe |
|
$path.topf configure -height 1 |
|
} elseif { $bool && ![llength [grid info $toolframe]] } { |
|
grid $toolframe -column 0 -row $index -sticky ew |
|
} |
|
} |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::showstatusbar |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::showstatusbar { path name } { |
|
set status $path.status |
|
set botframe $path.botf |
|
if { [string equal $name "none"] } { |
|
pack forget $status |
|
} else { |
|
pack $status -fill x -in $botframe -fill x -pady 2 |
|
switch -- $name { |
|
status { |
|
catch {pack forget $status.prg} |
|
} |
|
progression { |
|
pack $status.prg -in $status.prgf |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::_destroy |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::_destroy { path } { |
|
variable _widget |
|
|
|
Widget::destroy $path |
|
catch {destroy [$_widget($path,top) cget -menu]} |
|
$_widget($path,top) configure -menu {} |
|
|
|
# Unset all of the state vars associated with this main frame. |
|
foreach index [array names _widget $path,*] { |
|
unset _widget($index) |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------------------------- |
|
# Command MainFrame::_world_changed |
|
# ----------------------------------------------------------------------------- |
|
proc MainFrame::_world_changed { path type} { |
|
# Check if font changed |
|
if {$type == "FontChanged"} { |
|
_evaluate_status_height $path |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------------------------- |
|
# Command MainFrame::_evaluate_status_height |
|
# ----------------------------------------------------------------------------- |
|
# Change the status bar height in dependence of the status bar font. |
|
# This is used on configure -statusfont and on world change, where the font |
|
# height may also change. |
|
proc MainFrame::_evaluate_status_height {path} { |
|
$path.status configure -height [winfo reqheight $path.status.label] |
|
|
|
$path.status.prg configure \ |
|
-height [expr {[winfo reqheight $path.status.label]-2}] |
|
} |
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::_create_menubar |
|
# ---------------------------------------------------------------------------- |
|
# For Android, a menubutton is more appropriate. |
|
# To support this, the menubutton widget may be passed as 3rd |
|
# parameter. |
|
proc MainFrame::_create_menubar { path descmenu {top ""} } { |
|
variable _widget |
|
global tcl_platform |
|
|
|
if {![string length $top]} { |
|
set top $_widget($path,top) |
|
} |
|
|
|
foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} { |
|
if {[string length [Widget::getoption $path $x]]} { |
|
set $v [list -font [Widget::getoption $path $x]] |
|
} else { |
|
set $v "" |
|
} |
|
} |
|
|
|
if { ![Widget::theme] && $tcl_platform(platform) == "unix" |
|
&& [tk windowingsystem] !="aqua" } { |
|
set menuopts [list -background [Widget::getoption $path -background] \ |
|
-borderwidth 1] |
|
} else { |
|
set menuopts [list] |
|
} |
|
set menubar [eval [list menu $top.menubar -tearoff 0] $menuopts $mbfnt] |
|
$top configure -menu $menubar |
|
|
|
set count 0 |
|
foreach {name tags menuid tearoff entries} $descmenu { |
|
# Check if only one menu with an empty name is given |
|
# In this case, remove the top level menu item |
|
# This allows to also have checkboxes and commands at the top level. |
|
if {![string length $name] && 5 == [llength $descmenu]} { |
|
# A single namesless menu - skip the first level to allow other |
|
# than cascade as first level. |
|
set menu $menubar |
|
} else { |
|
set opt [_parse_name $name] |
|
if {[string length $menuid] |
|
&& ![info exists _widget($path,menuid,$menuid)] } { |
|
# menu has identifier |
|
# we use it for its pathname, to enable special menu entries |
|
# (help, system, ...) |
|
set menu $menubar.$menuid |
|
} else { |
|
set menu $menubar.menu$count |
|
} |
|
eval [list $menubar add cascade] $opt [list -menu $menu] |
|
eval [list menu $menu -tearoff $tearoff] $menuopts $mefnt |
|
foreach tag $tags { |
|
lappend _widget($path,tags,$tag) $menubar $count |
|
# ericm@scriptics: Add a tagstate tracker |
|
if { ![info exists _widget($path,tagstate,$tag)] } { |
|
set _widget($path,tagstate,$tag) 1 |
|
} |
|
} |
|
# ericm@scriptics: 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] |
|
|
|
if { [string equal $type "separator"] } { |
|
$menu add separator |
|
incr count |
|
continue |
|
} |
|
|
|
# entry name and tags |
|
set opt [_parse_name [lindex $entry 1]] |
|
set tags [lindex $entry 2] |
|
foreach tag $tags { |
|
lappend _widget($path,tags,$tag) $menu $count |
|
# ericm@scriptics: Add a tagstate tracker |
|
if { ![info exists _widget($path,tagstate,$tag)] } { |
|
set _widget($path,tagstate,$tag) 1 |
|
} |
|
} |
|
# ericm@scriptics: Add mapping from menu items to tags |
|
set _widget($path,menutags,[list $menu $count]) $tags |
|
|
|
if {[string equal $type "cascade"] || [string equal $type "cascad"]} { |
|
set menuid [lindex $entry 3] |
|
set tearoff [lindex $entry 4] |
|
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] } { |
|
if { !$registered } { |
|
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] |
|
foreach event [lindex $accel 1] { |
|
bind $_widget($path,top) $event [list $menu invoke $count] |
|
} |
|
foreach event [lindex $accel 2] { |
|
if {[bind $_widget($path,top) $event] == {}} { |
|
bind $_widget($path,top) $event { # do nothing } |
|
} else { |
|
# The existing binding will intercept these events. |
|
} |
|
} |
|
} |
|
|
|
# user options |
|
set useropt [lrange $entry 5 end] |
|
if { [string equal $type "command"] || |
|
[string equal $type "radiobutton"] || |
|
[string equal $type "checkbutton"] } { |
|
eval [list $menu add $type] $opt $useropt |
|
} else { |
|
return -code error "invalid menu type \"$type\"" |
|
} |
|
incr count |
|
} |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# Command MainFrame::_parse_name |
|
# ---------------------------------------------------------------------------- |
|
proc MainFrame::_parse_name { menuname } { |
|
set idx [string first "&" $menuname] |
|
if { $idx == -1 } { |
|
return [list -label $menuname] |
|
} else { |
|
set beg [string range $menuname 0 [expr {$idx-1}]] |
|
set end [string range $menuname [expr {$idx+1}] end] |
|
append beg $end |
|
return [list -label $beg -underline $idx] |
|
} |
|
} |
|
|
|
|
|
# MainFrame::_parse_accelerator -- |
|
# |
|
# Given a key combo description, construct an appropriate human readable |
|
# string (for display on as a menu accelerator), a list of the |
|
# corresponding bind events, and a separate list of bind events that need |
|
# to be blocked. |
|
# |
|
# When argument $desc does not include "Shift", the bindings to $events |
|
# will in some cases also intercept events that have the modifier "Shift", |
|
# unless more specific bindings $blockEvents exist to the latter. This |
|
# situation occurs, for example, when a Cmd binding exists without a |
|
# corresponding ShiftCmd binding. The list of events that need to be |
|
# blocked is returned as the third element of the result. |
|
# |
|
# 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 events blockEvents} a list containing the accelerator string and |
|
# two lists of events |
|
|
|
proc MainFrame::_parse_accelerator { desc } { |
|
variable _widget |
|
|
|
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} |
|
} |
|
|
|
set blockEvents {} |
|
set upc [string toupper $key] |
|
|
|
switch -- $seq { |
|
None { |
|
set accel "$upc" |
|
set events [list "<Key-$key>"] |
|
if {$fKey} { |
|
set blockEvents [list "<Shift-Key-$key>"] |
|
} |
|
} |
|
Shift { |
|
# Used only with Function keys. |
|
set accel "Shift+$upc" |
|
set events [list "<Shift-Key-$key>"] |
|
} |
|
Cmd { |
|
set accel "Cmd+$upc" |
|
|
|
if { [string equal [tk windowingsystem] "aqua"] && |
|
([string first AppKit [winfo server .]] == -1) |
|
} { |
|
# Carbon |
|
set events [list "<Command-Key-$key>" \ |
|
"<Lock-Command-Key-$upc>" ] |
|
set blockEvents [list "<Lock-Shift-Command-Key-$upc>"] |
|
# Both bindings must be included in $events - the first binding |
|
# does not fire if "Lock" is set, and this is as bind(n) states |
|
# because the second binding is NOT a more specialized form of |
|
# the first. |
|
} else { |
|
# Cocoa and anything else that uses Cmd |
|
set events [list "<Command-Key-$key>"] |
|
# A binding to "<Lock-Command-Key-$upc>" must not be included |
|
# here - both events fire if "Lock" is set. |
|
set blockEvents [list "<Shift-Command-Key-$key>"] |
|
} |
|
} |
|
ShiftCmd { |
|
if { [string equal [tk windowingsystem] "aqua"] && |
|
([string first AppKit [winfo server .]] == -1) |
|
} { |
|
# Carbon |
|
set accel "Shift+Cmd+$upc" |
|
set events [list "<Shift-Command-Key-$upc>" \ |
|
"<Lock-Shift-Command-Key-$upc>"] |
|
# Both bindings must be included here - the first binding does |
|
# not fire if "Lock" is set, even though the second binding |
|
# should be recognized as a more specialized form of the first. |
|
} else { |
|
# Cocoa and anything else that uses Cmd |
|
set accel "Shift+Cmd+$upc" |
|
set events [list "<Shift-Command-Key-$key>"] |
|
# A binding to "<Lock-Shift-Command-Key-$key>" must not be |
|
# included here - both events fire if "Lock" is set. |
|
# Tk/Cocoa fails to recognize |
|
# <Lock-Shift-Command-Key-$key> as a "more specialized" binding |
|
# than <Shift-Command-Key-$key>. |
|
# Perversely, Tk/Carbon (above) makes the opposite error. |
|
} |
|
} |
|
Ctrl { |
|
set accel "Ctrl+$upc" |
|
set events [list "<Control-Key-$key>"] |
|
} |
|
Alt { |
|
set accel "Alt+$upc" |
|
set events [list "<Alt-Key-$key>"] |
|
} |
|
CtrlAlt { |
|
set accel "Ctrl+Alt+$upc" |
|
set events [list "<Control-Alt-Key-$key>"] |
|
} |
|
default { |
|
return -code error "invalid accelerator code $seq" |
|
} |
|
} |
|
|
|
return [list $accel $events $blockEvents] |
|
}
|
|
|